diff options
| author | Nicolas Frisby <nicolas.frisby@gmail.com> | 2014-08-19 20:03:23 -0500 |
|---|---|---|
| committer | Nicolas Frisby <nicolas.frisby@gmail.com> | 2014-08-19 20:04:15 -0500 |
| commit | f17ceee98221de21f896ac412b7a7ddcfc35a0c6 (patch) | |
| tree | 3b3237251bee546221b9023b9c7cf0a94bc7d37a /compiler | |
| parent | 4d3f37e0c07f35be51b8bb24374ca3163b8b9a46 (diff) | |
| parent | 15faa0ec3a5a783f3949dcff6adf412d5f21bdf8 (diff) | |
| download | haskell-f17ceee98221de21f896ac412b7a7ddcfc35a0c6.tar.gz | |
Merge branch 'master' into late-lam-lift
Silly conflicts because of new flags -- not sure how best to resolve/avoid this.
git is requiring my commit to mention 'submodule' for some reason?
Conflicts:
compiler/main/DynFlags.hs
Diffstat (limited to 'compiler')
344 files changed, 13064 insertions, 11031 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/ConLike.lhs b/compiler/basicTypes/ConLike.lhs index de10d0fb0a..3414aa4230 100644 --- a/compiler/basicTypes/ConLike.lhs +++ b/compiler/basicTypes/ConLike.lhs @@ -5,6 +5,7 @@ \section[ConLike]{@ConLike@: Constructor-like things} \begin{code} +{-# LANGUAGE CPP, DeriveDataTypeable #-} module ConLike ( ConLike(..) diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index ad56290694..771aa303a1 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -5,7 +5,8 @@ \section[DataCon]{@DataCon@: Data Constructors} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# 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 @@ -941,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 8a082b98ad..ed055b5808 100644 --- a/compiler/basicTypes/Demand.lhs +++ b/compiler/basicTypes/Demand.lhs @@ -5,6 +5,7 @@ \section[Demand]{@Demand@: A decoupled implementation of a demand domain} \begin{code} +{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances #-} module Demand ( StrDmd, UseDmd(..), Count(..), @@ -41,7 +42,7 @@ module Demand ( deferAfterIO, postProcessUnsat, postProcessDmdTypeM, - splitProdDmd, splitProdDmd_maybe, peelCallDmd, mkCallDmd, + splitProdDmd_maybe, peelCallDmd, mkCallDmd, dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig, argOneShots, argsOneShots, trimToType, TypeShape(..), @@ -65,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 @@ -200,11 +201,13 @@ seqMaybeStr Lazy = () seqMaybeStr (Str s) = seqStrDmd s -- Splitting polymorphic demands -splitStrProdDmd :: Int -> StrDmd -> [MaybeStr] -splitStrProdDmd n HyperStr = replicate n strBot -splitStrProdDmd n HeadStr = replicate n strTop -splitStrProdDmd n (SProd ds) = ASSERT( ds `lengthIs` n) ds -splitStrProdDmd _ d@(SCall {}) = pprPanic "attempt to prod-split strictness call demand" (ppr d) +splitStrProdDmd :: Int -> StrDmd -> Maybe [MaybeStr] +splitStrProdDmd n HyperStr = Just (replicate n strBot) +splitStrProdDmd n HeadStr = Just (replicate n strTop) +splitStrProdDmd n (SProd ds) = ASSERT( ds `lengthIs` n) Just ds +splitStrProdDmd _ (SCall {}) = Nothing + -- This can happen when the programmer uses unsafeCoerce, + -- and we don't then want to crash the compiler (Trac #9208) \end{code} %************************************************************************ @@ -441,13 +444,15 @@ seqMaybeUsed (Use c u) = c `seq` seqUseDmd u seqMaybeUsed _ = () -- Splitting polymorphic Maybe-Used demands -splitUseProdDmd :: Int -> UseDmd -> [MaybeUsed] -splitUseProdDmd n Used = replicate n useTop -splitUseProdDmd n UHead = replicate n Abs -splitUseProdDmd n (UProd ds) = ASSERT2( ds `lengthIs` n, text "splitUseProdDmd" $$ ppr n $$ ppr ds ) ds -splitUseProdDmd _ d@(UCall _ _) = pprPanic "attempt to prod-split usage call demand" (ppr d) +splitUseProdDmd :: Int -> UseDmd -> Maybe [MaybeUsed] +splitUseProdDmd n Used = Just (replicate n useTop) +splitUseProdDmd n UHead = Just (replicate n Abs) +splitUseProdDmd n (UProd ds) = ASSERT2( ds `lengthIs` n, text "splitUseProdDmd" $$ ppr n $$ ppr ds ) + Just ds +splitUseProdDmd _ (UCall _ _) = Nothing + -- This can happen when the programmer uses unsafeCoerce, + -- and we don't then want to crash the compiler (Trac #9208) \end{code} - %************************************************************************ %* * \subsection{Joint domain for Strictness and Absence} @@ -719,26 +724,18 @@ can be expanded to saturate a callee's arity. \begin{code} -splitProdDmd :: Arity -> JointDmd -> [JointDmd] -splitProdDmd n (JD {strd = s, absd = u}) - = mkJointDmds (split_str s) (split_abs u) - where - split_str Lazy = replicate n Lazy - split_str (Str s) = splitStrProdDmd n s - - split_abs Abs = replicate n Abs - split_abs (Use _ u) = splitUseProdDmd n u - splitProdDmd_maybe :: JointDmd -> Maybe [JointDmd] -- Split a product into its components, iff there is any -- useful information to be extracted thereby -- The demand is not necessarily strict! splitProdDmd_maybe (JD {strd = s, absd = u}) = case (s,u) of - (Str (SProd sx), Use _ u) -> Just (mkJointDmds sx (splitUseProdDmd (length sx) u)) - (Str s, Use _ (UProd ux)) -> Just (mkJointDmds (splitStrProdDmd (length ux) s) ux) - (Lazy, Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux) - _ -> Nothing + (Str (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u + -> Just (mkJointDmds sx ux) + (Str s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s + -> Just (mkJointDmds sx ux) + (Lazy, Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux) + _ -> Nothing \end{code} %************************************************************************ @@ -1204,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 @@ -1385,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 @@ -1400,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 @@ -1521,12 +1563,12 @@ dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res)) | otherwise -- Not saturated = nopDmdType where - go_str 0 dmd = Just (splitStrProdDmd arity dmd) + go_str 0 dmd = splitStrProdDmd arity dmd go_str n (SCall s') = go_str (n-1) s' go_str n HyperStr = go_str (n-1) HyperStr go_str _ _ = Nothing - go_abs 0 dmd = Just (splitUseProdDmd arity dmd) + go_abs 0 dmd = splitUseProdDmd arity dmd go_abs n (UCall One u') = go_abs (n-1) u' go_abs _ _ = Nothing diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index aada6dccc2..85e9b3083a 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -5,6 +5,8 @@ \section[Id]{@Ids@: Value and constructor identifiers} \begin{code} +{-# LANGUAGE CPP #-} + -- | -- #name_types# -- GHC uses several kinds of name internally: @@ -252,8 +254,9 @@ mkLocalIdWithInfo name ty info = Var.mkLocalVar VanillaId name ty info -- | Create a local 'Id' that is marked as exported. -- This prevents things attached to it from being removed as dead code. -mkExportedLocalId :: Name -> Type -> Id -mkExportedLocalId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo +-- See Note [Exported LocalIds] +mkExportedLocalId :: IdDetails -> Name -> Type -> Id +mkExportedLocalId details name ty = Var.mkExportedLocalVar details name ty vanillaIdInfo -- Note [Free type variables] @@ -305,6 +308,40 @@ mkTemplateLocalsNum :: Int -> [Type] -> [Id] mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys \end{code} +Note [Exported LocalIds] +~~~~~~~~~~~~~~~~~~~~~~~~ +We use mkExportedLocalId for things like + - Dictionary functions (DFunId) + - Wrapper and matcher Ids for pattern synonyms + - Default methods for classes + - etc + +They marked as "exported" in the sense that they should be kept alive +even if apparently unused in other bindings, and not dropped as dead +code by the occurrence analyser. (But "exported" here does not mean +"brought into lexical scope by an import declaration". Indeed these +things are always internal Ids that the user never sees.) + +It's very important that they are *LocalIds*, not GlobalIs, for lots +of reasons: + + * We want to treat them as free variables for the purpose of + dependency analysis (e.g. CoreFVs.exprFreeVars). + + * Look them up in the current substitution when we come across + occurrences of them (in Subst.lookupIdSubst) + + * Ensure that for dfuns that the specialiser does not float dict uses + above their defns, which would prevent good simplifications happening. + + * The strictness analyser treats a occurrence of a GlobalId as + imported and assumes it contains strictness in its IdInfo, which + isn't true if the thing is bound in the same module as the + occurrence. + +In CoreTidy we must make all these LocalIds into GlobalIds, so that in +importing modules (in --make mode) we treat them as properly global. +That is what is happening in, say tidy_insts in TidyPgm. %************************************************************************ %* * diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs index 94b3d2a71e..d9bce17def 100644 --- a/compiler/basicTypes/IdInfo.lhs +++ b/compiler/basicTypes/IdInfo.lhs @@ -8,7 +8,7 @@ Haskell. [WDP 94/11]) \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 diff --git a/compiler/basicTypes/Literal.lhs b/compiler/basicTypes/Literal.lhs index c77915fef6..13fbb4d46d 100644 --- a/compiler/basicTypes/Literal.lhs +++ b/compiler/basicTypes/Literal.lhs @@ -5,7 +5,7 @@ \section[Literal]{@Literal@: Machine literals (unboxed, of course)} \begin{code} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP, DeriveDataTypeable #-} module Literal ( diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 38922fcd00..7816ad9005 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -12,7 +12,8 @@ have a standard form, namely: - primitive operations \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -20,7 +21,7 @@ have a standard form, namely: -- for details module MkId ( - mkDictFunId, mkDictFunTy, mkDictSelId, + mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs, mkPrimOpId, mkFCallId, @@ -66,7 +67,6 @@ import PrimOp import ForeignCall import DataCon import Id -import Var ( mkExportedLocalVar ) import IdInfo import Demand import CoreSyn @@ -272,39 +272,36 @@ at the outside. When dealing with classes it's very convenient to recover the original type signature from the class op selector. \begin{code} -mkDictSelId :: DynFlags - -> Bool -- True <=> don't include the unfolding - -- Little point on imports without -O, because the - -- dictionary itself won't be visible - -> Name -- Name of one of the *value* selectors +mkDictSelId :: Name -- Name of one of the *value* selectors -- (dictionary superclass or method) -> Class -> Id -mkDictSelId dflags no_unf name clas +mkDictSelId name clas = mkGlobalId (ClassOpId clas) name sel_ty info where - sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id)) - -- We can't just say (exprType rhs), because that would give a type - -- C a -> C a - -- for a single-op class (after all, the selector is the identity) - -- But it's type must expose the representation of the dictionary - -- to get (say) C a -> (a -> a) + tycon = classTyCon clas + sel_names = map idName (classAllSelIds clas) + new_tycon = isNewTyCon tycon + [data_con] = tyConDataCons tycon + tyvars = dataConUnivTyVars data_con + arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses + val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name + + sel_ty = mkForAllTys tyvars (mkFunTy (mkClassPred clas (mkTyVarTys tyvars)) + (getNth arg_tys val_index)) base_info = noCafIdInfo `setArityInfo` 1 `setStrictnessInfo` strict_sig - `setUnfoldingInfo` (if no_unf then noUnfolding - else mkImplicitUnfolding dflags rhs) - -- In module where class op is defined, we must add - -- the unfolding, even though it'll never be inlined - -- because we use that to generate a top-level binding - -- for the ClassOp - - info | new_tycon = base_info `setInlinePragInfo` alwaysInlinePragma + + info | new_tycon + = base_info `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkInlineUnfolding (Just 1) (mkDictSelRhs clas val_index) -- See Note [Single-method classes] in TcInstDcls -- for why alwaysInlinePragma - | otherwise = base_info `setSpecInfo` mkSpecInfo [rule] - `setInlinePragInfo` neverInlinePragma - -- Add a magic BuiltinRule, and never inline it + + | otherwise + = base_info `setSpecInfo` mkSpecInfo [rule] + -- Add a magic BuiltinRule, but no unfolding -- so that the rule is always available to fire. -- See Note [ClassOp/DFun selection] in TcInstDcls @@ -326,25 +323,26 @@ mkDictSelId dflags no_unf name clas strict_sig = mkClosedStrictSig [arg_dmd] topRes arg_dmd | new_tycon = evalDmd | otherwise = mkManyUsedDmd $ - mkProdDmd [ if the_arg_id == id then evalDmd else absDmd - | id <- arg_ids ] - + mkProdDmd [ if name == sel_name then evalDmd else absDmd + | sel_name <- sel_names ] + +mkDictSelRhs :: Class + -> Int -- 0-indexed selector among (superclasses ++ methods) + -> CoreExpr +mkDictSelRhs clas val_index + = mkLams tyvars (Lam dict_id rhs_body) + where tycon = classTyCon clas new_tycon = isNewTyCon tycon [data_con] = tyConDataCons tycon tyvars = dataConUnivTyVars data_con arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses - -- 'index' is a 0-index into the *value* arguments of the dictionary - val_index = assoc "MkId.mkDictSelId" sel_index_prs name - sel_index_prs = map idName (classAllSelIds clas) `zip` [0..] - the_arg_id = getNth arg_ids val_index pred = mkClassPred clas (mkTyVarTys tyvars) dict_id = mkTemplateLocal 1 pred arg_ids = mkTemplateLocalsNum 2 arg_tys - rhs = mkLams tyvars (Lam dict_id rhs_body) rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id) | otherwise = Case (Var dict_id) dict_id (idType the_arg_id) [(DataAlt data_con, arg_ids, varToCoreExpr the_arg_id)] @@ -956,29 +954,13 @@ mkFCallId dflags uniq fcall ty %* * %************************************************************************ -Important notes about dict funs and default methods -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Dict funs and default methods] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Dict funs and default methods are *not* ImplicitIds. Their definition involves user-written code, so we can't figure out their strictness etc based on fixed info, as we can for constructors and record selectors (say). -We build them as LocalIds, but with External Names. This ensures that -they are taken to account by free-variable finding and dependency -analysis (e.g. CoreFVs.exprFreeVars). - -Why shouldn't they be bound as GlobalIds? Because, in particular, if -they are globals, the specialiser floats dict uses above their defns, -which prevents good simplifications happening. Also the strictness -analyser treats a occurrence of a GlobalId as imported and assumes it -contains strictness in its IdInfo, which isn't true if the thing is -bound in the same module as the occurrence. - -It's OK for dfuns to be LocalIds, because we form the instance-env to -pass on to the next module (md_insts) in CoreTidy, afer tidying -and globalising the top-level Ids. - -BUT make sure they are *exported* LocalIds (mkExportedLocalId) so -that they aren't discarded by the occurrence analyser. +NB: See also Note [Exported LocalIds] in Id \begin{code} mkDictFunId :: Name -- Name to use for the dict fun; @@ -988,12 +970,12 @@ mkDictFunId :: Name -- Name to use for the dict fun; -> [Type] -> Id -- Implements the DFun Superclass Invariant (see TcInstDcls) +-- See Note [Dict funs and default methods] mkDictFunId dfun_name tvs theta clas tys - = mkExportedLocalVar (DFunId n_silent is_nt) - dfun_name - dfun_ty - vanillaIdInfo + = mkExportedLocalId (DFunId n_silent is_nt) + dfun_name + dfun_ty where is_nt = isNewTyCon (classTyCon clas) (n_silent, dfun_ty) = mkDictFunTy tvs theta clas tys diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs index 90bf717a85..8f21d66bc1 100644 --- a/compiler/basicTypes/Module.lhs +++ b/compiler/basicTypes/Module.lhs @@ -9,6 +9,7 @@ These are Uniquable, hence we can build Maps with Modules as the keys. \begin{code} +{-# LANGUAGE DeriveDataTypeable #-} module Module ( @@ -22,30 +23,31 @@ module Module mkModuleNameFS, stableModuleNameCmp, - -- * The PackageId type - PackageId, - fsToPackageId, - packageIdFS, - stringToPackageId, - packageIdString, - stablePackageIdCmp, + -- * The PackageKey type + PackageKey, + fsToPackageKey, + packageKeyFS, + stringToPackageKey, + packageKeyString, + stablePackageKeyCmp, - -- * Wired-in PackageIds + -- * 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, @@ -81,6 +83,7 @@ import UniqFM import FastString import Binary import Util +import {-# SOURCE #-} Packages import Data.Data import Data.Map (Map) @@ -227,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 @@ -255,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 @@ -287,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 -- ----------------------------------------------------------------------------- @@ -347,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 @@ -355,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 e2742bb3a8..7651c7c749 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -5,6 +5,8 @@ \section[Name]{@Name@: to transmit name info from renamer to typechecker} \begin{code} +{-# LANGUAGE DeriveDataTypeable #-} + -- | -- #name_types# -- GHC uses several kinds of name internally: @@ -501,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/NameEnv.lhs b/compiler/basicTypes/NameEnv.lhs index 292ee3d1ec..f39627706d 100644 --- a/compiler/basicTypes/NameEnv.lhs +++ b/compiler/basicTypes/NameEnv.lhs @@ -5,7 +5,8 @@ \section[NameEnv]{@NameEnv@: name environments} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 diff --git a/compiler/basicTypes/NameSet.lhs b/compiler/basicTypes/NameSet.lhs index ed42c2b1aa..9cd9fcef93 100644 --- a/compiler/basicTypes/NameSet.lhs +++ b/compiler/basicTypes/NameSet.lhs @@ -4,7 +4,8 @@ % \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index 66e6550297..d942362db7 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -4,6 +4,8 @@ % \begin{code} +{-# LANGUAGE DeriveDataTypeable #-} + -- | -- #name_types# -- GHC uses several kinds of name internally: @@ -20,7 +22,7 @@ -- -- * 'Var.Var': see "Var#name_types" -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -30,6 +32,8 @@ module OccName ( -- * The 'NameSpace' type NameSpace, -- Abstract + + nameSpacesRelated, -- ** Construction -- $real_vs_source_data_constructors @@ -51,7 +55,6 @@ module OccName ( mkTcOcc, mkTcOccFS, mkClsOcc, mkClsOccFS, mkDFunOcc, - mkTupleOcc, setOccNameSpace, demoteOccName, HasOccName(..), @@ -82,14 +85,12 @@ module OccName ( isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace, - isTupleOcc_maybe, - -- * The 'OccEnv' type OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv, lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv, occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C, extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv, - alterOccEnv, + alterOccEnv, pprOccEnv, -- * The 'OccSet' type OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, @@ -103,12 +104,14 @@ module OccName ( -- * Lexical characteristics of Haskell names isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym, isLexVarId, isLexVarSym, - startsVarSym, startsVarId, startsConSym, startsConId + startsVarSym, startsVarId, startsConSym, startsConId, + + -- FsEnv + FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv ) where import Util import Unique -import BasicTypes import DynFlags import UniqFM import UniqSet @@ -121,6 +124,29 @@ import Data.Data %************************************************************************ %* * + FastStringEnv +%* * +%************************************************************************ + +FastStringEnv can't be in FastString because the env depends on UniqFM + +\begin{code} +type FastStringEnv a = UniqFM a -- Keyed by FastString + + +emptyFsEnv :: FastStringEnv a +lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a +extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a +mkFsEnv :: [(FastString,a)] -> FastStringEnv a + +emptyFsEnv = emptyUFM +lookupFsEnv = lookupUFM +extendFsEnv = addToUFM +mkFsEnv = listToUFM +\end{code} + +%************************************************************************ +%* * \subsection{Name space} %* * %************************************************************************ @@ -248,6 +274,9 @@ instance Data OccName where toConstr _ = abstractConstr "OccName" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "OccName" + +instance HasOccName OccName where + occName = id \end{code} @@ -343,7 +372,20 @@ demoteOccName (OccName space name) = do space' <- demoteNameSpace space return $ OccName space' name -{- | Other names in the compiler add aditional information to an OccName. +-- Name spaces are related if there is a chance to mean the one when one writes +-- the other, i.e. variables <-> data constructors and type variables <-> type constructors +nameSpacesRelated :: NameSpace -> NameSpace -> Bool +nameSpacesRelated ns1 ns2 = ns1 == ns2 || otherNameSpace ns1 == ns2 + +otherNameSpace :: NameSpace -> NameSpace +otherNameSpace VarName = DataName +otherNameSpace DataName = VarName +otherNameSpace TvName = TcClsName +otherNameSpace TcClsName = TvName + + + +{- | Other names in the compiler add additional information to an OccName. This class provides a consistent way to access the underlying OccName. -} class HasOccName name where occName :: name -> OccName @@ -420,7 +462,10 @@ filterOccEnv x (A y) = A $ filterUFM x y alterOccEnv fn (A y) k = A $ alterUFM fn y k instance Outputable a => Outputable (OccEnv a) where - ppr (A x) = ppr x + ppr x = pprOccEnv ppr x + +pprOccEnv :: (a -> SDoc) -> OccEnv a -> SDoc +pprOccEnv ppr_elt (A env) = pprUniqFM ppr_elt env type OccSet = UniqSet OccName @@ -813,55 +858,6 @@ tidyOccName env occ@(OccName occ_sp fs) %************************************************************************ %* * - Stuff for dealing with tuples -%* * -%************************************************************************ - -\begin{code} -mkTupleOcc :: NameSpace -> TupleSort -> Arity -> OccName -mkTupleOcc ns sort ar = OccName ns (mkFastString str) - where - -- no need to cache these, the caching is done in the caller - -- (TysWiredIn.mk_tuple) - str = case sort of - UnboxedTuple -> '(' : '#' : commas ++ "#)" - BoxedTuple -> '(' : commas ++ ")" - ConstraintTuple -> '(' : commas ++ ")" - -- Cute hack: reuse the standard tuple OccNames (and hence code) - -- for fact tuples, but give them different Uniques so they are not equal. - -- - -- You might think that this will go wrong because isTupleOcc_maybe won't - -- be able to tell the difference between boxed tuples and fact tuples. BUT: - -- 1. Fact tuples never occur directly in user code, so it doesn't matter - -- that we can't detect them in Orig OccNames originating from the user - -- programs (or those built by setRdrNameSpace used on an Exact tuple Name) - -- 2. Interface files have a special representation for tuple *occurrences* - -- in IfaceTyCons, their workers (in IfaceSyn) and their DataCons (in case - -- alternatives). Thus we don't rely on the OccName to figure out what kind - -- of tuple an occurrence was trying to use in these situations. - -- 3. We *don't* represent tuple data type declarations specially, so those - -- are still turned into wired-in names via isTupleOcc_maybe. But that's OK - -- because we don't actually need to declare fact tuples thanks to this hack. - -- - -- So basically any OccName like (,,) flowing to isTupleOcc_maybe will always - -- refer to the standard boxed tuple. Cool :-) - - commas = take (ar-1) (repeat ',') - -isTupleOcc_maybe :: OccName -> Maybe (NameSpace, TupleSort, Arity) --- Tuples are special, because there are so many of them! -isTupleOcc_maybe (OccName ns fs) - = case unpackFS fs of - '(':'#':',':rest -> Just (ns, UnboxedTuple, 2 + count_commas rest) - '(':',':rest -> Just (ns, BoxedTuple, 2 + count_commas rest) - _other -> Nothing - where - count_commas (',':rest) = 1 + count_commas rest - count_commas _ = 0 -\end{code} - -%************************************************************************ -%* * \subsection{Lexical categories} %* * %************************************************************************ @@ -905,9 +901,12 @@ isLexConSym cs -- Infix type or data constructors | otherwise = startsConSym (headFS cs) isLexVarSym fs -- Infix identifiers e.g. "+" + | fs == (fsLit "~R#") = True + | otherwise = case (if nullFS fs then [] else unpackFS fs) of [] -> False (c:cs) -> startsVarSym c && all isVarSymChar cs + -- See Note [Classification of generated names] ------------- startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool diff --git a/compiler/basicTypes/PatSyn.lhs b/compiler/basicTypes/PatSyn.lhs index 9285b3c365..cba8427292 100644 --- a/compiler/basicTypes/PatSyn.lhs +++ b/compiler/basicTypes/PatSyn.lhs @@ -5,21 +5,25 @@ \section[PatSyn]{@PatSyn@: Pattern synonyms} \begin{code} +{-# LANGUAGE CPP, DeriveDataTypeable #-} module PatSyn ( -- * Main data types PatSyn, mkPatSyn, -- ** Type deconstruction - patSynId, patSynType, patSynArity, patSynIsInfix, - patSynArgs, patSynArgTys, patSynTyDetails, + patSynName, patSynArity, patSynIsInfix, + patSynArgs, patSynTyDetails, patSynType, patSynWrapper, patSynMatcher, - patSynExTyVars, patSynSig, patSynInstArgTys + patSynExTyVars, patSynSig, + patSynInstArgTys, patSynInstResTy, + tidyPatSynIds, patSynIds ) where #include "HsVersions.h" import Type +import TcType( mkSigmaTy ) import Name import Outputable import Unique @@ -27,8 +31,6 @@ import Util import BasicTypes import FastString import Var -import Id -import TcType import HsBinds( HsPatSynDetails(..) ) import qualified Data.Data as Data @@ -37,8 +39,8 @@ import Data.Function \end{code} -Pattern synonym representation -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Pattern synonym representation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following pattern synonym declaration pattern P x = MkT [x] (Just 42) @@ -58,15 +60,49 @@ with the following typeclass constraints: In this case, the fields of MkPatSyn will be set as follows: - psArgs = [x :: b] + psArgs = [b] psArity = 1 psInfix = False psUnivTyVars = [t] psExTyVars = [b] - psTheta = ((Show (Maybe t), Ord b), (Eq t, Num t)) + psProvTheta = (Show (Maybe t), Ord b) + psReqTheta = (Eq t, Num t) psOrigResTy = T (Maybe t) +Note [Matchers and wrappers for pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For each pattern synonym, we generate a single matcher function which +implements the actual matching. For the above example, the matcher +will have type: + + $mP :: forall r t. (Eq t, Num t) + => T (Maybe t) + -> (forall b. (Show (Maybe t), Ord b) => b -> r) + -> r + -> r + +with the following implementation: + + $mP @r @t $dEq $dNum scrut cont fail = case scrut of + MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x + _ -> fail + +For *bidirectional* pattern synonyms, we also generate a single wrapper +function which implements the pattern synonym in an expression +context. For our running example, it will be: + + $WP :: forall t b. (Show (Maybe t), Ord b, Eq t, Num t) + => b -> T (Maybe t) + $WP x = MkT [x] (Just 42) + +NB: the existential/universal and required/provided split does not +apply to the wrapper since you are only putting stuff in, not getting +stuff out. + +Injectivity of bidirectional pattern synonyms is checked in +tcPatToExpr which walks the pattern and returns its corresponding +expression when available. %************************************************************************ %* * @@ -76,21 +112,36 @@ In this case, the fields of MkPatSyn will be set as follows: \begin{code} -- | A pattern synonym +-- See Note [Pattern synonym representation] data PatSyn = MkPatSyn { - psId :: Id, - psUnique :: Unique, -- Cached from Name - psMatcher :: Id, - psWrapper :: Maybe Id, + psName :: Name, + psUnique :: Unique, -- Cached from Name - psArgs :: [Var], - psArity :: Arity, -- == length psArgs - psInfix :: Bool, -- True <=> declared infix + psArgs :: [Type], + psArity :: Arity, -- == length psArgs + psInfix :: Bool, -- True <=> declared infix - psUnivTyVars :: [TyVar], -- Universially-quantified type variables - psExTyVars :: [TyVar], -- Existentially-quantified type vars - psTheta :: (ThetaType, ThetaType), -- Provided and required dictionaries - psOrigResTy :: Type + psUnivTyVars :: [TyVar], -- Universially-quantified type variables + psExTyVars :: [TyVar], -- Existentially-quantified type vars + psProvTheta :: ThetaType, -- Provided dictionaries + psReqTheta :: ThetaType, -- Required dictionaries + psOrigResTy :: Type, -- Mentions only psUnivTyVars + + -- See Note [Matchers and wrappers for pattern synonyms] + psMatcher :: Id, + -- Matcher function, of type + -- forall r univ_tvs. req_theta + -- => res_ty + -- -> (forall ex_tvs. prov_theta -> arg_tys -> r) + -- -> r -> r + + psWrapper :: Maybe Id + -- Nothing => uni-directional pattern synonym + -- Just wid => bi-direcitonal + -- Wrapper function, of type + -- forall univ_tvs, ex_tvs. (prov_theta, req_theta) + -- => arg_tys -> res_ty } deriving Data.Typeable.Typeable \end{code} @@ -117,7 +168,7 @@ instance Uniquable PatSyn where getUnique = psUnique instance NamedThing PatSyn where - getName = getName . psId + getName = patSynName instance Outputable PatSyn where ppr = ppr . getName @@ -144,7 +195,7 @@ instance Data.Data PatSyn where -- | Build a new pattern synonym mkPatSyn :: Name -> Bool -- ^ Is the pattern synonym declared infix? - -> [Var] -- ^ Original arguments + -> [Type] -- ^ Original arguments -> [TyVar] -- ^ Universially-quantified type variables -> [TyVar] -- ^ Existentially-quantified type variables -> ThetaType -- ^ Wanted dicts @@ -158,29 +209,30 @@ mkPatSyn name declared_infix orig_args prov_theta req_theta orig_res_ty matcher wrapper - = MkPatSyn {psId = id, psUnique = getUnique name, + = MkPatSyn {psName = name, psUnique = getUnique name, psUnivTyVars = univ_tvs, psExTyVars = ex_tvs, - psTheta = (prov_theta, req_theta), + psProvTheta = prov_theta, psReqTheta = req_theta, psInfix = declared_infix, psArgs = orig_args, psArity = length orig_args, psOrigResTy = orig_res_ty, psMatcher = matcher, psWrapper = wrapper } - where - pat_ty = mkSigmaTy univ_tvs req_theta $ - mkSigmaTy ex_tvs prov_theta $ - mkFunTys (map varType orig_args) orig_res_ty - id = mkLocalId name pat_ty \end{code} \begin{code} -- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification -patSynId :: PatSyn -> Id -patSynId = psId +patSynName :: PatSyn -> Name +patSynName = psName patSynType :: PatSyn -> Type -patSynType = psOrigResTy +-- The full pattern type, used only in error messages +patSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta + , psExTyVars = ex_tvs, psProvTheta = prov_theta + , psArgs = orig_args, psOrigResTy = orig_res_ty }) + = mkSigmaTy univ_tvs req_theta $ + mkSigmaTy ex_tvs prov_theta $ + mkFunTys orig_args orig_res_ty -- | Should the 'PatSyn' be presented infix? patSynIsInfix :: PatSyn -> Bool @@ -190,22 +242,24 @@ patSynIsInfix = psInfix patSynArity :: PatSyn -> Arity patSynArity = psArity -patSynArgs :: PatSyn -> [Var] +patSynArgs :: PatSyn -> [Type] patSynArgs = psArgs -patSynArgTys :: PatSyn -> [Type] -patSynArgTys = map varType . patSynArgs - patSynTyDetails :: PatSyn -> HsPatSynDetails Type -patSynTyDetails ps = case (patSynIsInfix ps, patSynArgTys ps) of - (True, [left, right]) -> InfixPatSyn left right - (_, tys) -> PrefixPatSyn tys +patSynTyDetails (MkPatSyn { psInfix = is_infix, psArgs = arg_tys }) + | is_infix, [left,right] <- arg_tys + = InfixPatSyn left right + | otherwise + = PrefixPatSyn arg_tys patSynExTyVars :: PatSyn -> [TyVar] patSynExTyVars = psExTyVars -patSynSig :: PatSyn -> ([TyVar], [TyVar], (ThetaType, ThetaType)) -patSynSig ps = (psUnivTyVars ps, psExTyVars ps, psTheta ps) +patSynSig :: PatSyn -> ([TyVar], [TyVar], ThetaType, ThetaType, [Type], Type) +patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs + , psProvTheta = prov, psReqTheta = req + , psArgs = arg_tys, psOrigResTy = res_ty }) + = (univ_tvs, ex_tvs, prov, req, arg_tys, res_ty) patSynWrapper :: PatSyn -> Maybe Id patSynWrapper = psWrapper @@ -213,13 +267,43 @@ patSynWrapper = psWrapper patSynMatcher :: PatSyn -> Id patSynMatcher = psMatcher +patSynIds :: PatSyn -> [Id] +patSynIds (MkPatSyn { psMatcher = match_id, psWrapper = mb_wrap_id }) + = case mb_wrap_id of + Nothing -> [match_id] + Just wrap_id -> [match_id, wrap_id] + +tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn +tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = match_id, psWrapper = mb_wrap_id }) + = ps { psMatcher = tidy_fn match_id, psWrapper = fmap tidy_fn mb_wrap_id } + patSynInstArgTys :: PatSyn -> [Type] -> [Type] -patSynInstArgTys ps inst_tys +-- Return the types of the argument patterns +-- e.g. data D a = forall b. MkD a b (b->a) +-- pattern P f x y = MkD (x,True) y f +-- D :: forall a. forall b. a -> b -> (b->a) -> D a +-- P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c +-- patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb] +-- NB: the inst_tys should be both universal and existential +patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs + , psExTyVars = ex_tvs, psArgs = arg_tys }) + inst_tys = ASSERT2( length tyvars == length inst_tys - , ptext (sLit "patSynInstArgTys") <+> ppr ps $$ ppr tyvars $$ ppr inst_tys ) + , ptext (sLit "patSynInstArgTys") <+> ppr name $$ ppr tyvars $$ ppr inst_tys ) map (substTyWith tyvars inst_tys) arg_tys where - (univ_tvs, ex_tvs, _) = patSynSig ps - arg_tys = map varType (psArgs ps) tyvars = univ_tvs ++ ex_tvs + +patSynInstResTy :: PatSyn -> [Type] -> Type +-- Return the type of whole pattern +-- E.g. pattern P x y = Just (x,x,y) +-- P :: a -> b -> Just (a,a,b) +-- (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool) +-- NB: unlikepatSynInstArgTys, the inst_tys should be just the *universal* tyvars +patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs + , psOrigResTy = res_ty }) + inst_tys + = ASSERT2( length univ_tvs == length inst_tys + , ptext (sLit "patSynInstResTy") <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys ) + substTyWith univ_tvs inst_tys res_ty \end{code} diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index 3ff771f0fe..d4afaf10fc 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -4,7 +4,7 @@ % \begin{code} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP, DeriveDataTypeable #-} -- | -- #name_types# @@ -331,49 +331,71 @@ instance Ord RdrName where -- It is keyed by OccName, because we never use it for qualified names -- We keep the current mapping, *and* the set of all Names in scope -- Reason: see Note [Splicing Exact Names] in RnEnv -type LocalRdrEnv = (OccEnv Name, NameSet) +data LocalRdrEnv = LRE { lre_env :: OccEnv Name + , lre_in_scope :: NameSet } + +instance Outputable LocalRdrEnv where + ppr (LRE {lre_env = env, lre_in_scope = ns}) + = hang (ptext (sLit "LocalRdrEnv {")) + 2 (vcat [ ptext (sLit "env =") <+> pprOccEnv ppr_elt env + , ptext (sLit "in_scope =") <+> braces (pprWithCommas ppr (nameSetToList ns)) + ] <+> char '}') + where + ppr_elt name = parens (ppr (getUnique (nameOccName name))) <+> ppr name + -- So we can see if the keys line up correctly emptyLocalRdrEnv :: LocalRdrEnv -emptyLocalRdrEnv = (emptyOccEnv, emptyNameSet) +emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv, lre_in_scope = emptyNameSet } extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv -- The Name should be a non-top-level thing -extendLocalRdrEnv (env, ns) name +extendLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) name = WARN( isExternalName name, ppr name ) - ( extendOccEnv env (nameOccName name) name - , addOneToNameSet ns name - ) + LRE { lre_env = extendOccEnv env (nameOccName name) name + , lre_in_scope = addOneToNameSet ns name } extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv -extendLocalRdrEnvList (env, ns) names +extendLocalRdrEnvList (LRE { lre_env = env, lre_in_scope = ns }) names = WARN( any isExternalName names, ppr names ) - ( extendOccEnvList env [(nameOccName n, n) | n <- names] - , addListToNameSet ns names - ) + LRE { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names] + , lre_in_scope = addListToNameSet ns names } lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name -lookupLocalRdrEnv (env, _) (Unqual occ) = lookupOccEnv env occ -lookupLocalRdrEnv _ _ = Nothing +lookupLocalRdrEnv (LRE { lre_env = env }) (Unqual occ) = lookupOccEnv env occ +lookupLocalRdrEnv _ _ = Nothing lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name -lookupLocalRdrOcc (env, _) occ = lookupOccEnv env occ +lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool -elemLocalRdrEnv rdr_name (env, _) - | isUnqual rdr_name = rdrNameOcc rdr_name `elemOccEnv` env - | otherwise = False +elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns }) + = case rdr_name of + Unqual occ -> occ `elemOccEnv` env + Exact name -> name `elemNameSet` ns -- See Note [Local bindings with Exact Names] + Qual {} -> False + Orig {} -> False localRdrEnvElts :: LocalRdrEnv -> [Name] -localRdrEnvElts (env, _) = occEnvElts env +localRdrEnvElts (LRE { lre_env = env }) = occEnvElts env inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool -- This is the point of the NameSet -inLocalRdrEnvScope name (_, ns) = name `elemNameSet` ns +inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv -delLocalRdrEnvList (env, ns) occs = (delListFromOccEnv env occs, ns) +delLocalRdrEnvList (LRE { lre_env = env, lre_in_scope = ns }) occs + = LRE { lre_env = delListFromOccEnv env occs + , lre_in_scope = ns } \end{code} +Note [Local bindings with Exact Names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With Template Haskell we can make local bindings that have Exact Names. +Computing shadowing etc may use elemLocalRdrEnv (at least it certainly +does so in RnTpes.bindHsTyVars), so for an Exact Name we must consult +the in-scope-name-set. + + %************************************************************************ %* * GlobalRdrEnv @@ -795,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/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs index d53ac2b0ea..ab58a4f9f5 100644 --- a/compiler/basicTypes/SrcLoc.lhs +++ b/compiler/basicTypes/SrcLoc.lhs @@ -3,6 +3,7 @@ % \begin{code} +{-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} -- Workaround for Trac #5252 crashes the bootstrap compiler without -O -- When the earliest compiler we want to boostrap with is diff --git a/compiler/basicTypes/UniqSupply.lhs b/compiler/basicTypes/UniqSupply.lhs index fea1489efb..6ceee20793 100644 --- a/compiler/basicTypes/UniqSupply.lhs +++ b/compiler/basicTypes/UniqSupply.lhs @@ -4,6 +4,8 @@ % \begin{code} +{-# LANGUAGE UnboxedTuples #-} + module UniqSupply ( -- * Main data type UniqSupply, -- Abstractly diff --git a/compiler/basicTypes/Unique.lhs b/compiler/basicTypes/Unique.lhs index 037aed0641..897b093e39 100644 --- a/compiler/basicTypes/Unique.lhs +++ b/compiler/basicTypes/Unique.lhs @@ -16,7 +16,7 @@ Some of the other hair in this code is to be able to use a Haskell). \begin{code} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP, BangPatterns, MagicHash #-} module Unique ( -- * Main data types diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs index 70c5d4491a..1f20d4adec 100644 --- a/compiler/basicTypes/Var.lhs +++ b/compiler/basicTypes/Var.lhs @@ -5,7 +5,8 @@ \section{@Vars@: Variables} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# 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 diff --git a/compiler/basicTypes/VarSet.lhs b/compiler/basicTypes/VarSet.lhs index b756283b91..8b7f755dcd 100644 --- a/compiler/basicTypes/VarSet.lhs +++ b/compiler/basicTypes/VarSet.lhs @@ -4,7 +4,8 @@ % \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 diff --git a/compiler/cmm/Bitmap.hs b/compiler/cmm/Bitmap.hs index 54db1a9a67..e7aa072063 100644 --- a/compiler/cmm/Bitmap.hs +++ b/compiler/cmm/Bitmap.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- -- (c) The University of Glasgow 2003-2006 -- diff --git a/compiler/cmm/BlockId.hs b/compiler/cmm/BlockId.hs index 8a46aed8f0..e4cc0bccb7 100644 --- a/compiler/cmm/BlockId.hs +++ b/compiler/cmm/BlockId.hs @@ -1,5 +1,7 @@ -{- BlockId module should probably go away completely, being superseded by Label -} +{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + +{- BlockId module should probably go away completely, being superseded by Label -} module BlockId ( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet , BlockSet, BlockEnv 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 fadce0b5eb..9e9bae93c6 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -1,5 +1,5 @@ -- Cmm representations using Hoopl's Graph CmmNode e x. -{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP, GADTs #-} module Cmm ( -- * Cmm top-level datatypes @@ -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 16ace5245f..6521a84006 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP, GADTs #-} -- See Note [Deprecations in Hoopl] in Hoopl module {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} @@ -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/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs index 60e2c8c8f7..f36fc0bae5 100644 --- a/compiler/cmm/CmmCallConv.hs +++ b/compiler/cmm/CmmCallConv.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module CmmCallConv ( ParamLocation(..), diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs index 0c0c9714ec..1d6c97f41e 100644 --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -1,4 +1,7 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} module CmmExpr diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 42c9e6ba53..3bfc728ac0 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -1,10 +1,4 @@ -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - +{-# LANGUAGE CPP #-} module CmmInfo ( mkEmptyContInfoTable, cmmToRawCmm, @@ -61,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 @@ -83,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 @@ -167,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) @@ -215,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)) @@ -230,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, []) } @@ -280,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 @@ -292,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 @@ -304,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. @@ -331,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 @@ -342,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) @@ -356,7 +350,7 @@ mkLivenessBits dflags liveness ------------------------------------------------------------------------- -- --- Generating a standard info table +-- Generating a standard info table -- ------------------------------------------------------------------------- @@ -369,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 @@ -416,7 +410,7 @@ srtEscape dflags = toStgHalfWord dflags (-1) ------------------------------------------------------------------------- -- --- Accessing fields of an info table +-- Accessing fields of an info table -- ------------------------------------------------------------------------- @@ -491,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 @@ -514,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 @@ -546,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 bdc947829d..c582b783f2 100644 --- a/compiler/cmm/CmmLayoutStack.hs +++ b/compiler/cmm/CmmLayoutStack.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards, GADTs #-} +{-# LANGUAGE CPP, RecordWildCards, GADTs #-} module CmmLayoutStack ( cmmLayoutStack, setInfoTableStackMap ) where @@ -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/CmmLive.hs b/compiler/cmm/CmmLive.hs index 24202cbe8c..dfacd139b6 100644 --- a/compiler/cmm/CmmLive.hs +++ b/compiler/cmm/CmmLive.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs index 684a4b9729..a7b2c85175 100644 --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module CmmMachOp ( MachOp(..) @@ -18,6 +19,9 @@ module CmmMachOp -- CallishMachOp , CallishMachOp(..), callishMachOpHints , pprCallishMachOp + + -- Atomic read-modify-write + , AtomicMachOp(..) ) where @@ -545,9 +549,28 @@ data CallishMachOp | MO_Memmove | MO_PopCnt Width + | MO_Clz Width + | MO_Ctz 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/CmmNode.hs b/compiler/cmm/CmmNode.hs index 5c520d3899..7eb2b61d9a 100644 --- a/compiler/cmm/CmmNode.hs +++ b/compiler/cmm/CmmNode.hs @@ -1,9 +1,14 @@ --- CmmNode type for representation using Hoopl graphs. +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} +-- CmmNode type for representation using Hoopl graphs. + module CmmNode ( CmmNode(..), CmmFormal, CmmActual, UpdFrameOffset, Convention(..), diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index 54dbbebae6..84499b97de 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Cmm optimisation 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 1447f6d8cd..af4f62a4a8 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns #-} + module CmmPipeline ( -- | Converts C-- with an implicit stack and native C-- calls into -- optimized, CPS converted and native-call-less C--. The latter @@ -36,8 +38,6 @@ cmmPipeline :: HscEnv -- Compilation env including cmmPipeline hsc_env topSRT prog = do let dflags = hsc_dflags hsc_env - showPass dflags "CPSZ" - tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog (topSRT, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags topSRT tops @@ -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 635b0021f1..4dced9afd2 100644 --- a/compiler/cmm/CmmSink.hs +++ b/compiler/cmm/CmmSink.hs @@ -3,14 +3,13 @@ module CmmSink ( cmmSink ) where -import CodeGen.Platform (callerSaves) - import Cmm import CmmOpt import BlockId import CmmLive import CmmUtils import Hoopl +import CodeGen.Platform import DynFlags import UniqFM @@ -18,6 +17,7 @@ import PprCmm () import Data.List (partition) import qualified Data.Set as Set +import Data.Maybe -- ----------------------------------------------------------------------------- -- Sinking and inlining @@ -199,7 +199,7 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets') where should_drop = conflicts dflags a final_last - || not (isTrivial rhs) && live_in_multi live_sets r + || not (isTrivial dflags rhs) && live_in_multi live_sets r || r `Set.member` live_in_joins live_sets' | should_drop = live_sets @@ -221,28 +221,24 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks -- small: an expression we don't mind duplicating isSmall :: CmmExpr -> Bool -isSmall (CmmReg (CmmLocal _)) = True -- not globals, we want to coalesce them instead* See below +isSmall (CmmReg (CmmLocal _)) = True -- isSmall (CmmLit _) = True isSmall (CmmMachOp (MO_Add _) [x,y]) = isTrivial x && isTrivial y isSmall (CmmRegOff (CmmLocal _) _) = True isSmall _ = False - -Coalesce global registers? What does that mean? We observed no decrease -in performance comming from inlining of global registers, hence we do it now -(see isTrivial function). Ideally we'd like to measure performance using -some tool like perf or VTune and make decisions what to inline based on that. -} -- -- We allow duplication of trivial expressions: registers (both local and -- global) and literals. -- -isTrivial :: CmmExpr -> Bool -isTrivial (CmmReg (CmmLocal _)) = True --- isTrivial (CmmLit _) = True -- Disabled because it used to make thing worse. - -- Needs further investigation -isTrivial _ = False - +isTrivial :: DynFlags -> CmmExpr -> Bool +isTrivial _ (CmmReg (CmmLocal _)) = True +isTrivial dflags (CmmReg (CmmGlobal r)) = -- see Note [Inline GlobalRegs?] + isJust (globalRegMaybe (targetPlatform dflags) r) + -- GlobalRegs that are loads from BaseReg are not trivial +isTrivial _ (CmmLit _) = True +isTrivial _ _ = False -- -- annotate each node with the set of registers live *after* the node @@ -405,7 +401,7 @@ tryToInline dflags live node assigs = go usages node [] assigs | cannot_inline = dont_inline | occurs_none = discard -- Note [discard during inlining] | occurs_once = inline_and_discard - | isTrivial rhs = inline_and_keep + | isTrivial dflags rhs = inline_and_keep | otherwise = dont_inline where inline_and_discard = go usages' inl_node skipped rest @@ -505,7 +501,8 @@ regsUsedIn ls e = wrapRecExpf f e False -- nor the NCG can do it. See Note [Register parameter passing] -- See also StgCmmForeign:load_args_into_temps. okToInline :: DynFlags -> CmmExpr -> CmmNode e x -> Bool -okToInline dflags expr CmmUnsafeForeignCall{} = not (anyCallerSavesRegs dflags expr) +okToInline dflags expr node@(CmmUnsafeForeignCall{}) = + not (globalRegistersConflict dflags expr node) okToInline _ _ _ = True -- ----------------------------------------------------------------------------- @@ -518,23 +515,23 @@ okToInline _ _ _ = True conflicts :: DynFlags -> Assignment -> CmmNode O x -> Bool conflicts dflags (r, rhs, addr) node - -- (1) an assignment to a register conflicts with a use of the register - | CmmAssign reg _ <- node, reg `regUsedIn` rhs = True + -- (1) node defines registers used by rhs of assignment. This catches + -- assignments and all three kinds of calls. See Note [Sinking and calls] + | globalRegistersConflict dflags rhs node = True + | localRegistersConflict dflags rhs node = True + + -- (2) node uses register defined by assignment | foldRegsUsed dflags (\b r' -> r == r' || b) False node = True - -- (2) a store to an address conflicts with a read of the same memory + -- (3) a store to an address conflicts with a read of the same memory | CmmStore addr' e <- node , memConflicts addr (loadAddr dflags addr' (cmmExprWidth dflags e)) = True - -- (3) an assignment to Hp/Sp conflicts with a heap/stack read respectively + -- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively | HeapMem <- addr, CmmAssign (CmmGlobal Hp) _ <- node = True | StackMem <- addr, CmmAssign (CmmGlobal Sp) _ <- node = True | SpMem{} <- addr, CmmAssign (CmmGlobal Sp) _ <- node = True - -- (4) assignments that read caller-saves GlobalRegs conflict with a - -- foreign call. See Note [Unsafe foreign calls clobber caller-save registers] - | CmmUnsafeForeignCall{} <- node, anyCallerSavesRegs dflags rhs = True - -- (5) foreign calls clobber heap: see Note [Foreign calls clobber heap] | CmmUnsafeForeignCall{} <- node, memConflicts addr AnyMem = True @@ -544,11 +541,57 @@ conflicts dflags (r, rhs, addr) node -- (7) otherwise, no conflict | otherwise = False -anyCallerSavesRegs :: DynFlags -> CmmExpr -> Bool -anyCallerSavesRegs dflags e = wrapRecExpf f e False - where f (CmmReg (CmmGlobal r)) _ - | callerSaves (targetPlatform dflags) r = True - f _ z = z +-- Returns True if node defines any global registers that are used in the +-- Cmm expression +globalRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool +globalRegistersConflict dflags expr node = + foldRegsDefd dflags (\b r -> b || (CmmGlobal r) `regUsedIn` expr) False node + +-- Returns True if node defines any local registers that are used in the +-- Cmm expression +localRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool +localRegistersConflict dflags expr node = + foldRegsDefd dflags (\b r -> b || (CmmLocal r) `regUsedIn` expr) False node + +-- Note [Sinking and calls] +-- ~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- We have three kinds of calls: normal (CmmCall), safe foreign (CmmForeignCall) +-- and unsafe foreign (CmmUnsafeForeignCall). We perform sinking pass after +-- stack layout (see Note [Sinking after stack layout]) which leads to two +-- invariants related to calls: +-- +-- a) during stack layout phase all safe foreign calls are turned into +-- unsafe foreign calls (see Note [Lower safe foreign calls]). This +-- means that we will never encounter CmmForeignCall node when running +-- sinking after stack layout +-- +-- b) stack layout saves all variables live across a call on the stack +-- just before making a call (remember we are not sinking assignments to +-- stack): +-- +-- L1: +-- x = R1 +-- P64[Sp - 16] = L2 +-- P64[Sp - 8] = x +-- Sp = Sp - 16 +-- call f() returns L2 +-- L2: +-- +-- We will attempt to sink { x = R1 } but we will detect conflict with +-- { P64[Sp - 8] = x } and hence we will drop { x = R1 } without even +-- checking whether it conflicts with { call f() }. In this way we will +-- never need to check any assignment conflicts with CmmCall. Remember +-- that we still need to check for potential memory conflicts. +-- +-- So the result is that we only need to worry about CmmUnsafeForeignCall nodes +-- when checking conflicts (see Note [Unsafe foreign calls clobber caller-save registers]). +-- This assumption holds only when we do sinking after stack layout. If we run +-- it before stack layout we need to check for possible conflicts with all three +-- kinds of calls. Our `conflicts` function does that by using a generic +-- foldRegsDefd and foldRegsUsed functions defined in DefinerOfRegs and +-- UserOfRegs typeclasses. +-- -- An abstraction of memory read or written. data AbsMem @@ -607,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 @@ -652,3 +699,91 @@ regAddr _ (CmmGlobal Hp) _ _ = HeapMem regAddr _ (CmmGlobal CurrentTSO) _ _ = HeapMem -- important for PrimOps regAddr dflags r _ _ | isGcPtrType (cmmRegType dflags r) = HeapMem -- yay! GCPtr pays for itself regAddr _ _ _ _ = AnyMem + +{- +Note [Inline GlobalRegs?] + +Should we freely inline GlobalRegs? + +Actually it doesn't make a huge amount of difference either way, so we +*do* currently treat GlobalRegs as "trivial" and inline them +everywhere, but for what it's worth, here is what I discovered when I +(SimonM) looked into this: + +Common sense says we should not inline GlobalRegs, because when we +have + + x = R1 + +the register allocator will coalesce this assignment, generating no +code, and simply record the fact that x is bound to $rbx (or +whatever). Furthermore, if we were to sink this assignment, then the +range of code over which R1 is live increases, and the range of code +over which x is live decreases. All things being equal, it is better +for x to be live than R1, because R1 is a fixed register whereas x can +live in any register. So we should neither sink nor inline 'x = R1'. + +However, not inlining GlobalRegs can have surprising +consequences. e.g. (cgrun020) + + c3EN: + _s3DB::P64 = R1; + _c3ES::P64 = _s3DB::P64 & 7; + if (_c3ES::P64 >= 2) goto c3EU; else goto c3EV; + c3EU: + _s3DD::P64 = P64[_s3DB::P64 + 6]; + _s3DE::P64 = P64[_s3DB::P64 + 14]; + I64[Sp - 8] = c3F0; + R1 = _s3DE::P64; + P64[Sp] = _s3DD::P64; + +inlining the GlobalReg gives: + + c3EN: + if (R1 & 7 >= 2) goto c3EU; else goto c3EV; + c3EU: + I64[Sp - 8] = c3F0; + _s3DD::P64 = P64[R1 + 6]; + R1 = P64[R1 + 14]; + P64[Sp] = _s3DD::P64; + +but if we don't inline the GlobalReg, instead we get: + + _s3DB::P64 = R1; + if (_s3DB::P64 & 7 >= 2) goto c3EU; else goto c3EV; + c3EU: + I64[Sp - 8] = c3F0; + R1 = P64[_s3DB::P64 + 14]; + P64[Sp] = P64[_s3DB::P64 + 6]; + +This looks better - we managed to inline _s3DD - but in fact it +generates an extra reg-reg move: + +.Lc3EU: + movq $c3F0_info,-8(%rbp) + movq %rbx,%rax + movq 14(%rbx),%rbx + movq 6(%rax),%rax + movq %rax,(%rbp) + +because _s3DB is now live across the R1 assignment, we lost the +benefit of coalescing. + +Who is at fault here? Perhaps if we knew that _s3DB was an alias for +R1, then we would not sink a reference to _s3DB past the R1 +assignment. Or perhaps we *should* do that - we might gain by sinking +it, despite losing the coalescing opportunity. + +Sometimes not inlining global registers wins by virtue of the rule +about not inlining into arguments of a foreign call, e.g. (T7163) this +is what happens when we inlined F1: + + _s3L2::F32 = F1; + _c3O3::F32 = %MO_F_Mul_W32(F1, 10.0 :: W32); + (_s3L7::F32) = call "ccall" arg hints: [] result hints: [] rintFloat(_c3O3::F32); + +but if we don't inline F1: + + (_s3L7::F32) = call "ccall" arg hints: [] result hints: [] rintFloat(%MO_F_Mul_W32(_s3L2::F32, + 10.0 :: W32)); +-} diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs index d03c2dc0b9..37d92c207d 100644 --- a/compiler/cmm/CmmType.hs +++ b/compiler/cmm/CmmType.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module CmmType ( CmmType -- Abstract diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index afba245fbc..1f6d1ac0e3 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP, GADTs, RankNTypes #-} ----------------------------------------------------------------------------- -- diff --git a/compiler/cmm/Hoopl.hs b/compiler/cmm/Hoopl.hs index 2d7139af9f..4b3717288f 100644 --- a/compiler/cmm/Hoopl.hs +++ b/compiler/cmm/Hoopl.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} + module Hoopl ( module Compiler.Hoopl, module Hoopl.Dataflow, diff --git a/compiler/cmm/Hoopl/Dataflow.hs b/compiler/cmm/Hoopl/Dataflow.hs index 78b930a20f..f5511515a9 100644 --- a/compiler/cmm/Hoopl/Dataflow.hs +++ b/compiler/cmm/Hoopl/Dataflow.hs @@ -1,3 +1,12 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fprof-auto-top #-} + -- -- Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones, -- and Norman Ramsey @@ -9,10 +18,6 @@ -- specialised to the UniqSM monad. -- -{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, MultiParamTypeClasses #-} -{-# OPTIONS_GHC -fprof-auto-top #-} -{-# LANGUAGE Trustworthy #-} - module Hoopl.Dataflow ( DataflowLattice(..), OldFact(..), NewFact(..), Fact, mkFactBase , ChangeFlag(..) diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs index 6f9bbf8872..9bc2bd9ddc 100644 --- a/compiler/cmm/MkGraph.hs +++ b/compiler/cmm/MkGraph.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE BangPatterns, CPP, GADTs #-} module MkGraph ( CmmAGraph, CgStmt(..) diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 23989811dd..93a5d06259 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP, GADTs #-} + ----------------------------------------------------------------------------- -- -- Pretty-printing of Cmm as C, suitable for feeding gcc @@ -16,7 +18,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE GADTs #-} module PprC ( writeCs, pprStringInCStyle @@ -752,6 +753,12 @@ pprCallishMachOp_for_C mop MO_Memmove -> ptext (sLit "memmove") (MO_BSwap w) -> ptext (sLit $ bSwapLabel w) (MO_PopCnt w) -> ptext (sLit $ popCntLabel w) + (MO_Clz w) -> ptext (sLit $ clzLabel w) + (MO_Ctz w) -> ptext (sLit $ ctzLabel 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 46257b4188..cc3124028a 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + ---------------------------------------------------------------------------- -- -- Pretty-printing of Cmm as (a superset of) C-- @@ -30,8 +33,6 @@ -- -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts #-} module PprCmm ( module PprCmmDecl , module PprCmmExpr @@ -137,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/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs index 354a3d4563..dd80f5cd56 100644 --- a/compiler/cmm/PprCmmDecl.hs +++ b/compiler/cmm/PprCmmDecl.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ---------------------------------------------------------------------------- -- -- Pretty-printing of common Cmm types diff --git a/compiler/cmm/SMRep.lhs b/compiler/cmm/SMRep.lhs index 704c22db6a..53c9d0a5e8 100644 --- a/compiler/cmm/SMRep.lhs +++ b/compiler/cmm/SMRep.lhs @@ -6,7 +6,7 @@ Storage manager representation of closures \begin{code} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP,GeneralizedNewtypeDeriving #-} module SMRep ( -- * Words and bytes @@ -71,16 +71,30 @@ import Data.Bits %************************************************************************ \begin{code} -type WordOff = Int -- Word offset, or word count -type ByteOff = Int -- Byte offset, or byte count +-- | Word offset, or word count +type WordOff = Int +-- | Byte offset, or byte count +type ByteOff = Int + +-- | Round up the given byte count to the next byte count that's a +-- multiple of the machine's word size. roundUpToWords :: DynFlags -> ByteOff -> ByteOff roundUpToWords dflags n = (n + (wORD_SIZE dflags - 1)) .&. (complement (wORD_SIZE dflags - 1)) -wordsToBytes :: DynFlags -> WordOff -> ByteOff -wordsToBytes dflags n = wORD_SIZE dflags * n - +-- | Convert the given number of words to a number of bytes. +-- +-- This function morally has type @WordOff -> ByteOff@, but uses @Num +-- a@ to allow for overloading. +wordsToBytes :: Num a => DynFlags -> a -> a +wordsToBytes dflags n = fromIntegral (wORD_SIZE dflags) * n +{-# SPECIALIZE wordsToBytes :: DynFlags -> Int -> Int #-} +{-# SPECIALIZE wordsToBytes :: DynFlags -> Word -> Word #-} +{-# SPECIALIZE wordsToBytes :: DynFlags -> Integer -> Integer #-} + +-- | First round the given byte count up to a multiple of the +-- machine's word size and then convert the result to words. bytesToWordsRoundUp :: DynFlags -> ByteOff -> WordOff bytesToWordsRoundUp dflags n = (n + word_size - 1) `quot` word_size where word_size = wORD_SIZE dflags @@ -91,11 +105,7 @@ StgWord is a type representing an StgWord on the target platform. \begin{code} -- A Word64 is large enough to hold a Word for either a 32bit or 64bit platform newtype StgWord = StgWord Word64 - deriving (Eq, -#if __GLASGOW_HASKELL__ < 706 - Num, -#endif - Bits) + deriving (Eq, Bits) fromStgWord :: StgWord -> Integer fromStgWord (StgWord i) = toInteger i diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 6b36ab09cd..51b8ed9ec8 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP, GADTs #-} + ----------------------------------------------------------------------------- -- -- Code generator utilities; mostly monadic @@ -6,7 +8,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE GADTs #-} module CgUtils ( fixStgRegisters ) where #include "HsVersions.h" diff --git a/compiler/codeGen/CodeGen/Platform/ARM.hs b/compiler/codeGen/CodeGen/Platform/ARM.hs index 727a43561f..5d1148496c 100644 --- a/compiler/codeGen/CodeGen/Platform/ARM.hs +++ b/compiler/codeGen/CodeGen/Platform/ARM.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module CodeGen.Platform.ARM where diff --git a/compiler/codeGen/CodeGen/Platform/NoRegs.hs b/compiler/codeGen/CodeGen/Platform/NoRegs.hs index c4c63b7572..0c85ffbda7 100644 --- a/compiler/codeGen/CodeGen/Platform/NoRegs.hs +++ b/compiler/codeGen/CodeGen/Platform/NoRegs.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module CodeGen.Platform.NoRegs where diff --git a/compiler/codeGen/CodeGen/Platform/PPC.hs b/compiler/codeGen/CodeGen/Platform/PPC.hs index bcbdfe244b..76a2b020ac 100644 --- a/compiler/codeGen/CodeGen/Platform/PPC.hs +++ b/compiler/codeGen/CodeGen/Platform/PPC.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module CodeGen.Platform.PPC where diff --git a/compiler/codeGen/CodeGen/Platform/PPC_Darwin.hs b/compiler/codeGen/CodeGen/Platform/PPC_Darwin.hs index 42bf22f26c..a98e558cc1 100644 --- a/compiler/codeGen/CodeGen/Platform/PPC_Darwin.hs +++ b/compiler/codeGen/CodeGen/Platform/PPC_Darwin.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module CodeGen.Platform.PPC_Darwin where diff --git a/compiler/codeGen/CodeGen/Platform/SPARC.hs b/compiler/codeGen/CodeGen/Platform/SPARC.hs index b49af14409..991f515eaf 100644 --- a/compiler/codeGen/CodeGen/Platform/SPARC.hs +++ b/compiler/codeGen/CodeGen/Platform/SPARC.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module CodeGen.Platform.SPARC where diff --git a/compiler/codeGen/CodeGen/Platform/X86.hs b/compiler/codeGen/CodeGen/Platform/X86.hs index 6dd74df130..e74807ff88 100644 --- a/compiler/codeGen/CodeGen/Platform/X86.hs +++ b/compiler/codeGen/CodeGen/Platform/X86.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module CodeGen.Platform.X86 where diff --git a/compiler/codeGen/CodeGen/Platform/X86_64.hs b/compiler/codeGen/CodeGen/Platform/X86_64.hs index 190d642ea6..102132d679 100644 --- a/compiler/codeGen/CodeGen/Platform/X86_64.hs +++ b/compiler/codeGen/CodeGen/Platform/X86_64.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module CodeGen.Platform.X86_64 where diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index a92f80439b..efc89fe04a 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Stg to C-- code generation @@ -37,7 +39,6 @@ import DataCon import Name import TyCon import Module -import ErrUtils import Outputable import Stream import BasicTypes @@ -60,9 +61,7 @@ codeGen :: DynFlags codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info - = do { liftIO $ showPass dflags "New CodeGen" - - -- cg: run the code generator, and yield the resulting CmmGroup + = do { -- cg: run the code generator, and yield the resulting CmmGroup -- Using an IORef to store the state is a bit crude, but otherwise -- we would need to add a state monad layer. ; cgref <- liftIO $ newIORef =<< initC diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 06e17164dd..4631b2dc14 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Stg to C-- code generation: bindings diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index c9302f21a1..b65d56bae2 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP, RecordWildCards #-} + ----------------------------------------------------------------------------- -- -- Stg to C-- code generation: @@ -9,8 +11,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE RecordWildCards #-} - module StgCmmClosure ( DynTag, tagForCon, isSmallFamily, ConTagZ, dataConTagZ, diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index a02a5da616..edd064848f 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Stg to C--: code generation for constructors @@ -188,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 @@ -203,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/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index 2b8677c408..4127b67401 100644 --- a/compiler/codeGen/StgCmmEnv.hs +++ b/compiler/codeGen/StgCmmEnv.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Stg to C-- code generation: the binding environment diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 9b9d6397c4..ad34b5ba19 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Stg to C-- code generation: expressions 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/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index bf88f1ccb3..6937c85d01 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Code generation for foreign calls. diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index a3a47a65e7..7ac2c7a0bd 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Stg to C--: heap management functions @@ -514,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 a56248dcb9..d62101f27e 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Building info tables. @@ -357,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 348b7b9299..22c89d7e05 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP, GADTs, UnboxedTuples #-} + ----------------------------------------------------------------------------- -- -- Monad for Stg to C-- code generation @@ -493,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 5c75acba5a..9e12427355 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ---------------------------------------------------------------------------- -- -- Stg to C--: primitive operations @@ -41,6 +43,7 @@ import FastString import Outputable import Util +import Data.Bits ((.&.), bit) import Control.Monad (liftM, when) ------------------------------------------------------------------------ @@ -119,6 +122,26 @@ cgOpApp (StgPrimCallOp primcall) args _res_ty ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall)) ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args } +-- | Interpret the argument as an unsigned value, assuming the value +-- is given in two-complement form in the given width. +-- +-- Example: @asUnsigned W64 (-1)@ is 18446744073709551615. +-- +-- This function is used to work around the fact that many array +-- primops take Int# arguments, but we interpret them as unsigned +-- quantities in the code gen. This means that we have to be careful +-- every time we work on e.g. a CmmInt literal that corresponds to the +-- array size, as it might contain a negative Integer value if the +-- user passed a value larger than 2^(wORD_SIZE_IN_BITS-1) as the Int# +-- literal. +asUnsigned :: Width -> Integer -> Integer +asUnsigned w n = n .&. (bit (widthInBits w) - 1) + +-- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use +-- ByteOff (or some other fixed width signed type) to represent +-- array sizes or indices. This means that these will overflow for +-- large enough sizes. + -- | Decide whether an out-of-line primop should be replaced by an -- inline implementation. This might happen e.g. if there's enough -- static information, such as statically know arguments, to emit a @@ -133,12 +156,12 @@ shouldInlinePrimOp :: DynFlags -> [CmmExpr] -- ^ The primop arguments -> Maybe ([LocalReg] -> FCode ()) -shouldInlinePrimOp dflags NewByteArrayOp_Char [(CmmLit (CmmInt n _))] - | fromInteger n <= maxInlineAllocSize dflags = +shouldInlinePrimOp dflags NewByteArrayOp_Char [(CmmLit (CmmInt n w))] + | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags) = Just $ \ [res] -> doNewByteArrayOp res (fromInteger n) -shouldInlinePrimOp dflags NewArrayOp [(CmmLit (CmmInt n _)), init] - | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags = +shouldInlinePrimOp dflags NewArrayOp [(CmmLit (CmmInt n w)), init] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = Just $ \ [res] -> doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel [ (mkIntExpr dflags (fromInteger n), @@ -164,24 +187,24 @@ shouldInlinePrimOp _ CopyMutableArrayArrayOp [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] = Just $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n) -shouldInlinePrimOp dflags CloneArrayOp [src, src_off, (CmmLit (CmmInt n _))] - | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags = +shouldInlinePrimOp dflags CloneArrayOp [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_infoLabel res src src_off (fromInteger n) -shouldInlinePrimOp dflags CloneMutableArrayOp [src, src_off, (CmmLit (CmmInt n _))] - | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags = +shouldInlinePrimOp dflags CloneMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) -shouldInlinePrimOp dflags FreezeArrayOp [src, src_off, (CmmLit (CmmInt n _))] - | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags = +shouldInlinePrimOp dflags FreezeArrayOp [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_infoLabel res src src_off (fromInteger n) -shouldInlinePrimOp dflags ThawArrayOp [src, src_off, (CmmLit (CmmInt n _))] - | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags = +shouldInlinePrimOp dflags ThawArrayOp [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) -shouldInlinePrimOp dflags NewSmallArrayOp [(CmmLit (CmmInt n _)), init] - | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags = +shouldInlinePrimOp dflags NewSmallArrayOp [(CmmLit (CmmInt n w)), init] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = Just $ \ [res] -> doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel [ (mkIntExpr dflags (fromInteger n), @@ -197,20 +220,20 @@ shouldInlinePrimOp _ CopySmallMutableArrayOp [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] = Just $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n) -shouldInlinePrimOp dflags CloneSmallArrayOp [src, src_off, (CmmLit (CmmInt n _))] - | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags = +shouldInlinePrimOp dflags CloneSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_infoLabel res src src_off (fromInteger n) -shouldInlinePrimOp dflags CloneSmallMutableArrayOp [src, src_off, (CmmLit (CmmInt n _))] - | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags = +shouldInlinePrimOp dflags CloneSmallMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n) -shouldInlinePrimOp dflags FreezeSmallArrayOp [src, src_off, (CmmLit (CmmInt n _))] - | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags = +shouldInlinePrimOp dflags FreezeSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_infoLabel res src src_off (fromInteger n) -shouldInlinePrimOp dflags ThawSmallArrayOp [src, src_off, (CmmLit (CmmInt n _))] - | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags = +shouldInlinePrimOp dflags ThawSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n) shouldInlinePrimOp dflags primop args @@ -248,63 +271,6 @@ emitPrimOp :: DynFlags -- First we handle various awkward cases specially. The remaining -- easy cases are then handled by translateOp, defined below. -emitPrimOp dflags [res_r,res_c] IntAddCOp [aa,bb] -{- - With some bit-twiddling, we can define int{Add,Sub}Czh portably in - C, and without needing any comparisons. This may not be the - fastest way to do it - if you have better code, please send it! --SDM - - Return : r = a + b, c = 0 if no overflow, 1 on overflow. - - We currently don't make use of the r value if c is != 0 (i.e. - overflow), we just convert to big integers and try again. This - could be improved by making r and c the correct values for - plugging into a new J#. - - { r = ((I_)(a)) + ((I_)(b)); \ - c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ - >> (BITS_IN (I_) - 1); \ - } - Wading through the mass of bracketry, it seems to reduce to: - c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1) - --} - = emit $ catAGraphs [ - mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]), - mkAssign (CmmLocal res_c) $ - CmmMachOp (mo_wordUShr dflags) [ - CmmMachOp (mo_wordAnd dflags) [ - CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]], - CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] - ], - mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) - ] - ] - - -emitPrimOp dflags [res_r,res_c] IntSubCOp [aa,bb] -{- Similarly: - #define subIntCzh(r,c,a,b) \ - { r = ((I_)(a)) - ((I_)(b)); \ - c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ - >> (BITS_IN (I_) - 1); \ - } - - c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) --} - = emit $ catAGraphs [ - mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]), - mkAssign (CmmLocal res_c) $ - CmmMachOp (mo_wordUShr dflags) [ - CmmMachOp (mo_wordAnd dflags) [ - CmmMachOp (mo_wordXor dflags) [aa,bb], - CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] - ], - mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) - ] - ] - - emitPrimOp _ [res] ParOp [arg] = -- for now, just implement this in a C function @@ -597,6 +563,20 @@ emitPrimOp _ [res] PopCnt32Op [w] = emitPopCntCall res w W32 emitPrimOp _ [res] PopCnt64Op [w] = emitPopCntCall res w W64 emitPrimOp dflags [res] PopCntOp [w] = emitPopCntCall res w (wordWidth dflags) +-- count leading zeros +emitPrimOp _ [res] Clz8Op [w] = emitClzCall res w W8 +emitPrimOp _ [res] Clz16Op [w] = emitClzCall res w W16 +emitPrimOp _ [res] Clz32Op [w] = emitClzCall res w W32 +emitPrimOp _ [res] Clz64Op [w] = emitClzCall res w W64 +emitPrimOp dflags [res] ClzOp [w] = emitClzCall res w (wordWidth dflags) + +-- count trailing zeros +emitPrimOp _ [res] Ctz8Op [w] = emitCtzCall res w W8 +emitPrimOp _ [res] Ctz16Op [w] = emitCtzCall res w W16 +emitPrimOp _ [res] Ctz32Op [w] = emitCtzCall res w W32 +emitPrimOp _ [res] Ctz64Op [w] = emitCtzCall res w W64 +emitPrimOp dflags [res] CtzOp [w] = emitCtzCall res w (wordWidth dflags) + -- Unsigned int to floating point conversions emitPrimOp _ [res] Word2FloatOp [w] = emitPrimCall [res] (MO_UF_Conv W32) [w] @@ -767,6 +747,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] @@ -807,6 +806,10 @@ callishPrimOpSupported dflags op WordAdd2Op | ncg && x86ish -> Left (MO_Add2 (wordWidth dflags)) | otherwise -> Right genericWordAdd2Op + IntAddCOp -> Right genericIntAddCOp + + IntSubCOp -> Right genericIntSubCOp + WordMul2Op | ncg && x86ish -> Left (MO_U_Mul2 (wordWidth dflags)) | otherwise -> Right genericWordMul2Op @@ -912,6 +915,67 @@ genericWordAdd2Op [res_h, res_l] [arg_x, arg_y] (bottomHalf (CmmReg (CmmLocal r1))))] genericWordAdd2Op _ _ = panic "genericWordAdd2Op" +genericIntAddCOp :: GenericOp +genericIntAddCOp [res_r, res_c] [aa, bb] +{- + With some bit-twiddling, we can define int{Add,Sub}Czh portably in + C, and without needing any comparisons. This may not be the + fastest way to do it - if you have better code, please send it! --SDM + + Return : r = a + b, c = 0 if no overflow, 1 on overflow. + + We currently don't make use of the r value if c is != 0 (i.e. + overflow), we just convert to big integers and try again. This + could be improved by making r and c the correct values for + plugging into a new J#. + + { r = ((I_)(a)) + ((I_)(b)); \ + c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ + >> (BITS_IN (I_) - 1); \ + } + Wading through the mass of bracketry, it seems to reduce to: + c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1) + +-} + = do dflags <- getDynFlags + emit $ catAGraphs [ + mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]), + mkAssign (CmmLocal res_c) $ + CmmMachOp (mo_wordUShr dflags) [ + CmmMachOp (mo_wordAnd dflags) [ + CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]], + CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] + ], + mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) + ] + ] +genericIntAddCOp _ _ = panic "genericIntAddCOp" + +genericIntSubCOp :: GenericOp +genericIntSubCOp [res_r, res_c] [aa, bb] +{- Similarly: + #define subIntCzh(r,c,a,b) \ + { r = ((I_)(a)) - ((I_)(b)); \ + c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ + >> (BITS_IN (I_) - 1); \ + } + + c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) +-} + = do dflags <- getDynFlags + emit $ catAGraphs [ + mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]), + mkAssign (CmmLocal res_c) $ + CmmMachOp (mo_wordUShr dflags) [ + CmmMachOp (mo_wordAnd dflags) [ + CmmMachOp (mo_wordXor dflags) [aa,bb], + CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] + ], + mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) + ] + ] +genericIntSubCOp _ _ = panic "genericIntSubCOp" + genericWordMul2Op :: GenericOp genericWordMul2Op [res_h, res_l] [arg_x, arg_y] = do dflags <- getDynFlags @@ -1931,6 +1995,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@. @@ -1971,3 +2110,17 @@ emitPopCntCall res x width = do [ res ] (MO_PopCnt width) [ x ] + +emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitClzCall res x width = do + emitPrimCall + [ res ] + (MO_Clz width) + [ x ] + +emitCtzCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitCtzCall res x width = do + emitPrimCall + [ res ] + (MO_Ctz width) + [ x ] diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index f858c5a0b6..7249477c9f 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Code generation for profiling @@ -181,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 @@ -283,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 @@ -354,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 b1218201a6..3652a79979 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns, CPP #-} + ----------------------------------------------------------------------------- -- -- Code generation for ticky-ticky profiling @@ -325,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 () @@ -470,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 ]} @@ -539,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 1c6c3f2eae..985c6db900 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Code generator utilities; mostly monadic @@ -173,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/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs index 12d4274223..26669b6d32 100644 --- a/compiler/coreSyn/CoreArity.lhs +++ b/compiler/coreSyn/CoreArity.lhs @@ -6,7 +6,8 @@ Arity and eta expansion \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -73,7 +74,8 @@ should have arity 3, regardless of f's arity. \begin{code} manifestArity :: CoreExpr -> Arity --- ^ manifestArity sees how many leading value lambdas there are +-- ^ manifestArity sees how many leading value lambdas there are, +-- after looking through casts manifestArity (Lam v e) | isId v = 1 + manifestArity e | otherwise = manifestArity e manifestArity (Tick t e) | not (tickishIsCode t) = manifestArity e diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs index fef3977b73..19e3eeb787 100644 --- a/compiler/coreSyn/CoreFVs.lhs +++ b/compiler/coreSyn/CoreFVs.lhs @@ -5,6 +5,8 @@ Taken quite directly from the Peyton Jones/Lester paper. \begin{code} +{-# LANGUAGE CPP #-} + -- | A module concerned with finding the free variables of an expression. module CoreFVs ( -- * Free variables of expressions and binding groups diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 836164e0ce..f4607823a8 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -7,19 +7,13 @@ A ``lint'' pass to check for Core correctness \begin{code} --- 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 CPP #-} {-# OPTIONS_GHC -fprof-auto #-} module CoreLint ( lintCoreBindings, lintUnfolding, lintExpr ) where #include "HsVersions.h" -import Demand import CoreSyn import CoreFVs import CoreUtils @@ -213,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) @@ -226,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) @@ -239,9 +235,13 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) -- Check whether arity and demand type are consistent (only if demand analysis -- already happened) - ; checkL (case dmdTy of - StrictSig dmd_ty -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs) - (mkArityMsg binder) + -- + -- Note (Apr 2014): this is actually ok. See Note [Demand analysis for trivial right-hand sides] + -- in DmdAnal. After eta-expansion in CorePrep the rhs is no longer trivial. + -- ; let dmdTy = idStrictness binder + -- ; checkL (case dmdTy of + -- StrictSig dmd_ty -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs) + -- (mkArityMsg binder) ; lintIdUnfolding binder binder_ty (idUnfolding binder) } @@ -249,7 +249,6 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) -- the unfolding is a SimplifiableCoreExpr. Give up for now. where binder_ty = idType binder - dmdTy = idStrictness binder bndr_vars = varSetElems (idFreeVars binder) -- If you edit this function, you may need to update the GHC formalism @@ -454,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 } ----------------- @@ -854,6 +855,9 @@ lintCoercion co@(TyConAppCo r tc cos) ; checkRole co2 r r2 ; return (rk, mkFunTy s1 s2, mkFunTy t1 t2, r) } + | Just {} <- synTyConDefn_maybe tc + = failWithL (ptext (sLit "Synonym in TyConAppCo:") <+> ppr co) + | otherwise = do { (ks,ss,ts,rs) <- mapAndUnzip4M lintCoercion cos ; rk <- lint_co_app co (tyConKind tc) (ss `zip` ks) @@ -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:"), @@ -1421,6 +1430,7 @@ mkKindErrMsg tyvar arg_ty hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] +{- Not needed now mkArityMsg :: Id -> MsgDoc mkArityMsg binder = vcat [hsep [ptext (sLit "Demand type has"), @@ -1433,7 +1443,7 @@ mkArityMsg binder ] where (StrictSig dmd_ty) = idStrictness binder - +-} mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc mkCastErr expr co from_ty expr_ty = vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"), diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index 1da88b7428..180456ed77 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -5,7 +5,7 @@ Core pass to saturate constructors and PrimOps \begin{code} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, CPP #-} module CorePrep ( corePrepPgm, corePrepExpr, cvtLitInteger, @@ -197,6 +197,7 @@ corePrepTopBinds initialCorePrepEnv binds mkDataConWorkers :: [TyCon] -> [CoreBind] -- See Note [Data constructor workers] +-- c.f. Note [Injecting implicit bindings] in TidyPgm mkDataConWorkers data_tycons = [ NonRec id (Var id) -- The ice is thin here, but it works | tycon <- data_tycons, -- CorePrep will eta-expand it @@ -1118,9 +1119,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/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index ef601a2a09..f3215094df 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -6,7 +6,8 @@ Utility functions on @Core@ syntax \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 364ad743e6..e8d072a51f 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -4,9 +4,8 @@ % \begin{code} -{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-} - -{-# OPTIONS -fno-warn-tabs #-} +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} +{-# 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 @@ -181,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: -- @@ -360,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1220,8 +1221,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/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs index 8c0ae4a65a..4754aa5afb 100644 --- a/compiler/coreSyn/CoreTidy.lhs +++ b/compiler/coreSyn/CoreTidy.lhs @@ -7,7 +7,8 @@ This module contains "tidying" code for *nested* expressions, bindings, rules. The code for *top-level* bindings is in TidyPgm. \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -33,7 +34,6 @@ import Name hiding (tidyNameOcc) import SrcLoc import Maybes import Data.List -import Outputable \end{code} @@ -141,18 +141,48 @@ tidyBndr env var tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var]) tidyBndrs env vars = mapAccumL tidyBndr env vars +-- Non-top-level variables +tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id) +tidyIdBndr env@(tidy_env, var_env) id + = -- Do this pattern match strictly, otherwise we end up holding on to + -- stuff in the OccName. + case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> + let + -- Give the Id a fresh print-name, *and* rename its type + -- The SrcLoc isn't important now, + -- though we could extract it from the Id + -- + ty' = tidyType env (idType id) + name' = mkInternalName (idUnique id) occ' noSrcSpan + id' = mkLocalIdWithInfo name' ty' new_info + var_env' = extendVarEnv var_env id id' + + -- Note [Tidy IdInfo] + new_info = vanillaIdInfo `setOccInfo` occInfo old_info + `setUnfoldingInfo` new_unf + old_info = idInfo id + old_unf = unfoldingInfo old_info + new_unf | isEvaldUnfolding old_unf = evaldUnfolding + | otherwise = noUnfolding + -- See Note [Preserve evaluatedness] + in + ((tidy_env', var_env'), id') + } + tidyLetBndr :: TidyEnv -- Knot-tied version for unfoldings -> TidyEnv -- The one to extend -> (Id, CoreExpr) -> (TidyEnv, Var) -- Used for local (non-top-level) let(rec)s -tidyLetBndr rec_tidy_env env (id,rhs) - = ((tidy_occ_env,new_var_env), final_id) - where - ((tidy_occ_env,var_env), new_id) = tidyIdBndr env id - new_var_env = extendVarEnv var_env id final_id - -- Override the env we get back from tidyId with the - -- new IdInfo so it gets propagated to the usage sites. +-- Just like tidyIdBndr above, but with more IdInfo +tidyLetBndr rec_tidy_env env@(tidy_env, var_env) (id,rhs) + = case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> + let + ty' = tidyType env (idType id) + name' = mkInternalName (idUnique id) occ' noSrcSpan + id' = mkLocalIdWithInfo name' ty' new_info + var_env' = extendVarEnv var_env id id' + -- Note [Tidy IdInfo] -- We need to keep around any interesting strictness and -- demand info because later on we may need to use it when -- converting to A-normal form. @@ -161,48 +191,27 @@ tidyLetBndr rec_tidy_env env (id,rhs) -- into case (g x) of z -> f z by CorePrep, but only if f still -- has its strictness info. -- - -- Similarly for the demand info - on a let binder, this tells + -- Similarly for the demand info - on a let binder, this tells -- CorePrep to turn the let into a case. -- -- Similarly arity info for eta expansion in CorePrep - -- - -- Set inline-prag info so that we preseve it across + -- + -- Set inline-prag info so that we preseve it across -- separate compilation boundaries - final_id = new_id `setIdInfo` new_info - idinfo = idInfo id - new_info = idInfo new_id - `setArityInfo` exprArity rhs - `setStrictnessInfo` strictnessInfo idinfo - `setDemandInfo` demandInfo idinfo - `setInlinePragInfo` inlinePragInfo idinfo - `setUnfoldingInfo` new_unf - - new_unf | isStableUnfolding unf = tidyUnfolding rec_tidy_env unf (panic "tidy_unf") - | otherwise = noUnfolding - unf = unfoldingInfo idinfo - --- Non-top-level variables -tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id) -tidyIdBndr env@(tidy_env, var_env) id - = -- Do this pattern match strictly, otherwise we end up holding on to - -- stuff in the OccName. - case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> - let - -- Give the Id a fresh print-name, *and* rename its type - -- The SrcLoc isn't important now, - -- though we could extract it from the Id - -- - ty' = tidyType env (idType id) - name' = mkInternalName (idUnique id) occ' noSrcSpan - id' = mkLocalIdWithInfo name' ty' new_info - var_env' = extendVarEnv var_env id id' - - -- Note [Tidy IdInfo] - new_info = vanillaIdInfo `setOccInfo` occInfo old_info old_info = idInfo id + new_info = vanillaIdInfo + `setOccInfo` occInfo old_info + `setArityInfo` exprArity rhs + `setStrictnessInfo` strictnessInfo old_info + `setDemandInfo` demandInfo old_info + `setInlinePragInfo` inlinePragInfo old_info + `setUnfoldingInfo` new_unf + + new_unf | isStableUnfolding old_unf = tidyUnfolding rec_tidy_env old_unf old_unf + | otherwise = noUnfolding + old_unf = unfoldingInfo old_info in - ((tidy_env', var_env'), id') - } + ((tidy_env', var_env'), id') } ------------ Unfolding -------------- tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding @@ -234,9 +243,26 @@ two reasons: the benefit of that occurrence analysis when we use the rule or or inline the function. In particular, it's vital not to lose loop-breaker info, else we get an infinite inlining loop - + Note that tidyLetBndr puts more IdInfo back. +Note [Preserve evaluatedness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = MkT !Bool + ....(case v of MkT y -> + let z# = case y of + True -> 1# + False -> 2# + in ...) + +The z# binding is ok because the RHS is ok-for-speculation, +but Lint will complain unless it can *see* that. So we +preserve the evaluated-ness on 'y' in tidyBndr. + +(Another alternative would be to tidy unboxed lets into cases, +but that seems more indirect and surprising.) + \begin{code} (=:) :: a -> (a -> b) -> b diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 3a2c237602..fa9259a005 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -15,7 +15,8 @@ literal''). In the corner of a @CoreUnfolding@ unfolding, you will find, unsurprisingly, a Core expression. \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index ea2e17fb04..baf7e4fa80 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -6,6 +6,8 @@ Utility functions on @Core@ syntax \begin{code} +{-# LANGUAGE CPP #-} + -- | Commonly useful utilites for manipulating the Core language module CoreUtils ( -- * Constructing expressions @@ -215,7 +217,7 @@ mkCast expr co -- if to_ty `eqType` from_ty -- then expr -- else - WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co)) + WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionType co)) (Cast expr co) \end{code} @@ -906,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) +-- +-- For @exprOkForSideEffects@ the list is the same, but omitting (e). -- --- * The expression guarantees to terminate, --- * soon, --- * without raising an exception, --- * without causing a side effect (e.g. writing a mutable variable) +-- 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# } @@ -962,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 @@ -981,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 @@ -1222,7 +1231,7 @@ dataConInstPat :: [FastString] -- A long enough list of FSs to use for -> [Unique] -- An equally long list of uniques, at least one for each binder -> DataCon -> [Type] -- Types to instantiate the universally quantified tyvars - -> ([TyVar], [Id]) -- Return instantiated variables + -> ([TyVar], [Id]) -- Return instantiated variables -- dataConInstPat arg_fun fss us con inst_tys returns a triple -- (ex_tvs, arg_ids), -- @@ -1250,14 +1259,14 @@ dataConInstPat :: [FastString] -- A long enough list of FSs to use for -- -- where the double-primed variables are created with the FastStrings and -- Uniques given as fss and us -dataConInstPat fss uniqs con inst_tys +dataConInstPat fss uniqs con inst_tys = ASSERT( univ_tvs `equalLength` inst_tys ) (ex_bndrs, arg_ids) - where + where univ_tvs = dataConUnivTyVars con ex_tvs = dataConExTyVars con arg_tys = dataConRepArgTys con - + arg_strs = dataConRepStrictness con -- 1-1 with arg_tys n_ex = length ex_tvs -- split the Uniques and FastStrings @@ -1268,7 +1277,7 @@ dataConInstPat fss uniqs con inst_tys univ_subst = zipOpenTvSubst univ_tvs inst_tys -- Make existential type variables, applyingn and extending the substitution - (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst + (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst (zip3 ex_tvs ex_fss ex_uniqs) mk_ex_var :: TvSubst -> (TyVar, FastString, Unique) -> (TvSubst, TyVar) @@ -1280,11 +1289,30 @@ dataConInstPat fss uniqs con inst_tys kind = Type.substTy subst (tyVarKind tv) -- Make value vars, instantiating types - arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys - mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq - (Type.substTy full_subst ty) noSrcSpan + arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs + mk_id_var uniq fs ty str + = mkLocalIdWithInfo name (Type.substTy full_subst ty) info + where + name = mkInternalName uniq (mkVarOccFS fs) noSrcSpan + info | isMarkedStrict str = vanillaIdInfo `setUnfoldingInfo` evaldUnfolding + | otherwise = vanillaIdInfo + -- See Note [Mark evaluated arguments] \end{code} +Note [Mark evaluated arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When pattern matching on a constructor with strict fields, the binder +can have an 'evaldUnfolding'. Moreover, it *should* have one, so that +when loading an interface file unfolding like: + data T = MkT !Int + f x = case x of { MkT y -> let v::Int# = case y of I# n -> n+1 + in ... } +we don't want Lint to complain. The 'y' is evaluated, so the +case in the RHS of the binding for 'v' is fine. But only if we +*know* that 'y' is evaluated. + +c.f. add_evals in Simplify.simplAlt + %************************************************************************ %* * Equality diff --git a/compiler/coreSyn/ExternalCore.lhs b/compiler/coreSyn/ExternalCore.lhs deleted file mode 100644 index ecc24b1155..0000000000 --- a/compiler/coreSyn/ExternalCore.lhs +++ /dev/null @@ -1,118 +0,0 @@ -% -% (c) The University of Glasgow 2001-2006 -% -\begin{code} -module ExternalCore where - -import Data.Word - -data Module - = Module Mname [Tdef] [Vdefg] - -data Tdef - = Data (Qual Tcon) [Tbind] [Cdef] - | Newtype (Qual Tcon) (Qual Tcon) [Tbind] Ty - -data Cdef - = Constr (Qual Dcon) [Tbind] [Ty] - | GadtConstr (Qual Dcon) Ty - -data Vdefg - = Rec [Vdef] - | Nonrec Vdef - --- Top-level bindings are qualified, so that the printer doesn't have to pass --- around the module name. -type Vdef = (Bool,Qual Var,Ty,Exp) - -data Exp - = Var (Qual Var) - | Dcon (Qual Dcon) - | Lit Lit - | App Exp Exp - | Appt Exp Ty - | Lam Bind Exp - | Let Vdefg Exp - | Case Exp Vbind Ty [Alt] {- non-empty list -} - | Cast Exp Coercion - | Tick String Exp {- XXX probably wrong -} - | External String String Ty {- target name, convention, and type -} - | DynExternal String Ty {- convention and type (incl. Addr# of target as first arg) -} - | Label String - -data Bind - = Vb Vbind - | Tb Tbind - -data Alt - = Acon (Qual Dcon) [Tbind] [Vbind] Exp - | Alit Lit Exp - | Adefault Exp - -type Vbind = (Var,Ty) -type Tbind = (Tvar,Kind) - -data Ty - = Tvar Tvar - | Tcon (Qual Tcon) - | Tapp Ty Ty - | Tforall Tbind Ty - -data Coercion --- We distinguish primitive coercions because External Core treats --- them specially, so we have to print them out with special syntax. - = ReflCoercion Role Ty - | SymCoercion Coercion - | TransCoercion Coercion Coercion - | TyConAppCoercion Role (Qual Tcon) [Coercion] - | AppCoercion Coercion Coercion - | ForAllCoercion Tbind Coercion - | CoVarCoercion Var - | UnivCoercion Role Ty Ty - | InstCoercion Coercion Ty - | NthCoercion Int Coercion - | AxiomCoercion (Qual Tcon) Int [Coercion] - | LRCoercion LeftOrRight Coercion - | SubCoercion Coercion - -data Role = Nominal | Representational | Phantom - -data LeftOrRight = CLeft | CRight - -data Kind - = Klifted - | Kunlifted - | Kunboxed - | Kopen - | Karrow Kind Kind - -data Lit - = Lint Integer Ty - | Lrational Rational Ty - | Lchar Char Ty - | Lstring [Word8] Ty - - -type Mname = Id -type Var = Id -type Tvar = Id -type Tcon = Id -type Dcon = Id - -type Qual t = (Mname,t) - -type Id = String - -primMname :: Mname --- For truly horrible reasons, this must be z-encoded. --- With any hope, the z-encoding will die soon. -primMname = "ghczmprim:GHCziPrim" - -tcArrow :: Qual Tcon -tcArrow = (primMname, "(->)") - -\end{code} - - - - diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs index f71b4b4ff6..3ba8b1d6ee 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.lhs @@ -1,5 +1,6 @@ \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -303,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" @@ -414,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/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs deleted file mode 100644 index 6a6f0551ed..0000000000 --- a/compiler/coreSyn/MkExternalCore.lhs +++ /dev/null @@ -1,360 +0,0 @@ - -% (c) The University of Glasgow 2001-2006 -% -\begin{code} -module MkExternalCore ( - emitExternalCore -) where - -#include "HsVersions.h" - -import qualified ExternalCore as C -import Module -import CoreSyn -import HscTypes -import TyCon -import CoAxiom --- import Class -import TypeRep -import Type -import Kind -import PprExternalCore () -- Instances -import DataCon -import Coercion -import Var -import IdInfo -import Literal -import Name -import Outputable -import Encoding -import ForeignCall -import DynFlags -import FastString -import Exception - -import Control.Applicative (Applicative(..)) -import Control.Monad -import qualified Data.ByteString as BS -import Data.Char -import System.IO - -emitExternalCore :: DynFlags -> FilePath -> CgGuts -> IO () -emitExternalCore dflags extCore_filename cg_guts - | gopt Opt_EmitExternalCore dflags - = (do handle <- openFile extCore_filename WriteMode - hPutStrLn handle (show (mkExternalCore dflags cg_guts)) - hClose handle) - `catchIO` (\_ -> pprPanic "Failed to open or write external core output file" - (text extCore_filename)) -emitExternalCore _ _ _ - | otherwise - = return () - --- Reinventing the Reader monad; whee. -newtype CoreM a = CoreM (CoreState -> (CoreState, a)) -data CoreState = CoreState { - cs_dflags :: DynFlags, - cs_module :: Module - } - -instance Functor CoreM where - fmap = liftM - -instance Applicative CoreM where - pure = return - (<*>) = ap - -instance Monad CoreM where - (CoreM m) >>= f = CoreM (\ s -> case m s of - (s',r) -> case f r of - CoreM f' -> f' s') - return x = CoreM (\ s -> (s, x)) -runCoreM :: CoreM a -> CoreState -> a -runCoreM (CoreM f) s = snd $ f s -ask :: CoreM CoreState -ask = CoreM (\ s -> (s,s)) - -instance HasDynFlags CoreM where - getDynFlags = liftM cs_dflags ask - -mkExternalCore :: DynFlags -> CgGuts -> C.Module --- The ModGuts has been tidied, but the implicit bindings have --- not been injected, so we have to add them manually here --- We don't include the strange data-con *workers* because they are --- implicit in the data type declaration itself -mkExternalCore dflags (CgGuts {cg_module=this_mod, cg_tycons = tycons, - cg_binds = binds}) -{- Note that modules can be mutually recursive, but even so, we - print out dependency information within each module. -} - = C.Module (mname dflags) tdefs (runCoreM (mapM (make_vdef True) binds) initialState) - where - initialState = CoreState { - cs_dflags = dflags, - cs_module = this_mod - } - mname dflags = make_mid dflags this_mod - tdefs = foldr (collect_tdefs dflags) [] tycons - -collect_tdefs :: DynFlags -> TyCon -> [C.Tdef] -> [C.Tdef] -collect_tdefs dflags tcon tdefs - | isAlgTyCon tcon = tdef: tdefs - where - tdef | isNewTyCon tcon = - C.Newtype (qtc dflags tcon) - (qcc dflags (newTyConCo tcon)) - (map make_tbind tyvars) - (make_ty dflags (snd (newTyConRhs tcon))) - | otherwise = - C.Data (qtc dflags tcon) (map make_tbind tyvars) - (map (make_cdef dflags) (tyConDataCons tcon)) - tyvars = tyConTyVars tcon - -collect_tdefs _ _ tdefs = tdefs - -qtc :: DynFlags -> TyCon -> C.Qual C.Tcon -qtc dflags = make_con_qid dflags . tyConName - -qcc :: DynFlags -> CoAxiom br -> C.Qual C.Tcon -qcc dflags = make_con_qid dflags . co_ax_name - -make_cdef :: DynFlags -> DataCon -> C.Cdef -make_cdef dflags dcon = C.Constr dcon_name existentials tys - where - dcon_name = make_qid dflags False False (dataConName dcon) - existentials = map make_tbind ex_tyvars - ex_tyvars = dataConExTyVars dcon - tys = map (make_ty dflags) (dataConRepArgTys dcon) - -make_tbind :: TyVar -> C.Tbind -make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv)) - -make_vbind :: DynFlags -> Var -> C.Vbind -make_vbind dflags v = (make_var_id (Var.varName v), make_ty dflags (varType v)) - -make_vdef :: Bool -> CoreBind -> CoreM C.Vdefg -make_vdef topLevel b = - case b of - NonRec v e -> f (v,e) >>= (return . C.Nonrec) - Rec ves -> mapM f ves >>= (return . C.Rec) - where - f :: (CoreBndr,CoreExpr) -> CoreM C.Vdef - f (v,e) = do - localN <- isALocal vName - let local = not topLevel || localN - rhs <- make_exp e - -- use local flag to determine where to add the module name - dflags <- getDynFlags - return (local, make_qid dflags local True vName, make_ty dflags (varType v),rhs) - where vName = Var.varName v - -make_exp :: CoreExpr -> CoreM C.Exp -make_exp (Var v) = do - let vName = Var.varName v - isLocal <- isALocal vName - dflags <- getDynFlags - return $ - case idDetails v of - FCallId (CCall (CCallSpec (StaticTarget nm _ True) callconv _)) - -> C.External (unpackFS nm) (showPpr dflags callconv) (make_ty dflags (varType v)) - FCallId (CCall (CCallSpec (StaticTarget _ _ False) _ _)) -> - panic "make_exp: FFI values not supported" - FCallId (CCall (CCallSpec DynamicTarget callconv _)) - -> C.DynExternal (showPpr dflags callconv) (make_ty dflags (varType v)) - -- Constructors are always exported, so make sure to declare them - -- with qualified names - DataConWorkId _ -> C.Var (make_var_qid dflags False vName) - DataConWrapId _ -> C.Var (make_var_qid dflags False vName) - _ -> C.Var (make_var_qid dflags isLocal vName) -make_exp (Lit (MachLabel s _ _)) = return $ C.Label (unpackFS s) -make_exp (Lit l) = do dflags <- getDynFlags - return $ C.Lit (make_lit dflags l) -make_exp (App e (Type t)) = do b <- make_exp e - dflags <- getDynFlags - return $ C.Appt b (make_ty dflags t) -make_exp (App _e (Coercion _co)) = error "make_exp (App _ (Coercion _))" -- TODO -make_exp (App e1 e2) = do - rator <- make_exp e1 - rand <- make_exp e2 - return $ C.App rator rand -make_exp (Lam v e) | isTyVar v = make_exp e >>= (\ b -> - return $ C.Lam (C.Tb (make_tbind v)) b) -make_exp (Lam v e) | otherwise = do b <- make_exp e - dflags <- getDynFlags - return $ C.Lam (C.Vb (make_vbind dflags v)) b -make_exp (Cast e co) = do b <- make_exp e - dflags <- getDynFlags - return $ C.Cast b (make_co dflags co) -make_exp (Let b e) = do - vd <- make_vdef False b - body <- make_exp e - return $ C.Let vd body -make_exp (Case e v ty alts) = do - scrut <- make_exp e - newAlts <- mapM make_alt alts - dflags <- getDynFlags - return $ C.Case scrut (make_vbind dflags v) (make_ty dflags ty) newAlts -make_exp (Tick _ e) = make_exp e >>= (return . C.Tick "SCC") -- temporary -make_exp _ = error "MkExternalCore died: make_exp" - -make_alt :: CoreAlt -> CoreM C.Alt -make_alt (DataAlt dcon, vs, e) = do - newE <- make_exp e - dflags <- getDynFlags - return $ C.Acon (make_con_qid dflags (dataConName dcon)) - (map make_tbind tbs) - (map (make_vbind dflags) vbs) - newE - where (tbs,vbs) = span isTyVar vs -make_alt (LitAlt l,_,e) = do x <- make_exp e - dflags <- getDynFlags - return $ C.Alit (make_lit dflags l) x -make_alt (DEFAULT,[],e) = make_exp e >>= (return . C.Adefault) --- This should never happen, as the DEFAULT alternative binds no variables, --- but we might as well check for it: -make_alt a@(DEFAULT,_ ,_) = pprPanic ("MkExternalCore: make_alt: DEFAULT " - ++ "alternative had a non-empty var list") (ppr a) - - -make_lit :: DynFlags -> Literal -> C.Lit -make_lit dflags l = - case l of - -- Note that we need to check whether the character is "big". - -- External Core only allows character literals up to '\xff'. - MachChar i | i <= chr 0xff -> C.Lchar i t - -- For a character bigger than 0xff, we represent it in ext-core - -- as an int lit with a char type. - MachChar i -> C.Lint (fromIntegral $ ord i) t - MachStr s -> C.Lstring (BS.unpack s) t - MachNullAddr -> C.Lint 0 t - MachInt i -> C.Lint i t - MachInt64 i -> C.Lint i t - MachWord i -> C.Lint i t - MachWord64 i -> C.Lint i t - MachFloat r -> C.Lrational r t - MachDouble r -> C.Lrational r t - LitInteger i _ -> C.Lint i t - _ -> pprPanic "MkExternalCore died: make_lit" (ppr l) - where - t = make_ty dflags (literalType l) - --- Expand type synonyms, then convert. -make_ty :: DynFlags -> Type -> C.Ty -- Be sure to expand types recursively! - -- example: FilePath ~> String ~> [Char] -make_ty dflags t | Just expanded <- tcView t = make_ty dflags expanded -make_ty dflags t = make_ty' dflags t - --- note calls to make_ty so as to expand types recursively -make_ty' :: DynFlags -> Type -> C.Ty -make_ty' _ (TyVarTy tv) = C.Tvar (make_var_id (tyVarName tv)) -make_ty' dflags (AppTy t1 t2) = C.Tapp (make_ty dflags t1) (make_ty dflags t2) -make_ty' dflags (FunTy t1 t2) = make_ty dflags (TyConApp funTyCon [t1,t2]) -make_ty' dflags (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty dflags t) -make_ty' dflags (TyConApp tc ts) = make_tyConApp dflags tc ts -make_ty' _ (LitTy {}) = panic "MkExernalCore can't do literal types yet" - --- Newtypes are treated just like any other type constructor; not expanded --- Reason: predTypeRep does substitution and, while substitution deals --- correctly with name capture, it's only correct if you see the uniques! --- If you just see occurrence names, name capture may occur. --- Example: newtype A a = A (forall b. b -> a) --- test :: forall q b. q -> A b --- test _ = undefined --- Here the 'a' gets substituted by 'b', which is captured. --- Another solution would be to expand newtypes before tidying; but that would --- expose the representation in interface files, which definitely isn't right. --- Maybe CoreTidy should know whether to expand newtypes or not? - -make_tyConApp :: DynFlags -> TyCon -> [Type] -> C.Ty -make_tyConApp dflags tc ts = - foldl C.Tapp (C.Tcon (qtc dflags tc)) - (map (make_ty dflags) ts) - -make_kind :: Kind -> C.Kind -make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2) -make_kind k - | isLiftedTypeKind k = C.Klifted - | isUnliftedTypeKind k = C.Kunlifted - | isOpenTypeKind k = C.Kopen -make_kind _ = error "MkExternalCore died: make_kind" - -{- Id generation. -} - -make_id :: Bool -> Name -> C.Id --- include uniques for internal names in order to avoid name shadowing -make_id _is_var nm = ((occNameString . nameOccName) nm) - ++ (if isInternalName nm then (show . nameUnique) nm else "") - -make_var_id :: Name -> C.Id -make_var_id = make_id True - --- It's important to encode the module name here, because in External Core, --- base:GHC.Base => base:GHCziBase --- We don't do this in pprExternalCore because we --- *do* want to keep the package name (we don't want baseZCGHCziBase, --- because that would just be ugly.) --- SIGH. --- We encode the package name as well. -make_mid :: DynFlags -> Module -> C.Id --- Super ugly code, but I can't find anything else that does quite what I --- want (encodes the hierarchical module name without encoding the colon --- that separates the package name from it.) -make_mid dflags m - = showSDoc dflags $ - (text $ zEncodeString $ packageIdString $ modulePackageId m) - <> text ":" - <> (pprEncoded $ pprModuleName $ moduleName m) - where pprEncoded = pprCode CStyle - -make_qid :: DynFlags -> Bool -> Bool -> Name -> C.Qual C.Id -make_qid dflags force_unqual is_var n = (mname,make_id is_var n) - where mname = - case nameModule_maybe n of - Just m | not force_unqual -> make_mid dflags m - _ -> "" - -make_var_qid :: DynFlags -> Bool -> Name -> C.Qual C.Id -make_var_qid dflags force_unqual = make_qid dflags force_unqual True - -make_con_qid :: DynFlags -> Name -> C.Qual C.Id -make_con_qid dflags = make_qid dflags False False - -make_co :: DynFlags -> Coercion -> C.Coercion -make_co dflags (Refl r ty) = C.ReflCoercion (make_role r) $ make_ty dflags ty -make_co dflags (TyConAppCo r tc cos) = C.TyConAppCoercion (make_role r) (qtc dflags tc) (map (make_co dflags) cos) -make_co dflags (AppCo c1 c2) = C.AppCoercion (make_co dflags c1) (make_co dflags c2) -make_co dflags (ForAllCo tv co) = C.ForAllCoercion (make_tbind tv) (make_co dflags co) -make_co _ (CoVarCo cv) = C.CoVarCoercion (make_var_id (coVarName cv)) -make_co dflags (AxiomInstCo cc ind cos) = C.AxiomCoercion (qcc dflags cc) ind (map (make_co dflags) cos) -make_co dflags (UnivCo r t1 t2) = C.UnivCoercion (make_role r) (make_ty dflags t1) (make_ty dflags t2) -make_co dflags (SymCo co) = C.SymCoercion (make_co dflags co) -make_co dflags (TransCo c1 c2) = C.TransCoercion (make_co dflags c1) (make_co dflags c2) -make_co dflags (NthCo d co) = C.NthCoercion d (make_co dflags co) -make_co dflags (LRCo lr co) = C.LRCoercion (make_lr lr) (make_co dflags co) -make_co dflags (InstCo co ty) = C.InstCoercion (make_co dflags co) (make_ty dflags ty) -make_co dflags (SubCo co) = C.SubCoercion (make_co dflags co) -make_co _ (AxiomRuleCo {}) = panic "make_co AxiomRuleCo: not yet implemented" - - -make_lr :: LeftOrRight -> C.LeftOrRight -make_lr CLeft = C.CLeft -make_lr CRight = C.CRight - -make_role :: Role -> C.Role -make_role Nominal = C.Nominal -make_role Representational = C.Representational -make_role Phantom = C.Phantom - -------- -isALocal :: Name -> CoreM Bool -isALocal vName = do - modName <- liftM cs_module ask - return $ case nameModule_maybe vName of - -- Not sure whether isInternalName corresponds to "local"ness - -- in the External Core sense; need to re-read the spec. - Just m | m == modName -> isInternalName vName - _ -> False -\end{code} - - - - diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 35c0630736..f86a911ede 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -121,7 +121,7 @@ ppr_expr add_par (Cast expr co) if gopt Opt_SuppressCoercions dflags then ptext (sLit "...") else parens $ - sep [ppr co, dcolon <+> pprEqPred (coercionKind co)] + sep [ppr co, dcolon <+> ppr (coercionType co)] ppr_expr add_par expr@(Lam _ _) diff --git a/compiler/coreSyn/PprExternalCore.lhs b/compiler/coreSyn/PprExternalCore.lhs deleted file mode 100644 index 7fd3ac1d65..0000000000 --- a/compiler/coreSyn/PprExternalCore.lhs +++ /dev/null @@ -1,260 +0,0 @@ -% -% (c) The University of Glasgow 2001-2006 -% - -\begin{code} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module PprExternalCore () where - -import Encoding -import ExternalCore - -import Pretty -import Data.Char -import Data.Ratio - -instance Show Module where - showsPrec _ m = shows (pmodule m) - -instance Show Tdef where - showsPrec _ t = shows (ptdef t) - -instance Show Cdef where - showsPrec _ c = shows (pcdef c) - -instance Show Vdefg where - showsPrec _ v = shows (pvdefg v) - -instance Show Exp where - showsPrec _ e = shows (pexp e) - -instance Show Alt where - showsPrec _ a = shows (palt a) - -instance Show Ty where - showsPrec _ t = shows (pty t) - -instance Show Kind where - showsPrec _ k = shows (pkind k) - -instance Show Lit where - showsPrec _ l = shows (plit l) - - -indent :: Doc -> Doc -indent = nest 2 - -pmodule :: Module -> Doc -pmodule (Module mname tdefs vdefgs) = - (text "%module" <+> text mname) - $$ indent ((vcat (map ((<> char ';') . ptdef) tdefs)) - $$ (vcat (map ((<> char ';') . pvdefg) vdefgs))) - -ptdef :: Tdef -> Doc -ptdef (Data tcon tbinds cdefs) = - (text "%data" <+> pqname tcon <+> (hsep (map ptbind tbinds)) <+> char '=') - $$ indent (braces ((vcat (punctuate (char ';') (map pcdef cdefs))))) - -ptdef (Newtype tcon coercion tbinds rep) = - text "%newtype" <+> pqname tcon <+> pqname coercion - <+> (hsep (map ptbind tbinds)) $$ indent repclause - where repclause = char '=' <+> pty rep - -pcdef :: Cdef -> Doc -pcdef (Constr dcon tbinds tys) = - (pqname dcon) <+> (sep [hsep (map pattbind tbinds),sep (map paty tys)]) -pcdef (GadtConstr dcon ty) = - (pqname dcon) <+> text "::" <+> pty ty - -pname :: Id -> Doc -pname id = text (zEncodeString id) - -pqname :: Qual Id -> Doc -pqname ("",id) = pname id -pqname (m,id) = text m <> char '.' <> pname id - -ptbind, pattbind :: Tbind -> Doc -ptbind (t,Klifted) = pname t -ptbind (t,k) = parens (pname t <> text "::" <> pkind k) - -pattbind (t,k) = char '@' <> ptbind (t,k) - -pakind, pkind :: Kind -> Doc -pakind (Klifted) = char '*' -pakind (Kunlifted) = char '#' -pakind (Kopen) = char '?' -pakind k = parens (pkind k) - -pkind (Karrow k1 k2) = parens (pakind k1 <> text "->" <> pkind k2) -pkind k = pakind k - -paty, pbty, pty :: Ty -> Doc --- paty: print in parens, if non-atomic (like a name) --- pbty: print in parens, if arrow (used only for lhs of arrow) --- pty: not in parens -paty (Tvar n) = pname n -paty (Tcon c) = pqname c -paty t = parens (pty t) - -pbty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = parens(fsep [pbty t1, text "->",pty t2]) -pbty t = paty t - -pty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = fsep [pbty t1, text "->",pty t2] -pty (Tforall tb t) = text "%forall" <+> pforall [tb] t -pty ty@(Tapp {}) = pappty ty [] -pty ty@(Tvar {}) = paty ty -pty ty@(Tcon {}) = paty ty - -pappty :: Ty -> [Ty] -> Doc -pappty (Tapp t1 t2) ts = pappty t1 (t2:ts) -pappty t ts = sep (map paty (t:ts)) - -pforall :: [Tbind] -> Ty -> Doc -pforall tbs (Tforall tb t) = pforall (tbs ++ [tb]) t -pforall tbs t = hsep (map ptbind tbs) <+> char '.' <+> pty t - -paco, pbco, pco :: Coercion -> Doc -paco (ReflCoercion r ty) = char '<' <> pty ty <> text ">_" <> prole r -paco (TyConAppCoercion r qtc []) = pqname qtc <> char '_' <> prole r -paco (AxiomCoercion qtc i []) = pqname qtc <> char '[' <> int i <> char ']' -paco (CoVarCoercion cv) = pname cv -paco c = parens (pco c) - -pbco (TyConAppCoercion _ arr [co1, co2]) - | arr == tcArrow - = parens (fsep [pbco co1, text "->", pco co2]) -pbco co = paco co - -pco c@(ReflCoercion {}) = paco c -pco (SymCoercion co) = sep [text "%sub", paco co] -pco (TransCoercion co1 co2) = sep [text "%trans", paco co1, paco co2] -pco (TyConAppCoercion _ arr [co1, co2]) - | arr == tcArrow = fsep [pbco co1, text "->", pco co2] -pco (TyConAppCoercion r qtc cos) = parens (pqname qtc <+> sep (map paco cos)) <> char '_' <> prole r -pco co@(AppCoercion {}) = pappco co [] -pco (ForAllCoercion tb co) = text "%forall" <+> pforallco [tb] co -pco co@(CoVarCoercion {}) = paco co -pco (UnivCoercion r ty1 ty2) = sep [text "%univ", prole r, paty ty1, paty ty2] -pco (InstCoercion co ty) = sep [text "%inst", paco co, paty ty] -pco (NthCoercion i co) = sep [text "%nth", int i, paco co] -pco (AxiomCoercion qtc i cos) = pqname qtc <> char '[' <> int i <> char ']' <+> sep (map paco cos) -pco (LRCoercion CLeft co) = sep [text "%left", paco co] -pco (LRCoercion CRight co) = sep [text "%right", paco co] -pco (SubCoercion co) = sep [text "%sub", paco co] - -pappco :: Coercion -> [Coercion ] -> Doc -pappco (AppCoercion co1 co2) cos = pappco co1 (co2:cos) -pappco co cos = sep (map paco (co:cos)) - -pforallco :: [Tbind] -> Coercion -> Doc -pforallco tbs (ForAllCoercion tb co) = pforallco (tbs ++ [tb]) co -pforallco tbs co = hsep (map ptbind tbs) <+> char '.' <+> pco co - -prole :: Role -> Doc -prole Nominal = char 'N' -prole Representational = char 'R' -prole Phantom = char 'P' - -pvdefg :: Vdefg -> Doc -pvdefg (Rec vdefs) = text "%rec" $$ braces (indent (vcat (punctuate (char ';') (map pvdef vdefs)))) -pvdefg (Nonrec vdef) = pvdef vdef - -pvdef :: Vdef -> Doc --- TODO: Think about whether %local annotations are actually needed. --- Right now, the local flag is never used, because the Core doc doesn't --- explain the meaning of %local. -pvdef (_l,v,t,e) = sep [(pqname v <+> text "::" <+> pty t <+> char '='), - indent (pexp e)] - -paexp, pfexp, pexp :: Exp -> Doc -paexp (Var x) = pqname x -paexp (Dcon x) = pqname x -paexp (Lit l) = plit l -paexp e = parens(pexp e) - -plamexp :: [Bind] -> Exp -> Doc -plamexp bs (Lam b e) = plamexp (bs ++ [b]) e -plamexp bs e = sep [sep (map pbind bs) <+> text "->", - indent (pexp e)] - -pbind :: Bind -> Doc -pbind (Tb tb) = char '@' <+> ptbind tb -pbind (Vb vb) = pvbind vb - -pfexp (App e1 e2) = pappexp e1 [Left e2] -pfexp (Appt e t) = pappexp e [Right t] -pfexp e = paexp e - -pappexp :: Exp -> [Either Exp Ty] -> Doc -pappexp (App e1 e2) as = pappexp e1 (Left e2:as) -pappexp (Appt e t) as = pappexp e (Right t:as) -pappexp e as = fsep (paexp e : map pa as) - where pa (Left e) = paexp e - pa (Right t) = char '@' <+> paty t - -pexp (Lam b e) = char '\\' <+> plamexp [b] e -pexp (Let vd e) = (text "%let" <+> pvdefg vd) $$ (text "%in" <+> pexp e) -pexp (Case e vb ty alts) = sep [text "%case" <+> paty ty <+> paexp e, - text "%of" <+> pvbind vb] - $$ (indent (braces (vcat (punctuate (char ';') (map palt alts))))) -pexp (Cast e co) = (text "%cast" <+> parens (pexp e)) $$ paco co -pexp (Tick s e) = (text "%source" <+> pstring s) $$ pexp e -pexp (External n cc t) = (text "%external" <+> text cc <+> pstring n) $$ paty t -pexp (DynExternal cc t) = (text "%dynexternal" <+> text cc) $$ paty t -pexp (Label n) = (text "%label" <+> pstring n) -pexp e = pfexp e - -pvbind :: Vbind -> Doc -pvbind (x,t) = parens(pname x <> text "::" <> pty t) - -palt :: Alt -> Doc -palt (Acon c tbs vbs e) = - sep [pqname c, - sep (map pattbind tbs), - sep (map pvbind vbs) <+> text "->"] - $$ indent (pexp e) -palt (Alit l e) = - (plit l <+> text "->") - $$ indent (pexp e) -palt (Adefault e) = - (text "%_ ->") - $$ indent (pexp e) - -plit :: Lit -> Doc -plit (Lint i t) = parens (integer i <> text "::" <> pty t) --- we use (text (show (numerator r))) (and the same for denominator) --- because "(rational r)" was printing out things like "2.0e-2" (which --- isn't External Core), and (text (show r)) was printing out things --- like "((-1)/5)" which isn't either (it should be "(-1/5)"). -plit (Lrational r t) = parens (text (show (numerator r)) <+> char '%' - <+> text (show (denominator r)) <> text "::" <> pty t) -plit (Lchar c t) = parens (text ("\'" ++ escape [c] ++ "\'") <> text "::" <> pty t) --- This is a little messy. We shouldn't really be going via String. -plit (Lstring bs t) = parens (pstring str <> text "::" <> pty t) - where str = map (chr . fromIntegral) bs - -pstring :: String -> Doc -pstring s = doubleQuotes(text (escape s)) - -escape :: String -> String -escape s = foldr f [] (map ord s) - where - f cv rest - | cv > 0xFF = '\\':'x':hs ++ rest - | (cv < 0x20 || cv > 0x7e || cv == 0x22 || cv == 0x27 || cv == 0x5c) = - '\\':'x':h1:h0:rest - where (q1,r1) = quotRem cv 16 - h1 = intToDigit q1 - h0 = intToDigit r1 - hs = dropWhile (=='0') $ reverse $ mkHex cv - mkHex 0 = "" - mkHex cv = intToDigit r : mkHex q - where (q,r) = quotRem cv 16 - f cv rest = (chr cv):rest - -\end{code} - - - - diff --git a/compiler/coreSyn/TrieMap.lhs b/compiler/coreSyn/TrieMap.lhs index ac04adab1b..2744c5d0b8 100644 --- a/compiler/coreSyn/TrieMap.lhs +++ b/compiler/coreSyn/TrieMap.lhs @@ -4,14 +4,14 @@ % \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 TypeFamilies #-} +{-# LANGUAGE RankNTypes, TypeFamilies #-} module TrieMap( CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap, TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap, diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index c0fe9c03e3..e07a70fc65 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -5,6 +5,8 @@ % Author: Juan J. Quintela <quintela@krilin.dc.fi.udc.es> \begin{code} +{-# LANGUAGE CPP #-} + module Check ( check , ExhaustivePat ) where #include "HsVersions.h" @@ -21,7 +23,6 @@ import Name import TysWiredIn import PrelNames import TyCon -import Type import SrcLoc import UniqSet import Util @@ -123,7 +124,7 @@ untidy_message :: (Name, [HsLit]) -> (Name, [HsLit]) untidy_message (string, lits) = (string, map untidy_lit lits) \end{code} -The function @untidy@ does the reverse work of the @tidy_pat@ funcion. +The function @untidy@ does the reverse work of the @tidy_pat@ function. \begin{code} @@ -144,7 +145,7 @@ untidy b (L loc p) = L loc (untidy' b p) untidy' _ p@(ConPatIn _ (PrefixCon [])) = p untidy' b (ConPatIn name ps) = pars b (L loc (ConPatIn name (untidy_con ps))) untidy' _ (ListPat pats ty Nothing) = ListPat (map untidy_no_pars pats) ty Nothing - untidy' _ (TuplePat pats box ty) = TuplePat (map untidy_no_pars pats) box ty + untidy' _ (TuplePat pats box tys) = TuplePat (map untidy_no_pars pats) box tys untidy' _ (ListPat _ _ (Just _)) = panic "Check.untidy: Overloaded ListPat" untidy' _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!" untidy' _ (SigPatIn _ _) = panic "Check.untidy: SigPat" @@ -468,8 +469,8 @@ get_unused_cons used_cons = ASSERT( not (null used_cons) ) unused_cons where used_set :: UniqSet DataCon used_set = mkUniqSet [d | ConPatOut{ pat_con = L _ (RealDataCon d) } <- used_cons] - (ConPatOut { pat_ty = ty }) = head used_cons - Just (ty_con, inst_tys) = splitTyConApp_maybe ty + (ConPatOut { pat_con = L _ (RealDataCon con1), pat_arg_tys = inst_tys }) = head used_cons + ty_con = dataConTyCon con1 unused_cons = filterOut is_used (tyConDataCons ty_con) is_used con = con `elementOfUniqSet` used_set || dataConCannotMatch inst_tys con @@ -593,9 +594,9 @@ make_con (ConPatOut{ pat_con = L _ (RealDataCon id) }) (lp:lq:ps, constraints) | isInfixCon id = (nlInfixConPat (getName id) lp lq : ps, constraints) where q = unLoc lq -make_con (ConPatOut{ pat_con = L _ (RealDataCon id), pat_args = PrefixCon pats, pat_ty = ty }) (ps, constraints) - | isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) ty) : rest_pats, constraints) - | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType) : rest_pats, constraints) +make_con (ConPatOut{ pat_con = L _ (RealDataCon id), pat_args = PrefixCon pats, pat_arg_tys = tys }) (ps, constraints) + | isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) tys) : rest_pats, constraints) + | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType) : rest_pats, constraints) | otherwise = (nlConPat name pats_con : rest_pats, constraints) where name = getName id @@ -696,17 +697,16 @@ tidy_pat (CoPat _ pat _) = tidy_pat pat tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id)) tidy_pat (ViewPat _ _ ty) = WildPat ty tidy_pat (ListPat _ _ (Just (ty,_))) = WildPat ty -tidy_pat (ConPatOut { pat_con = L _ PatSynCon{}, pat_ty = ty }) - = WildPat ty +tidy_pat (ConPatOut { pat_con = L _ (PatSynCon syn), pat_arg_tys = tys }) + = WildPat (patSynInstResTy syn tys) tidy_pat pat@(ConPatOut { pat_con = L _ con, pat_args = ps }) = pat { pat_args = tidy_con con ps } tidy_pat (ListPat ps ty Nothing) - = unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty) - (mkNilPat list_ty) + = unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] [ty]) + (mkNilPat ty) (map tidy_lpat ps) - where list_ty = mkListTy ty -- introduce fake parallel array constructors to be able to handle parallel -- arrays with the existing machinery for constructor pattern @@ -714,11 +714,11 @@ tidy_pat (ListPat ps ty Nothing) tidy_pat (PArrPat ps ty) = unLoc $ mkPrefixConPat (parrFakeCon (length ps)) (map tidy_lpat ps) - (mkPArrTy ty) + [ty] -tidy_pat (TuplePat ps boxity ty) +tidy_pat (TuplePat ps boxity tys) = unLoc $ mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) - (map tidy_lpat ps) ty + (map tidy_lpat ps) tys where arity = length ps @@ -735,8 +735,8 @@ tidy_lit_pat :: HsLit -> Pat Id -- overlap with each other, or even explicit lists of Chars. tidy_lit_pat lit | HsString s <- lit - = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy) - (mkPrefixConPat nilDataCon [] stringTy) (unpackFS s) + = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] [charTy]) + (mkPrefixConPat nilDataCon [] [charTy]) (unpackFS s) | otherwise = tidyLitPat lit diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 0ac7de8022..fae5f36426 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -3,6 +3,8 @@ % (c) University of Glasgow, 2007 % \begin{code} +{-# LANGUAGE NondecreasingIndentation #-} + module Coverage (addTicksToBinds, hpcInitCode) where import Type @@ -117,7 +119,7 @@ guessSourceFile :: LHsBinds Id -> FilePath -> FilePath guessSourceFile binds orig_file = -- Try look for a file generated from a .hsc file to a -- .hs file, by peeking ahead. - let top_pos = catMaybes $ foldrBag (\ (_, (L pos _)) rest -> + let top_pos = catMaybes $ foldrBag (\ (L pos _) rest -> srcSpanFileName_maybe pos : rest) [] binds in case top_pos of @@ -152,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. @@ -229,11 +231,7 @@ shouldTickPatBind density top_lev -- Adding ticks to bindings addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id) -addTickLHsBinds binds = mapBagM addTick binds - where - addTick (origin, bind) = do - bind' <- addTickLHsBind bind - return (origin, bind') +addTickLHsBinds = mapBagM addTickLHsBind addTickLHsBind :: LHsBind Id -> TM (LHsBind Id) addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds, @@ -1235,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/Desugar.lhs b/compiler/deSugar/Desugar.lhs index cd75de9a3a..3160b35f15 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -6,6 +6,8 @@ The Desugarer: turning HsSyn into Core. \begin{code} +{-# LANGUAGE CPP #-} + module Desugar ( deSugar, deSugarExpr ) where import DynFlags @@ -50,8 +52,6 @@ import OrdList import Data.List import Data.IORef import Control.Monad( when ) -import Data.Maybe ( mapMaybe ) -import UniqFM \end{code} %************************************************************************ @@ -123,27 +123,20 @@ deSugar hsc_env ; let hpc_init | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info | otherwise = empty - ; let patsyn_defs = [(patSynId ps, ps) | ps <- patsyns] ; return ( ds_ev_binds , foreign_prs `appOL` core_prs `appOL` spec_prs , spec_rules ++ ds_rules, ds_vects - , ds_fords `appendStubC` hpc_init - , patsyn_defs) } + , ds_fords `appendStubC` hpc_init) } ; case mb_res of { Nothing -> return (msgs, Nothing) ; - Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, patsyn_defs) -> do + Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> do do { -- Add export flags to bindings keep_alive <- readIORef keep_var - ; let (rules_for_locals, rules_for_imps) - = partition isLocalRule all_rules - final_patsyns = addExportFlagsAndRules target export_set keep_alive [] patsyn_defs - exp_patsyn_wrappers = mapMaybe (patSynWrapper . snd) final_patsyns - exp_patsyn_matchers = map (patSynMatcher . snd) final_patsyns - keep_alive' = addListToUFM keep_alive (map (\x -> (x, getName x)) (exp_patsyn_wrappers ++ exp_patsyn_matchers)) - final_prs = addExportFlagsAndRules target - export_set keep_alive' rules_for_locals (fromOL all_prs) + ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules + final_prs = addExportFlagsAndRules target export_set keep_alive + rules_for_locals (fromOL all_prs) final_pgm = combineEvBinds ds_ev_binds final_prs -- Notice that we put the whole lot in a big Rec, even the foreign binds @@ -187,7 +180,7 @@ deSugar hsc_env mg_fam_insts = fam_insts, mg_inst_env = inst_env, mg_fam_inst_env = fam_inst_env, - mg_patsyns = map snd . filter (isExportedId . fst) $ final_patsyns, + mg_patsyns = filter ((`elemNameSet` export_set) . patSynName) patsyns, mg_rules = ds_rules_for_imps, mg_binds = ds_binds, mg_foreign = ds_fords, diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index 763106f2b3..35a2477fd5 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -6,7 +6,8 @@ Desugaring arrow commands \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -465,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 @@ -517,7 +518,7 @@ case bodies, containing the following fields: \begin{code} dsCmd ids local_vars stack_ty res_ty - (HsCmdCase exp (MG { mg_alts = matches, mg_arg_tys = arg_tys })) + (HsCmdCase exp (MG { mg_alts = matches, mg_arg_tys = arg_tys, mg_origin = origin })) env_ids = do stack_id <- newSysLocalDs stack_ty @@ -561,7 +562,7 @@ dsCmd ids local_vars stack_ty res_ty in_ty = envStackType env_ids stack_ty core_body <- dsExpr (HsCase exp (MG { mg_alts = matches', mg_arg_tys = arg_tys - , mg_res_ty = sum_ty })) + , mg_res_ty = sum_ty, mg_origin = origin })) -- Note that we replace the HsCase result type by sum_ty, -- which is the type of matches' diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 4833e8090a..172d19b9ac 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -10,7 +10,8 @@ in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at lower levels it is preserved with @let@/@letrec@s). \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -34,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 ) @@ -95,13 +97,8 @@ ds_lhs_binds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr)) ds_lhs_binds binds = do { ds_bs <- mapBagM dsLHsBind binds ; return (foldBag appOL id nilOL ds_bs) } -dsLHsBind :: (Origin, LHsBind Id) -> DsM (OrdList (Id,CoreExpr)) -dsLHsBind (origin, L loc bind) - = handleWarnings $ putSrcSpanDs loc $ dsHsBind bind - where - handleWarnings = if isGenerated origin - then discardWarningsDs - else id +dsLHsBind :: LHsBind Id -> DsM (OrdList (Id,CoreExpr)) +dsLHsBind (L loc bind) = putSrcSpanDs loc $ dsHsBind bind dsHsBind :: HsBind Id -> DsM (OrdList (Id,CoreExpr)) @@ -458,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 @@ -582,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] @@ -593,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] @@ -612,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 ] @@ -622,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] @@ -642,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -670,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 80f2ec525f..a47b9ea4dd 100644 --- a/compiler/deSugar/DsCCall.lhs +++ b/compiler/deSugar/DsCCall.lhs @@ -6,7 +6,8 @@ Desugaring foreign calls \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -237,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 d1ef24070c..2a2d733995 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -6,6 +6,8 @@ Desugaring exporessions. \begin{code} +{-# LANGUAGE CPP #-} + module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where #include "HsVersions.h" @@ -99,7 +101,7 @@ ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr -- a tuple and doing selections. -- Silently ignore INLINE and SPECIALISE pragmas... ds_val_bind (NonRecursive, hsbinds) body - | [(_, L loc bind)] <- bagToList hsbinds, + | [L loc bind] <- bagToList hsbinds, -- Non-recursive, non-overloaded bindings only come in ones -- ToDo: in some bizarre case it's conceivable that there -- could be dict binds in the 'binds'. (See the notes @@ -130,11 +132,11 @@ dsStrictBind :: HsBind Id -> CoreExpr -> DsM CoreExpr dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] , abs_exports = exports , abs_ev_binds = ev_binds - , abs_binds = binds }) body + , abs_binds = lbinds }) body = do { let body1 = foldr bind_export body exports bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b - ; body2 <- foldlBagM (\body (_, bind) -> dsStrictBind (unLoc bind) body) - body1 binds + ; body2 <- foldlBagM (\body lbind -> dsStrictBind (unLoc lbind) body) + body1 lbinds ; ds_binds <- dsTcEvBinds ev_binds ; return (mkCoreLets ds_binds body2) } @@ -163,8 +165,8 @@ dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) ---------------------- strictMatchOnly :: HsBind Id -> Bool -strictMatchOnly (AbsBinds { abs_binds = binds }) - = anyBag (strictMatchOnly . unLoc . snd) binds +strictMatchOnly (AbsBinds { abs_binds = lbinds }) + = anyBag (strictMatchOnly . unLoc) lbinds strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = rhs_ty }) = isUnLiftedType rhs_ty || isStrictLPat lpat @@ -290,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 @@ -433,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: @@ -488,7 +490,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) -- constructor aguments. ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd ; ([discrim_var], matching_code) - <- matchWrapper RecUpd (MG { mg_alts = alts, mg_arg_tys = [in_ty], mg_res_ty = out_ty }) + <- matchWrapper RecUpd (MG { mg_alts = alts, mg_arg_tys = [in_ty], mg_res_ty = out_ty, mg_origin = Generated }) ; return (add_field_binds field_binds' $ bindNonRec discrim_var record_expr' matching_code) } @@ -548,7 +550,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) , pat_dicts = eqs_vars ++ theta_vars , pat_binds = emptyTcEvBinds , pat_args = PrefixCon $ map nlVarPat arg_ids - , pat_ty = in_ty + , pat_arg_tys = in_inst_tys , pat_wrap = idHsWrapper } ; let wrapped_rhs | null eq_spec = rhs | otherwise = mkLHsWrap (mkWpCast (mkTcSubCo wrap_co)) rhs @@ -789,7 +791,8 @@ dsDo stmts rets = map noLoc rec_rets mfix_app = nlHsApp (noLoc mfix_op) mfix_arg mfix_arg = noLoc $ HsLam (MG { mg_alts = [mkSimpleMatch [mfix_pat] body] - , mg_arg_tys = [tup_ty], mg_res_ty = body_ty }) + , mg_arg_tys = [tup_ty], mg_res_ty = body_ty + , mg_origin = Generated }) mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTup rec_tup_pats body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty ret_app = nlHsApp (noLoc return_op) (mkBigLHsTup rets) diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index e2f4f4ff3c..c60e9146bc 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -6,6 +6,8 @@ Desugaring foreign declarations (see also DsCCall). \begin{code} +{-# LANGUAGE CPP #-} + module DsForeign ( dsForeigns , dsForeigns' , dsFImport, dsCImport, dsFCall, dsPrimCall @@ -222,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/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs index 4573e54ce0..a571e807d4 100644 --- a/compiler/deSugar/DsGRHSs.lhs +++ b/compiler/deSugar/DsGRHSs.lhs @@ -6,6 +6,8 @@ Matching guarded right-hand-sides (GRHSs) \begin{code} +{-# LANGUAGE CPP #-} + module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS ) where #include "HsVersions.h" @@ -61,10 +63,8 @@ dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty = ASSERT( notNull grhss ) do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss ; let match_result1 = foldr1 combineMatchResults match_results - match_result2 = adjustMatchResultDs - (\e -> dsLocalBinds binds e) - match_result1 - -- NB: nested dsLet inside matchResult + match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1 + -- NB: nested dsLet inside matchResult ; return match_result2 } dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id (LHsExpr Id) -> DsM MatchResult diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs index a1131a8126..2111c95f82 100644 --- a/compiler/deSugar/DsListComp.lhs +++ b/compiler/deSugar/DsListComp.lhs @@ -6,7 +6,7 @@ Desugaring list comprehensions, monad comprehensions and array comprehensions \begin{code} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE CPP, NamedFieldPuns #-} module DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 6df92af517..28e6feffec 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 2006 @@ -394,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 $ \ _ -> @@ -705,12 +707,14 @@ addTyVarBinds :: LHsTyVarBndrs Name -- the binders to -- the computations passed as the second argument is executed in that extended -- meta environment and gets the *new* names on Core-level as an argument -addTyVarBinds tvs m - = do { freshNames <- mkGenSyms (hsLKiTyVarNames tvs) - ; term <- addBinds freshNames $ - do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs `zip` freshNames) +addTyVarBinds (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) m + = do { fresh_kv_names <- mkGenSyms kvs + ; fresh_tv_names <- mkGenSyms (map hsLTyVarName tvs) + ; let fresh_names = fresh_kv_names ++ fresh_tv_names + ; term <- addBinds fresh_names $ + do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (tvs `zip` fresh_tv_names) ; m kbs } - ; wrapGenSyms freshNames term } + ; wrapGenSyms fresh_names term } where mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) @@ -1180,7 +1184,7 @@ rep_binds binds = do { binds_w_locs <- rep_binds' binds ; return (de_loc (sort_by_loc binds_w_locs)) } rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)] -rep_binds' binds = mapM (rep_bind . snd) (bagToList binds) +rep_binds' = mapM rep_bind . bagToList rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ) -- Assumes: all the binders of the binding are alrady in the meta-env @@ -1412,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 @@ -1472,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 [] @@ -2113,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/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index b590f4b2d2..c017a7cc01 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -6,6 +6,8 @@ @DsMonad@: monadery used in desugaring \begin{code} +{-# LANGUAGE FlexibleInstances #-} + module DsMonad ( DsM, mapM, mapAndUnzipM, initDs, initDsTc, fixDs, diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 2ad70c67d3..c52b917efd 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -8,7 +8,8 @@ Utilities for desugaring This module exports some utility functions of no great interest. \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -64,7 +65,6 @@ import ConLike import DataCon import PatSyn import Type -import Coercion import TysPrim import TysWiredIn import BasicTypes @@ -638,12 +638,13 @@ mkSelectorBinds ticks pat val_expr -- efficient too. -- For the error message we make one error-app, to avoid duplication. - -- But we need it at different types... so we use coerce for that - ; err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID unitTy (ppr pat) - ; err_var <- newSysLocalDs unitTy - ; binds <- zipWithM (mk_bind val_var err_var) ticks' binders - ; return ( (val_var, val_expr) : - (err_var, err_expr) : + -- But we need it at different types, so we make it polymorphic: + -- err_var = /\a. iRREFUT_PAT_ERR a "blah blah blah" + ; err_app <- mkErrorAppDs iRREFUT_PAT_ERROR_ID alphaTy (ppr pat) + ; err_var <- newSysLocalDs (mkForAllTy alphaTyVar alphaTy) + ; binds <- zipWithM (mk_bind val_var err_var) ticks' binders + ; return ( (val_var, val_expr) : + (err_var, Lam alphaTyVar err_app) : binds ) } | otherwise @@ -665,14 +666,13 @@ mkSelectorBinds ticks pat val_expr mk_bind scrut_var err_var tick bndr_var = do -- (mk_bind sv err_var) generates - -- bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var } + -- bv = case sv of { pat -> bv; other -> err_var @ type-of-bv } -- Remember, pat binds bv rhs_expr <- matchSimply (Var scrut_var) PatBindRhs pat (Var bndr_var) error_expr return (bndr_var, mkOptTickBox tick rhs_expr) where - error_expr = mkCast (Var err_var) co - co = mkUnsafeCo (exprType (Var err_var)) (idType bndr_var) + error_expr = Var err_var `App` Type (idType bndr_var) is_simple_lpat p = is_simple_pat (unLoc p) @@ -709,8 +709,7 @@ mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs) mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id -- A vanilla tuple pattern simply gets its type from its sub-patterns -mkVanillaTuplePat pats box - = TuplePat pats box (mkTupleTy (boxityNormalTupleSort box) (map hsLPatType pats)) +mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats) -- The Big equivalents for the source tuple expressions mkBigLHsVarTup :: [Id] -> LHsExpr Id diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 0433d873d5..a14027862a 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -6,6 +6,8 @@ The @match@ function \begin{code} +{-# LANGUAGE CPP #-} + module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where #include "HsVersions.h" @@ -40,7 +42,7 @@ import Maybes import Util import Name import Outputable -import BasicTypes ( boxityNormalTupleSort ) +import BasicTypes ( boxityNormalTupleSort, isGenerated ) import FastString import Control.Monad( when ) @@ -552,9 +554,8 @@ tidy1 v (LazyPat pat) tidy1 _ (ListPat pats ty Nothing) = return (idDsWrapper, unLoc list_ConPat) where - list_ty = mkListTy ty - list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty) - (mkNilPat list_ty) + list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty]) + (mkNilPat ty) pats -- Introduce fake parallel array constructors to be able to handle parallel @@ -563,13 +564,13 @@ tidy1 _ (PArrPat pats ty) = return (idDsWrapper, unLoc parrConPat) where arity = length pats - parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty) + parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty] -tidy1 _ (TuplePat pats boxity ty) +tidy1 _ (TuplePat pats boxity tys) = return (idDsWrapper, unLoc tuple_ConPat) where arity = length pats - tuple_ConPat = mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) pats ty + tuple_ConPat = mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) pats tys -- LitPats: we *might* be able to replace these w/ a simpler form tidy1 _ (LitPat lit) @@ -586,8 +587,6 @@ tidy1 _ non_interesting_pat -------------------- tidy_bang_pat :: Id -> SrcSpan -> Pat Id -> DsM (DsWrapper, Pat Id) --- BangPatterns: Pattern matching is already strict in constructors, --- tuples etc, so the last case strips off the bang for those patterns. -- Discard bang around strict pattern tidy_bang_pat v _ p@(ListPat {}) = tidy1 v p @@ -596,8 +595,7 @@ tidy_bang_pat v _ p@(PArrPat {}) = tidy1 v p tidy_bang_pat v _ p@(ConPatOut {}) = tidy1 v p tidy_bang_pat v _ p@(LitPat {}) = tidy1 v p --- Discard lazy/par/sig under a bang -tidy_bang_pat v _ (LazyPat (L l p)) = tidy_bang_pat v l p +-- Discard par/sig under a bang tidy_bang_pat v _ (ParPat (L l p)) = tidy_bang_pat v l p tidy_bang_pat v _ (SigPatOut (L l p) _) = tidy_bang_pat v l p @@ -607,7 +605,10 @@ tidy_bang_pat v l (AsPat v' p) = tidy1 v (AsPat v' (L l (BangPat p))) tidy_bang_pat v l (CoPat w p t) = tidy1 v (CoPat w (BangPat (L l p)) t) -- Default case, leave the bang there: --- VarPat, WildPat, ViewPat, NPat, NPlusKPat +-- VarPat, LazyPat, WildPat, ViewPat, NPat, NPlusKPat +-- For LazyPat, remember that it's semantically like a VarPat +-- i.e. !(~p) is not like ~p, or p! (Trac #8952) + tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p)) -- NB: SigPatIn, ConPatIn should not happen \end{code} @@ -752,12 +753,14 @@ JJQC 30-Nov-1997 \begin{code} matchWrapper ctxt (MG { mg_alts = matches , mg_arg_tys = arg_tys - , mg_res_ty = rhs_ty }) + , mg_res_ty = rhs_ty + , mg_origin = origin }) = do { eqns_info <- mapM mk_eqn_info matches ; new_vars <- case matches of [] -> mapM newSysLocalDs arg_tys (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m)) - ; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty + ; result_expr <- handleWarnings $ + matchEquations ctxt new_vars eqns_info rhs_ty ; return (new_vars, result_expr) } where mk_eqn_info (L _ (Match pats _ grhss)) @@ -765,6 +768,10 @@ matchWrapper ctxt (MG { mg_alts = matches ; match_result <- dsGRHSs ctxt upats grhss rhs_ty ; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) } + handleWarnings = if isGenerated origin + then discardWarningsDs + else id + matchEquations :: HsMatchContext Name -> [Id] -> [EquationInfo] -> Type diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs index 2b51638bf3..8e581f66e2 100644 --- a/compiler/deSugar/MatchCon.lhs +++ b/compiler/deSugar/MatchCon.lhs @@ -6,7 +6,8 @@ Pattern-matching constructors \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -124,7 +125,7 @@ matchOneConLike :: [Id] -> [EquationInfo] -> DsM (CaseAlt ConLike) matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor - = do { arg_vars <- selectConMatchVars arg_tys args1 + = do { arg_vars <- selectConMatchVars val_arg_tys args1 -- Use the first equation as a source of -- suggestions for the new variables @@ -140,27 +141,24 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor alt_wrapper = wrapper1, alt_result = foldr1 combineMatchResults match_results } } where - ConPatOut { pat_con = L _ con1, pat_ty = pat_ty1, pat_wrap = wrapper1, + ConPatOut { pat_con = L _ con1, pat_arg_tys = arg_tys, pat_wrap = wrapper1, pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 } = firstPat eqn1 fields1 = case con1 of - RealDataCon dcon1 -> dataConFieldLabels dcon1 - PatSynCon{} -> [] - - arg_tys = inst inst_tys - where - inst = case con1 of - RealDataCon dcon1 -> dataConInstOrigArgTys dcon1 - PatSynCon psyn1 -> patSynInstArgTys psyn1 - inst_tys = tcTyConAppArgs pat_ty1 ++ - mkTyVarTys (takeList exVars tvs1) - -- Newtypes opaque, hence tcTyConAppArgs + RealDataCon dcon1 -> dataConFieldLabels dcon1 + PatSynCon{} -> [] + + val_arg_tys = case con1 of + RealDataCon dcon1 -> dataConInstOrigArgTys dcon1 inst_tys + PatSynCon psyn1 -> patSynInstArgTys psyn1 inst_tys + inst_tys = ASSERT( tvs1 `equalLength` ex_tvs ) + arg_tys ++ mkTyVarTys tvs1 -- dataConInstOrigArgTys takes the univ and existential tyvars -- and returns the types of the *value* args, which is what we want - where - exVars = case con1 of - RealDataCon dcon1 -> dataConExTyVars dcon1 - PatSynCon psyn1 -> patSynExTyVars psyn1 + + ex_tvs = case con1 of + RealDataCon dcon1 -> dataConExTyVars dcon1 + PatSynCon psyn1 -> patSynExTyVars psyn1 match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult -- All members of the group have compatible ConArgPats @@ -178,7 +176,7 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor return ( wrapBinds (tvs `zip` tvs1) . wrapBinds (ds `zip` dicts1) . mkCoreLets ds_bind - , eqn { eqn_pats = conArgPats arg_tys args ++ pats } + , eqn { eqn_pats = conArgPats val_arg_tys args ++ pats } ) shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps) diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index 7429a613d9..71a5e10636 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -6,6 +6,8 @@ Pattern-matching literal patterns \begin{code} +{-# LANGUAGE CPP, ScopedTypeVariables #-} + module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey , tidyLitPat, tidyNPat , matchLiterals, matchNPlusKPats, matchNPats @@ -90,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 @@ -264,8 +266,8 @@ tidyLitPat :: HsLit -> Pat Id tidyLitPat (HsChar c) = unLoc (mkCharLitPat c) tidyLitPat (HsString s) | lengthFS s <= 1 -- Short string literals only - = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy) - (mkNilPat stringTy) (unpackFS s) + = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] [charTy]) + (mkNilPat charTy) (unpackFS s) -- The stringTy is the type of the whole pattern, not -- the type to instantiate (:) or [] with! tidyLitPat lit = LitPat lit @@ -297,7 +299,7 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _ | isStringTy ty, Just str_lit <- mb_str_lit = tidy_lit_pat (HsString str_lit) where mk_con_pat :: DataCon -> HsLit -> Pat Id - mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] ty) + mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] []) mb_int_lit :: Maybe Integer mb_int_lit = case (mb_neg, val) of diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index bf62ac3996..d449adac67 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -18,7 +18,7 @@ Description: through this package. Category: Development Build-Type: Simple -Cabal-Version: >= 1.2.3 +Cabal-Version: >=1.10 Flag ghci Description: Build GHCi support. @@ -41,6 +41,7 @@ Flag stage3 Manual: True Library + Default-Language: Haskell2010 Exposed: False Build-Depends: base >= 4 && < 5, @@ -53,7 +54,9 @@ Library filepath >= 1 && < 1.4, Cabal, hpc, - transformers + transformers, + bin-package-db, + hoopl if flag(stage1) && impl(ghc < 7.5) Build-Depends: old-time >= 1 && < 1.2 @@ -70,19 +73,44 @@ Library CPP-Options: -DGHCI Include-Dirs: ../rts/dist/build @FFIIncludeDir@ - Build-Depends: bin-package-db - Build-Depends: hoopl - - Extensions: CPP, MagicHash, UnboxedTuples, PatternGuards, - ForeignFunctionInterface, EmptyDataDecls, - TypeSynonymInstances, MultiParamTypeClasses, - FlexibleInstances, RankNTypes, ScopedTypeVariables, - DeriveDataTypeable, BangPatterns - if impl(ghc >= 7.1) - Extensions: NondecreasingIndentation + Other-Extensions: + BangPatterns + CPP + DataKinds + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveTraversable + DisambiguateRecordFields + ExplicitForAll + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + MagicHash + MultiParamTypeClasses + NamedFieldPuns + NondecreasingIndentation + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + Trustworthy + TupleSections + TypeFamilies + TypeSynonymInstances + UnboxedTuples + UndecidableInstances 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 @@ -96,8 +124,6 @@ Library c-sources: parser/cutils.c - - c-sources: ghci/keepCAFsForGHCi.c cbits/genSym.c @@ -232,11 +258,8 @@ Library CoreTidy CoreUnfold CoreUtils - ExternalCore MkCore - MkExternalCore PprCore - PprExternalCore Check Coverage Desugar @@ -303,12 +326,9 @@ Library TidyPgm Ctype HaddockUtils - LexCore Lexer OptCoercion Parser - ParserCore - ParserCoreUtils RdrHsSyn ForeignCall PrelInfo 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/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index 9ec783a40d..52d6adde86 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -5,8 +5,8 @@ ByteCodeLink: Bytecode assembler and linker \begin{code} -{-# OPTIONS -optc-DNON_POSIX_SOURCE #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, CPP, MagicHash #-} +{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} module ByteCodeAsm ( assembleBCOs, assembleBCO, diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index 6dfee5629a..645a0d8118 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -5,13 +5,7 @@ ByteCodeGen: Generate bytecode from Core \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - +{-# LANGUAGE CPP, MagicHash #-} module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where #include "HsVersions.h" @@ -277,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 @@ -819,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, _, _) @@ -1252,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) @@ -1563,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 005a430cd9..5535d58453 100644 --- a/compiler/ghci/ByteCodeInstr.lhs +++ b/compiler/ghci/ByteCodeInstr.lhs @@ -4,23 +4,16 @@ ByteCodeInstrs: Bytecode instruction definitions \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - +{-# LANGUAGE CPP, MagicHash #-} {-# 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 @@ -43,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 ())] } @@ -79,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 @@ -111,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 @@ -146,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 @@ -172,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 '}' @@ -211,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) @@ -220,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" @@ -255,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)" @@ -264,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 @@ -283,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/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs index ce6bd01f16..7a7a62d980 100644 --- a/compiler/ghci/ByteCodeItbls.lhs +++ b/compiler/ghci/ByteCodeItbls.lhs @@ -4,7 +4,8 @@ ByteCodeItbls: Generate infotables for interpreter-made bytecodes \begin{code} -{-# OPTIONS -optc-DNON_POSIX_SOURCE #-} +{-# LANGUAGE CPP, MagicHash #-} +{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls, peekItbl , StgInfoTable(..) diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs index 4c484097f0..cbedb717fe 100644 --- a/compiler/ghci/ByteCodeLink.lhs +++ b/compiler/ghci/ByteCodeLink.lhs @@ -5,7 +5,12 @@ ByteCodeLink: Bytecode assembler and linker \begin{code} {-# LANGUAGE BangPatterns #-} -{-# OPTIONS -optc-DNON_POSIX_SOURCE #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} module ByteCodeLink ( ClosureEnv, emptyClosureEnv, extendClosureEnv, @@ -255,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/Debugger.hs b/compiler/ghci/Debugger.hs index 0807bf17b5..4966714181 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MagicHash #-} + ----------------------------------------------------------------------------- -- -- GHCi Interactive debugging commands diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs index 3d73e69e2b..9ccb113314 100644 --- a/compiler/ghci/DebuggerUtils.hs +++ b/compiler/ghci/DebuggerUtils.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module DebuggerUtils ( dataConInfoPtrToName, ) where @@ -44,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 274f2fbd44..86d7b268d0 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -2,15 +2,16 @@ % (c) The University of Glasgow 2005-2012 % \begin{code} +{-# LANGUAGE CPP, NondecreasingIndentation #-} +{-# OPTIONS_GHC -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + -- | The dynamic linker for GHCi. -- -- This module deals with the top-level issues of dynamic linking, -- calling the object-code linker and the byte-code linker where -- necessary. -{-# OPTIONS -fno-cse #-} --- -fno-cse is needed for GLOBAL_VAR's to behave properly - module Linker ( getHValue, showLinkerState, linkExpr, linkDecls, unload, withExtendedLinkEnv, extendLinkEnv, deleteFromLinkEnv, @@ -58,18 +59,13 @@ import Control.Monad import Data.IORef import Data.List -import qualified Data.Map as Map import Control.Concurrent.MVar import System.FilePath import System.IO -#if __GLASGOW_HASKELL__ > 704 import System.Directory hiding (findFile) -#else -import System.Directory -#endif -import Distribution.Package hiding (depends, PackageId) +import Distribution.Package hiding (depends, mkPackageKey, PackageKey) import Exception \end{code} @@ -123,7 +119,7 @@ data PersistentLinkerState -- The currently-loaded packages; always object code -- Held, as usual, in dependency order; though I am not sure if -- that is really important - pkgs_loaded :: ![PackageId] + pkgs_loaded :: ![PackageKey] } emptyPLS :: DynFlags -> PersistentLinkerState @@ -139,10 +135,10 @@ emptyPLS _ = PersistentLinkerState { -- -- The linker's symbol table is populated with RTS symbols using an -- explicit list. See rts/Linker.c for details. - where init_pkgs = [rtsPackageId] + where init_pkgs = [rtsPackageKey] -extendLoadedPkgs :: [PackageId] -> IO () +extendLoadedPkgs :: [PackageKey] -> IO () extendLoadedPkgs pkgs = modifyPLS_ $ \s -> return s{ pkgs_loaded = pkgs ++ pkgs_loaded s } @@ -526,7 +522,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 @@ -564,8 +560,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 @@ -579,7 +575,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 @@ -1044,7 +1040,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. -- @@ -1060,16 +1056,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 @@ -1077,17 +1070,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 () @@ -1208,7 +1200,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 @@ -1225,6 +1219,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 5e9bddca88..dde813d31d 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP, ScopedTypeVariables, MagicHash, UnboxedTuples #-} + ----------------------------------------------------------------------------- -- -- GHC Interactive support for inspecting arbitrary closures at runtime @@ -5,14 +7,6 @@ -- Pepe Iborra (supported by Google SoC) 2006 -- ----------------------------------------------------------------------------- - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module RtClosureInspect( cvObtainTerm, -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term cvReconstructType, @@ -83,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 @@ -140,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 @@ -161,7 +155,7 @@ data Closure = Closure { tipe :: ClosureType } instance Outputable ClosureType where - ppr = text . show + ppr = text . show #include "../includes/rts/storage/ClosureTypes.h" @@ -173,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 = @@ -192,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' @@ -210,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 @@ -238,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) @@ -313,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, @@ -345,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 @@ -376,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>") @@ -390,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" @@ -399,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. @@ -411,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 @@ -428,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) @@ -439,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) @@ -447,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) @@ -459,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 '\'') @@ -472,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 @@ -522,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 @@ -535,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) -} @@ -572,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 } @@ -581,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 @@ -606,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) } @@ -696,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 @@ -713,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 @@ -733,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 @@ -760,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 @@ -873,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 @@ -919,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)]) @@ -952,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)) @@ -973,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, @@ -982,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. @@ -1124,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. @@ -1172,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 @@ -1183,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) @@ -1191,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' @@ -1203,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 }) @@ -1212,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 0ec91ec1c3..d722a402e0 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -6,6 +6,8 @@ This module converts Template Haskell syntax into HsSyn \begin{code} +{-# LANGUAGE MagicHash #-} + module Convert( convertToHsExpr, convertToPat, convertToHsDecls, convertToHsType, thRdrNameGuesses ) where @@ -199,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") @@ -214,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 @@ -278,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] @@ -301,7 +310,7 @@ cvt_ci_decs doc decs ; unless (null bads) (failWith (mkBadDecMsg doc bads)) --We use FromSource as the origin of the bind -- because the TH declaration is user-written - ; return (listToBag (map (\bind -> (FromSource, bind)) binds'), sigs', fams', ats', adts') } + ; return (listToBag binds', sigs', fams', ats', adts') } ---------------- cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr] @@ -536,9 +545,7 @@ cvtLocalDecs doc ds ; let (binds, prob_sigs) = partitionWith is_bind ds' ; let (sigs, bads) = partitionWith is_sig prob_sigs ; unless (null bads) (failWith (mkBadDecMsg doc bads)) - ; return (HsValBinds (ValBindsIn (toBindBag binds) sigs)) } - where - toBindBag = listToBag . map (\bind -> (FromSource, bind)) + ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) } cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName)) cvtClause (Clause ps body wheres) @@ -563,10 +570,10 @@ cvtl e = wrapL (cvt e) cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' } cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e - ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) } + ; return $ HsLam (mkMatchGroup FromSource [mkSimpleMatch ps' e']) } cvt (LamCaseE ms) = do { ms' <- mapM cvtMatch ms ; return $ HsLamCase placeHolderType - (mkMatchGroup ms') + (mkMatchGroup FromSource ms') } cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' } -- Note [Dropping constructors] @@ -582,7 +589,7 @@ cvtl e = wrapL (cvt e) cvt (LetE ds e) = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds ; e' <- cvtl e; return $ HsLet ds' e' } cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM cvtMatch ms - ; return $ HsCase e' (mkMatchGroup ms') } + ; return $ HsCase e' (mkMatchGroup FromSource ms') } cvt (DoE ss) = cvtHsDo DoExpr ss cvt (CompE ss) = cvtHsDo ListComp ss cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' } @@ -830,8 +837,8 @@ cvtp (TH.LitP l) | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' } cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' } cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors] -cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void } -cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed void } +cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed [] } +cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] } cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps ; return $ ConPatIn s' (PrefixCon ps') } cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2 @@ -1108,8 +1115,10 @@ thRdrName loc ctxt_ns th_occ th_name TH.NameQ mod -> (mkRdrQual $! mk_mod mod) $! occ TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq uniq) $! occ) loc) TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq uniq) $! occ) loc) - TH.NameS | Just name <- isBuiltInOcc ctxt_ns th_occ -> nameRdrName $! name - | otherwise -> mkRdrUnqual $! occ + TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name + | otherwise -> mkRdrUnqual $! occ + -- We check for built-in syntax here, because the TH + -- user might have written a (NameS "(,,)"), for example where occ :: OccName.OccName occ = mk_occ ctxt_ns th_occ @@ -1129,25 +1138,6 @@ thRdrNameGuesses (TH.Name occ flavour) | otherwise = [OccName.varName, OccName.tvName] occ_str = TH.occString occ -isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name --- Built in syntax isn't "in scope" so an Unqual RdrName won't do --- We must generate an Exact name, just as the parser does -isBuiltInOcc ctxt_ns occ - = case occ of - ":" -> Just (Name.getName consDataCon) - "[]" -> Just (Name.getName nilDataCon) - "()" -> Just (tup_name 0) - '(' : ',' : rest -> go_tuple 2 rest - _ -> Nothing - where - go_tuple n ")" = Just (tup_name n) - go_tuple n (',' : rest) = go_tuple (n+1) rest - go_tuple _ _ = Nothing - - tup_name n - | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon BoxedTuple n) - | otherwise = Name.getName (tupleCon BoxedTuple n) - -- The packing and unpacking is rather turgid :-( mk_occ :: OccName.NameSpace -> String -> OccName.OccName mk_occ ns occ = OccName.mkOccName ns occ @@ -1160,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) @@ -1175,7 +1165,7 @@ Consider this TH term construction: ; x3 <- TH.newName "x" ; let x = mkName "x" -- mkName :: String -> TH.Name - -- Builds a NameL + -- Builds a NameS ; return (LamE (..pattern [x1,x2]..) $ LamE (VarPat x3) $ diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index e904633eec..04a72225f1 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -89,7 +89,7 @@ type LHsBind id = LHsBindLR id id type LHsBinds id = LHsBindsLR id id type HsBind id = HsBindLR id id -type LHsBindsLR idL idR = Bag (Origin, LHsBindLR idL idR) +type LHsBindsLR idL idR = Bag (LHsBindLR idL idR) type LHsBindLR idL idR = Located (HsBindLR idL idR) data HsBindLR idL idR @@ -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" @@ -322,7 +324,7 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR id pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc pprLHsBinds binds | isEmptyLHsBinds binds = empty - | otherwise = pprDeclList (map (ppr . snd) (bagToList binds)) + | otherwise = pprDeclList (map ppr (bagToList binds)) pprLHsBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2) => LHsBindsLR idL idR -> [LSig id2] -> [SDoc] @@ -338,7 +340,7 @@ pprLHsBindsForUser binds sigs decls :: [(SrcSpan, SDoc)] decls = [(loc, ppr sig) | L loc sig <- sigs] ++ - [(loc, ppr bind) | (_, L loc bind) <- bagToList binds] + [(loc, ppr bind) | L loc bind <- bagToList binds] sort_by_loc decls = sortBy (comparing fst) decls @@ -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 bae804eb07..9680c89e9b 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -23,13 +23,14 @@ module HsDecls ( tyFamInstDeclName, tyFamInstDeclLName, countTyClDecls, pprTyClDeclFlavour, tyClDeclLName, tyClDeclTyVars, + hsDeclHasCusk, famDeclHasCusk, FamilyDecl(..), LFamilyDecl, -- ** Instance declarations InstDecl(..), LInstDecl, NewOrData(..), FamilyInfo(..), TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts, DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, - TyFamInstEqn(..), LTyFamInstEqn, + TyFamEqn(..), TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn, LClsInstDecl, ClsInstDecl(..), -- ** Standalone deriving declarations @@ -93,6 +94,7 @@ import Bag import Data.Data hiding (TyCon) import Data.Foldable (Foldable) import Data.Traversable +import Data.Maybe \end{code} %************************************************************************ @@ -472,7 +474,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 +575,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 @@ -604,8 +606,54 @@ countTyClDecls decls isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True isNewTy _ = False + +-- | Does this declaration have a complete, user-supplied kind signature? +-- See Note [Complete user-supplied kind signatures] +hsDeclHasCusk :: TyClDecl name -> Bool +hsDeclHasCusk (ForeignType {}) = True +hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) = famDeclHasCusk fam_decl +hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs }) + = hsTvbAllKinded tyvars && rhs_annotated rhs + where + rhs_annotated (L _ ty) = case ty of + HsParTy lty -> rhs_annotated lty + HsKindSig {} -> True + _ -> False +hsDeclHasCusk (DataDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars +hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars + +-- | Does this family declaration have a complete, user-supplied kind signature? +famDeclHasCusk :: FamilyDecl name -> Bool +famDeclHasCusk (FamilyDecl { fdInfo = ClosedTypeFamily _ + , fdTyVars = tyvars + , fdKindSig = m_sig }) + = hsTvbAllKinded tyvars && isJust m_sig +famDeclHasCusk _ = True -- all open families have CUSKs! \end{code} +Note [Complete user-supplied kind signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We kind-check declarations differently if they have a complete, user-supplied +kind signature (CUSK). This is because we can safely generalise a CUSKed +declaration before checking all of the others, supporting polymorphic recursion. +See https://ghc.haskell.org/trac/ghc/wiki/GhcKinds/KindInference#Proposednewstrategy +and #9200 for lots of discussion of how we got here. + +A declaration has a CUSK if we can know its complete kind without doing any inference, +at all. Here are the rules: + + - A class or datatype is said to have a CUSK if and only if all of its type +variables are annotated. Its result kind is, by construction, Constraint or * +respectively. + + - A type synonym has a CUSK if and only if all of its type variables and its +RHS are annotated with kinds. + + - A closed type family is said to have a CUSK if and only if all of its type +variables and its return type are annotated. + + - An open type family always has a CUSK -- unannotated type variables (and return type) default to *. + \begin{code} instance OutputableBndr name => Outputable (TyClDecl name) where @@ -632,7 +680,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 +705,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 +726,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 +734,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 +942,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 +994,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 +1008,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 +1055,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 +1091,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 +1103,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 +1145,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} %************************************************************************ @@ -1236,7 +1331,7 @@ instance OutputableBndr name => Outputable (RuleDecl name) where nest 4 (equals <+> pprExpr (unLoc rhs) <+> text "#-}") ] where pp_forall | null ns = empty - | otherwise = text "forall" <+> fsep (map ppr ns) <> dot + | otherwise = forAllLit <+> fsep (map ppr ns) <> dot instance OutputableBndr name => Outputable (RuleBndr name) where ppr (RuleBndr name) = ppr name diff --git a/compiler/hsSyn/HsDoc.hs b/compiler/hsSyn/HsDoc.hs index 2cb28540f9..72bf0e56a4 100644 --- a/compiler/hsSyn/HsDoc.hs +++ b/compiler/hsSyn/HsDoc.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP, DeriveDataTypeable #-} module HsDoc ( HsDocString(..), diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 4c0c955cdd..69b6df64ec 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -3,7 +3,7 @@ % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \begin{code} -{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} +{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} -- | Abstract Haskell syntax for expressions. module HsExpr where @@ -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 @@ -630,13 +628,13 @@ ppr_expr (HsTickPragma externalSrcLoc exp) ptext (sLit ")")] ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True) - = hsep [ppr_lexpr arrow, ptext (sLit "-<"), ppr_lexpr arg] + = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False) - = hsep [ppr_lexpr arg, ptext (sLit ">-"), ppr_lexpr arrow] + = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow] ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True) - = hsep [ppr_lexpr arrow, ptext (sLit "-<<"), ppr_lexpr arg] + = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg] ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False) - = hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow] + = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2]) = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]] @@ -849,13 +847,13 @@ ppr_cmd (HsCmdCast co cmd) = sep [ ppr_cmd cmd , ptext (sLit "|>") <+> ppr co ] ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp True) - = hsep [ppr_lexpr arrow, ptext (sLit "-<"), ppr_lexpr arg] + = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp False) - = hsep [ppr_lexpr arg, ptext (sLit ">-"), ppr_lexpr arrow] + = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow] ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp True) - = hsep [ppr_lexpr arrow, ptext (sLit "-<<"), ppr_lexpr arg] + = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg] ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp False) - = hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow] + = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] ppr_cmd (HsCmdArrForm (L _ (HsVar v)) (Just _) [arg1, arg2]) = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]] @@ -909,7 +907,8 @@ patterns in each equation. data MatchGroup id body = MG { mg_alts :: [LMatch id body] -- The alternatives , mg_arg_tys :: [PostTcType] -- Types of the arguments, t1..tn - , mg_res_ty :: PostTcType } -- Type of the result, tr + , mg_res_ty :: PostTcType -- Type of the result, tr + , mg_origin :: Origin } -- The type is the type of the entire group -- t1 -> ... -> tn -> tr -- where there are n patterns @@ -1299,7 +1298,7 @@ instance (OutputableBndr idL, OutputableBndr idR, Outputable body) pprStmt :: (OutputableBndr idL, OutputableBndr idR, Outputable body) => (StmtLR idL idR body) -> SDoc pprStmt (LastStmt expr _) = ifPprDebug (ptext (sLit "[last]")) <+> ppr expr -pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, ptext (sLit "<-"), ppr expr] +pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, larrow, ppr expr] pprStmt (LetStmt binds) = hsep [ptext (sLit "let"), pprBinds binds] pprStmt (BodyStmt expr _ _ _) = ppr expr pprStmt (ParStmt stmtss _ _) = sep (punctuate (ptext (sLit " | ")) (map ppr stmtss)) diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs index 9565acbc8f..a4749dd730 100644 --- a/compiler/hsSyn/HsLit.lhs +++ b/compiler/hsSyn/HsLit.lhs @@ -5,14 +5,14 @@ \section[HsLit]{Abstract syntax: source-language literals} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 DeriveDataTypeable #-} +{-# LANGUAGE CPP, DeriveDataTypeable #-} module HsLit where diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index ef888fe5a8..4b8fcdaae7 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -75,10 +75,13 @@ data Pat id -- overall type of the pattern, and the toList -- function to convert the scrutinee to a list value - | TuplePat [LPat id] -- Tuple - Boxity -- UnitPat is TuplePat [] - PostTcType - -- You might think that the PostTcType was redundant, but it's essential + | TuplePat [LPat id] -- Tuple sub-patterns + Boxity -- UnitPat is TuplePat [] + [PostTcType] -- [] before typechecker, filled in afterwards with + -- the types of the tuple components + -- You might think that the PostTcType was redundant, because we can + -- get the pattern type by getting the types of the sub-patterns. + -- But it's essential -- data T a where -- T1 :: Int -> T Int -- f :: (T a, a) -> Int @@ -89,6 +92,8 @@ data Pat id -- Note the (w::a), NOT (w::Int), because we have not yet -- refined 'a' to Int. So we must know that the second component -- of the tuple is of type 'a' not Int. See selectMatchVar + -- (June 14: I'm not sure this comment is right; the sub-patterns + -- will be wrapped in CoPats, no?) | PArrPat [LPat id] -- Syntactic parallel array PostTcType -- The type of the elements @@ -98,14 +103,18 @@ data Pat id (HsConPatDetails id) | ConPatOut { - pat_con :: Located ConLike, + pat_con :: Located ConLike, + pat_arg_tys :: [Type], -- The univeral arg types, 1-1 with the universal + -- tyvars of the constructor/pattern synonym + -- Use (conLikeResTy pat_con pat_arg_tys) to get + -- the type of the pattern + pat_tvs :: [TyVar], -- Existentially bound type variables (tyvars only) pat_dicts :: [EvVar], -- Ditto *coercion variables* and *dictionaries* -- One reason for putting coercion variable here, I think, -- is to ensure their kinds are zonked pat_binds :: TcEvBinds, -- Bindings involving those dictionaries pat_args :: HsConPatDetails id, - pat_ty :: Type, -- The type of the pattern pat_wrap :: HsWrapper -- Extra wrapper to pass to the matcher } @@ -313,18 +322,18 @@ instance (OutputableBndr id, Outputable arg) %************************************************************************ \begin{code} -mkPrefixConPat :: DataCon -> [OutPat id] -> Type -> OutPat id +mkPrefixConPat :: DataCon -> [OutPat id] -> [Type] -> OutPat id -- Make a vanilla Prefix constructor pattern -mkPrefixConPat dc pats ty +mkPrefixConPat dc pats tys = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc), pat_tvs = [], pat_dicts = [], pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats, - pat_ty = ty, pat_wrap = idHsWrapper } + pat_arg_tys = tys, pat_wrap = idHsWrapper } mkNilPat :: Type -> OutPat id -mkNilPat ty = mkPrefixConPat nilDataCon [] ty +mkNilPat ty = mkPrefixConPat nilDataCon [] [ty] mkCharLitPat :: Char -> OutPat id -mkCharLitPat c = mkPrefixConPat charDataCon [noLoc $ LitPat (HsCharPrim c)] charTy +mkCharLitPat c = mkPrefixConPat charDataCon [noLoc $ LitPat (HsCharPrim c)] [] \end{code} diff --git a/compiler/hsSyn/HsSyn.lhs b/compiler/hsSyn/HsSyn.lhs index e9c3a5eeee..72cbac1487 100644 --- a/compiler/hsSyn/HsSyn.lhs +++ b/compiler/hsSyn/HsSyn.lhs @@ -23,7 +23,7 @@ module HsSyn ( module HsDoc, Fixity, - HsModule(..), HsExtCore(..), + HsModule(..) ) where -- friends: @@ -40,10 +40,9 @@ import HsDoc -- others: import OccName ( HasOccName ) -import IfaceSyn ( IfaceBinding ) import Outputable import SrcLoc -import Module ( Module, ModuleName ) +import Module ( ModuleName ) import FastString -- libraries: @@ -77,13 +76,6 @@ data HsModule name hsmodHaddockModHeader :: Maybe LHsDocString -- ^ Haddock module info and description, unparsed } deriving (Data, Typeable) - -data HsExtCore name -- Read from Foo.hcr - = HsExtCore - Module - [TyClDecl name] -- Type declarations only; just as in Haskell source, - -- so that we can infer kinds etc - [IfaceBinding] -- And the bindings \end{code} diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 28c6a2b89c..0cf8455bad 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -25,7 +25,7 @@ module HsTypes ( ConDeclField(..), pprConDeclFields, - mkHsQTvs, hsQTvBndrs, + mkHsQTvs, hsQTvBndrs, isHsKindedTyVar, hsTvbAllKinded, mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs, hsTyVarName, mkHsWithBndrs, hsLKiTyVarNames, hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, @@ -35,7 +35,7 @@ module HsTypes ( splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy, -- Printing - pprParendHsType, pprHsForAll, pprHsContext, pprHsContextNoArrow, ppr_hs_context, + pprParendHsType, pprHsForAll, pprHsContext, pprHsContextNoArrow, ) where import {-# SOURCE #-} HsExpr ( HsSplice, pprUntypedSplice ) @@ -45,6 +45,7 @@ import HsLit import Name( Name ) import RdrName( RdrName ) import DataCon( HsBang(..) ) +import TysPrim( funTyConName ) import Type import HsDoc import BasicTypes @@ -162,7 +163,7 @@ mkHsWithBndrs x = HsWB { hswb_cts = x, hswb_kvs = panic "mkHsTyWithBndrs:kvs" , hswb_tvs = panic "mkHsTyWithBndrs:tvs" } --- | These names are used eary on to store the names of implicit +-- | These names are used early on to store the names of implicit -- parameters. They completely disappear after type-checking. newtype HsIPName = HsIPName FastString-- ?x deriving( Eq, Data, Typeable ) @@ -187,6 +188,15 @@ data HsTyVarBndr name (LHsKind name) -- The user-supplied kind signature deriving (Data, Typeable) +-- | Does this 'HsTyVarBndr' come with an explicit kind annotation? +isHsKindedTyVar :: HsTyVarBndr name -> Bool +isHsKindedTyVar (UserTyVar {}) = False +isHsKindedTyVar (KindedTyVar {}) = True + +-- | Do all type variables in this 'LHsTyVarBndr' come with kind annotations? +hsTvbAllKinded :: LHsTyVarBndrs name -> Bool +hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvBndrs + data HsType name = HsForAllTy HsExplicitFlag -- Renamer leaves this flag unchanged, to record the way -- the user wrote it originally, so that the printer can @@ -506,15 +516,31 @@ splitLHsClassTy_maybe ty HsKindSig ty _ -> checkl ty args _ -> Nothing --- Splits HsType into the (init, last) parts +-- splitHsFunType decomposes a type (t1 -> t2 ... -> tn) -- Breaks up any parens in the result type: -- splitHsFunType (a -> (b -> c)) = ([a,b], c) -splitHsFunType :: LHsType name -> ([LHsType name], LHsType name) -splitHsFunType (L _ (HsFunTy x y)) = (x:args, res) - where - (args, res) = splitHsFunType y -splitHsFunType (L _ (HsParTy ty)) = splitHsFunType ty -splitHsFunType other = ([], other) +-- Also deals with (->) t1 t2; that is why it only works on LHsType Name +-- (see Trac #9096) +splitHsFunType :: LHsType Name -> ([LHsType Name], LHsType Name) +splitHsFunType (L _ (HsParTy ty)) + = splitHsFunType ty + +splitHsFunType (L _ (HsFunTy x y)) + | (args, res) <- splitHsFunType y + = (x:args, res) + +splitHsFunType orig_ty@(L _ (HsAppTy t1 t2)) + = go t1 [t2] + where -- Look for (->) t1 t2, possibly with parenthesisation + go (L _ (HsTyVar fn)) tys | fn == funTyConName + , [t1,t2] <- tys + , (args, res) <- splitHsFunType t2 + = (t1:args, res) + go (L _ (HsAppTy t1 t2)) tys = go t1 (t2:tys) + go (L _ (HsParTy ty)) tys = go ty tys + go _ _ = ([], orig_ty) -- Failure to match + +splitHsFunType other = ([], other) \end{code} @@ -550,7 +576,7 @@ pprHsForAll exp qtvs cxt show_forall = opt_PprStyle_Debug || (not (null (hsQTvBndrs qtvs)) && is_explicit) is_explicit = case exp of {Explicit -> True; Implicit -> False} - forall_part = ptext (sLit "forall") <+> ppr qtvs <> dot + forall_part = forAllLit <+> ppr qtvs <> dot pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc pprHsContext [] = empty @@ -558,12 +584,8 @@ pprHsContext cxt = pprHsContextNoArrow cxt <+> darrow pprHsContextNoArrow :: (OutputableBndr name) => HsContext name -> SDoc pprHsContextNoArrow [] = empty -pprHsContextNoArrow [L _ pred] = ppr pred -pprHsContextNoArrow cxt = ppr_hs_context cxt - -ppr_hs_context :: (OutputableBndr name) => HsContext name -> SDoc -ppr_hs_context [] = empty -ppr_hs_context cxt = parens (interpp'SP cxt) +pprHsContextNoArrow [L _ pred] = ppr_mono_ty FunPrec pred +pprHsContextNoArrow cxt = parens (interpp'SP cxt) pprConDeclFields :: OutputableBndr name => [ConDeclField name] -> SDoc pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) @@ -585,27 +607,12 @@ and the problem doesn't show up; but having the flag on a KindedTyVar seems like the Right Thing anyway.) \begin{code} -pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int -pREC_TOP = 0 -- type in ParseIface.y -pREC_FUN = 1 -- btype in ParseIface.y - -- Used for LH arg of (->) -pREC_OP = 2 -- Used for arg of any infix operator - -- (we don't keep their fixities around) -pREC_CON = 3 -- Used for arg of type applicn: - -- always parenthesise unless atomic - -maybeParen :: Int -- Precedence of context - -> Int -- Precedence of top-level operator - -> SDoc -> SDoc -- Wrap in parens if (ctxt >= op) -maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p - | otherwise = p - --- printing works more-or-less as for Types +-- Printing works more-or-less as for Types pprHsType, pprParendHsType :: (OutputableBndr name) => HsType name -> SDoc -pprHsType ty = getPprStyle $ \sty -> ppr_mono_ty pREC_TOP (prepare sty ty) -pprParendHsType ty = ppr_mono_ty pREC_CON ty +pprHsType ty = getPprStyle $ \sty -> ppr_mono_ty TopPrec (prepare sty ty) +pprParendHsType ty = ppr_mono_ty TyConPrec ty -- Before printing a type -- (a) Remove outermost HsParTy parens @@ -615,15 +622,15 @@ prepare :: PprStyle -> HsType name -> HsType name prepare sty (HsParTy ty) = prepare sty (unLoc ty) prepare _ ty = ty -ppr_mono_lty :: (OutputableBndr name) => Int -> LHsType name -> SDoc +ppr_mono_lty :: (OutputableBndr name) => TyPrec -> LHsType name -> SDoc ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) -ppr_mono_ty :: (OutputableBndr name) => Int -> HsType name -> SDoc +ppr_mono_ty :: (OutputableBndr name) => TyPrec -> HsType name -> SDoc ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty) - = maybeParen ctxt_prec pREC_FUN $ - sep [pprHsForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty] + = maybeParen ctxt_prec FunPrec $ + sep [pprHsForAll exp tvs ctxt, ppr_mono_lty TopPrec ty] -ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr_mono_lty pREC_CON ty +ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr_mono_lty TyConPrec ty ppr_mono_ty _ (HsQuasiQuoteTy qq) = ppr qq ppr_mono_ty _ (HsRecTy flds) = pprConDeclFields flds ppr_mono_ty _ (HsTyVar name) = pprPrefixOcc name @@ -632,10 +639,10 @@ ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys) where std_con = case con of HsUnboxedTuple -> UnboxedTuple _ -> BoxedTuple -ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> ppr kind) -ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty) -ppr_mono_ty _ (HsPArrTy ty) = paBrackets (ppr_mono_lty pREC_TOP ty) -ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec pREC_FUN (ppr n <+> dcolon <+> ppr_mono_lty pREC_TOP ty) +ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty TopPrec ty <+> dcolon <+> ppr kind) +ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty TopPrec ty) +ppr_mono_ty _ (HsPArrTy ty) = paBrackets (ppr_mono_lty TopPrec ty) +ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec FunPrec (ppr n <+> dcolon <+> ppr_mono_lty TopPrec ty) ppr_mono_ty _ (HsSpliceTy s _) = pprUntypedSplice s ppr_mono_ty _ (HsCoreTy ty) = ppr ty ppr_mono_ty _ (HsExplicitListTy _ tys) = quote $ brackets (interpp'SP tys) @@ -651,45 +658,45 @@ ppr_mono_ty ctxt_prec (HsWrapTy (WpKiApps _kis) ty) where go ctxt_prec [] ty = ppr_mono_ty ctxt_prec ty go ctxt_prec (ki:kis) ty - = maybeParen ctxt_prec pREC_CON $ - hsep [ go pREC_FUN kis ty + = maybeParen ctxt_prec TyConPrec $ + hsep [ go FunPrec kis ty , ptext (sLit "@") <> pprParendKind ki ] -} ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) - = maybeParen ctxt_prec pREC_OP $ - ppr_mono_lty pREC_OP ty1 <+> char '~' <+> ppr_mono_lty pREC_OP ty2 + = maybeParen ctxt_prec TyOpPrec $ + ppr_mono_lty TyOpPrec ty1 <+> char '~' <+> ppr_mono_lty TyOpPrec ty2 ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) - = maybeParen ctxt_prec pREC_CON $ - hsep [ppr_mono_lty pREC_FUN fun_ty, ppr_mono_lty pREC_CON arg_ty] + = maybeParen ctxt_prec TyConPrec $ + hsep [ppr_mono_lty FunPrec fun_ty, ppr_mono_lty TyConPrec arg_ty] ppr_mono_ty ctxt_prec (HsOpTy ty1 (_wrapper, L _ op) ty2) - = maybeParen ctxt_prec pREC_OP $ - sep [ ppr_mono_lty pREC_OP ty1 - , sep [pprInfixOcc op, ppr_mono_lty pREC_OP ty2 ] ] + = maybeParen ctxt_prec TyOpPrec $ + sep [ ppr_mono_lty TyOpPrec ty1 + , sep [pprInfixOcc op, ppr_mono_lty TyOpPrec ty2 ] ] -- Don't print the wrapper (= kind applications) -- c.f. HsWrapTy ppr_mono_ty _ (HsParTy ty) - = parens (ppr_mono_lty pREC_TOP ty) + = parens (ppr_mono_lty TopPrec ty) -- Put the parens in where the user did -- But we still use the precedence stuff to add parens because -- toHsType doesn't put in any HsParTys, so we may still need them ppr_mono_ty ctxt_prec (HsDocTy ty doc) - = maybeParen ctxt_prec pREC_OP $ - ppr_mono_lty pREC_OP ty <+> ppr (unLoc doc) + = maybeParen ctxt_prec TyOpPrec $ + ppr_mono_lty TyOpPrec ty <+> ppr (unLoc doc) -- we pretty print Haddock comments on types as if they were -- postfix operators -------------------------- -ppr_fun_ty :: (OutputableBndr name) => Int -> LHsType name -> LHsType name -> SDoc +ppr_fun_ty :: (OutputableBndr name) => TyPrec -> LHsType name -> LHsType name -> SDoc ppr_fun_ty ctxt_prec ty1 ty2 - = let p1 = ppr_mono_lty pREC_FUN ty1 - p2 = ppr_mono_lty pREC_TOP ty2 + = let p1 = ppr_mono_lty FunPrec ty1 + p2 = ppr_mono_lty TopPrec ty2 in - maybeParen ctxt_prec pREC_FUN $ + maybeParen ctxt_prec FunPrec $ sep [p1, ptext (sLit "->") <+> p2] -------------------------- diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 558c104fad..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 ---------------- ------------- @@ -13,7 +15,8 @@ which deal with the intantiated versions are located elsewhere: Id typecheck/TcHsSyn \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -99,7 +102,10 @@ import FastString import Util import Bag import Outputable + import Data.Either +import Data.Function +import Data.List \end{code} @@ -132,8 +138,8 @@ unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds unguardedRHS :: Located (body id) -> [LGRHS id (Located (body id))] unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)] -mkMatchGroup :: [LMatch id (Located (body id))] -> MatchGroup id (Located (body id)) -mkMatchGroup matches = MG { mg_alts = matches, mg_arg_tys = [], mg_res_ty = placeHolderType } +mkMatchGroup :: Origin -> [LMatch id (Located (body id))] -> MatchGroup id (Located (body id)) +mkMatchGroup origin matches = MG { mg_alts = matches, mg_arg_tys = [], mg_res_ty = placeHolderType, mg_origin = origin } mkHsAppTy :: LHsType name -> LHsType name -> LHsType name mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2) @@ -144,7 +150,7 @@ mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2) mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) where - matches = mkMatchGroup [mkSimpleMatch pats body] + matches = mkMatchGroup Generated [mkSimpleMatch pats body] mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars <.> mkWpLams dicts) expr @@ -351,11 +357,11 @@ nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id nlHsCase :: LHsExpr id -> [LMatch id (LHsExpr id)] -> LHsExpr id nlList :: [LHsExpr id] -> LHsExpr id -nlHsLam match = noLoc (HsLam (mkMatchGroup [match])) -nlHsPar e = noLoc (HsPar e) -nlHsIf cond true false = noLoc (mkHsIf cond true false) -nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup matches)) -nlList exprs = noLoc (ExplicitList placeHolderType Nothing exprs) +nlHsLam match = noLoc (HsLam (mkMatchGroup Generated [match])) +nlHsPar e = noLoc (HsPar e) +nlHsIf cond true false = noLoc (mkHsIf cond true false) +nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup Generated matches)) +nlList exprs = noLoc (ExplicitList placeHolderType Nothing exprs) nlHsAppTy :: LHsType name -> LHsType name -> LHsType name nlHsTyVar :: name -> LHsType name @@ -382,7 +388,7 @@ mkLHsVarTuple :: [a] -> LHsExpr a mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids) nlTuplePat :: [LPat id] -> Boxity -> LPat id -nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType) +nlTuplePat pats box = noLoc (TuplePat pats box []) missingTupArg :: HsTupArg a missingTupArg = Missing placeHolderType @@ -478,20 +484,20 @@ l mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> HsBind RdrName -- Not infix, with place holders for coercion and free vars mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False - , fun_matches = mkMatchGroup ms - , fun_co_fn = idHsWrapper + , fun_matches = mkMatchGroup Generated ms + , fun_co_fn = idHsWrapper , bind_fvs = placeHolderNames - , fun_tick = Nothing } + , fun_tick = Nothing } -mkTopFunBind :: Located Name -> [LMatch Name (LHsExpr Name)] -> HsBind Name +mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)] -> HsBind Name -- In Name-land, with empty bind_fvs -mkTopFunBind fn ms = FunBind { fun_id = fn, fun_infix = False - , fun_matches = mkMatchGroup ms - , fun_co_fn = idHsWrapper - , bind_fvs = emptyNameSet -- NB: closed binding - , fun_tick = Nothing } +mkTopFunBind origin fn ms = FunBind { fun_id = fn, fun_infix = False + , fun_matches = mkMatchGroup origin ms + , fun_co_fn = idHsWrapper + , bind_fvs = emptyNameSet -- NB: closed binding + , fun_tick = Nothing } -mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> (Origin, LHsBind RdrName) +mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs mkVarBind :: id -> LHsExpr id -> LHsBind id @@ -499,17 +505,19 @@ 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] - -> LHsExpr RdrName -> (Origin, LHsBind RdrName) + -> LHsExpr RdrName -> LHsBind RdrName mk_easy_FunBind loc fun pats expr - = (Generated, L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]) + = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds] ------------ mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id (LHsExpr id) @@ -571,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 [] @@ -580,11 +588,11 @@ collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL] collectHsBindListBinders = foldr (collect_bind . unLoc) [] collect_binds :: LHsBindsLR idL idR -> [idL] -> [idL] -collect_binds binds acc = foldrBag (collect_bind . unLoc . snd) acc binds +collect_binds binds acc = foldrBag (collect_bind . unLoc) acc binds collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName] -- Used exclusively for the bindings of an instance decl which are all FunBinds -collectMethodBinders binds = foldrBag (get . unLoc . snd) [] binds +collectMethodBinders binds = foldrBag (get . unLoc) [] binds where get (FunBind { fun_id = f }) fs = f : fs get _ fs = fs @@ -742,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] @@ -808,7 +818,7 @@ hsValBindsImplicits (ValBindsIn binds _) = lhsBindsImplicits binds lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet -lhsBindsImplicits = foldBag unionNameSets (lhs_bind . unLoc . snd) emptyNameSet +lhsBindsImplicits = foldBag unionNameSets (lhs_bind . unLoc) emptyNameSet where lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat lhs_bind _ = emptyNameSet diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 9fd0c33423..4ec9ec7cbb 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- -- (c) The University of Glasgow 2002-2006 -- @@ -258,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) = @@ -275,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 e412d7ef30..46091adf80 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -4,7 +4,8 @@ % \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -15,7 +16,7 @@ module BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, - buildPatSyn, mkPatSynMatcherId, mkPatSynWrapperId, + buildPatSyn, TcMethInfo, buildClass, distinctAbstractTyConRhs, totallyAbstractTyConRhs, mkNewTyConRhs, mkDataTyConRhs, @@ -36,10 +37,9 @@ import MkId import Class import TyCon import Type -import TypeRep -import TcType import Id import Coercion +import TcType import DynFlags import TcRnMonad @@ -184,67 +184,34 @@ mkDataConStupidTheta tycon arg_tys univ_tvs ------------------------------------------------------ -buildPatSyn :: Name -> Bool -> Bool - -> [Var] +buildPatSyn :: Name -> Bool + -> Id -> Maybe Id + -> [Type] -> [TyVar] -> [TyVar] -- Univ and ext -> ThetaType -> ThetaType -- Prov and req -> Type -- Result type - -> TyVar - -> TcRnIf m n PatSyn -buildPatSyn src_name declared_infix has_wrapper args univ_tvs ex_tvs prov_theta req_theta pat_ty tv - = do { (matcher, _, _) <- mkPatSynMatcherId src_name args - univ_tvs ex_tvs - prov_theta req_theta - pat_ty tv - ; wrapper <- case has_wrapper of - False -> return Nothing - True -> fmap Just $ - mkPatSynWrapperId src_name args - (univ_tvs ++ ex_tvs) (prov_theta ++ req_theta) - pat_ty - ; return $ mkPatSyn src_name declared_infix - args - univ_tvs ex_tvs - prov_theta req_theta - pat_ty - matcher - wrapper } - -mkPatSynMatcherId :: Name - -> [Var] - -> [TyVar] - -> [TyVar] - -> ThetaType -> ThetaType - -> Type - -> TyVar - -> TcRnIf n m (Id, Type, Type) -mkPatSynMatcherId name args univ_tvs ex_tvs prov_theta req_theta pat_ty res_tv - = do { matcher_name <- newImplicitBinder name mkMatcherOcc - - ; let res_ty = TyVarTy res_tv - cont_ty = mkSigmaTy ex_tvs prov_theta $ - mkFunTys (map varType args) res_ty - - ; let matcher_tau = mkFunTys [pat_ty, cont_ty, res_ty] res_ty - matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau - matcher_id = mkVanillaGlobal matcher_name matcher_sigma - ; return (matcher_id, res_ty, cont_ty) } - -mkPatSynWrapperId :: Name - -> [Var] - -> [TyVar] - -> ThetaType - -> Type - -> TcRnIf n m Id -mkPatSynWrapperId name args qtvs theta pat_ty - = do { wrapper_name <- newImplicitBinder name mkDataConWrapperOcc - - ; let wrapper_tau = mkFunTys (map varType args) pat_ty - wrapper_sigma = mkSigmaTy qtvs theta wrapper_tau - - ; let wrapper_id = mkVanillaGlobal wrapper_name wrapper_sigma - ; return wrapper_id } - + -> PatSyn +buildPatSyn src_name declared_infix matcher wrapper + args univ_tvs ex_tvs prov_theta req_theta pat_ty + = ASSERT((and [ univ_tvs == univ_tvs' + , ex_tvs == ex_tvs' + , pat_ty `eqType` pat_ty' + , prov_theta `eqTypes` prov_theta' + , req_theta `eqTypes` req_theta' + , args `eqTypes` args' + ])) + mkPatSyn src_name declared_infix + args + univ_tvs ex_tvs + prov_theta req_theta + pat_ty + matcher + wrapper + where + ((_:univ_tvs'), req_theta', tau) = tcSplitSigmaTy $ idType matcher + ([pat_ty', cont_sigma, _], _) = tcSplitFunTys tau + (ex_tvs', prov_theta', cont_tau) = tcSplitSigmaTy cont_sigma + (args', _) = tcSplitFunTys cont_tau \end{code} @@ -254,10 +221,7 @@ type TcMethInfo = (Name, DefMethSpec, Type) -- A temporary intermediate, to communicate between -- tcClassSigs and buildClass. -buildClass :: Bool -- True <=> do not include unfoldings - -- on dict selectors - -- Used when importing a class without -O - -> Name -> [TyVar] -> [Role] -> ThetaType +buildClass :: Name -> [TyVar] -> [Role] -> ThetaType -> [FunDep TyVar] -- Functional dependencies -> [ClassATItem] -- Associated types -> [TcMethInfo] -- Method info @@ -265,10 +229,9 @@ buildClass :: Bool -- True <=> do not include unfoldings -> RecFlag -- Info for type constructor -> TcRnIf m n Class -buildClass no_unf tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec +buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec = fixM $ \ rec_clas -> -- Only name generation inside loop do { traceIf (text "buildClass") - ; dflags <- getDynFlags ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc -- The class name is the 'parent' for this datacon, not its tycon, @@ -282,7 +245,7 @@ buildClass no_unf tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc -- Make selectors for the superclasses ; sc_sel_names <- mapM (newImplicitBinder tycon_name . mkSuperDictSelOcc) [1..length sc_theta] - ; let sc_sel_ids = [ mkDictSelId dflags no_unf sc_name rec_clas + ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas | sc_name <- sc_sel_names] -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we -- can construct names for the selectors. Thus @@ -348,14 +311,13 @@ buildClass no_unf tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc where mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem mk_op_item rec_clas (op_name, dm_spec, _) - = do { dflags <- getDynFlags - ; dm_info <- case dm_spec of + = do { dm_info <- case dm_spec of NoDM -> return NoDefMeth GenericDM -> do { dm_name <- newImplicitBinder op_name mkGenDefMethodOcc ; return (GenDefMeth dm_name) } VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc ; return (DefMeth dm_name) } - ; return (mkDictSelId dflags no_unf op_name rec_clas, dm_info) } + ; return (mkDictSelId op_name rec_clas, dm_info) } \end{code} Note [Class newtypes and equality predicates] @@ -368,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/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs index 42c3e32605..c29778dc23 100644 --- a/compiler/iface/IfaceEnv.lhs +++ b/compiler/iface/IfaceEnv.lhs @@ -1,7 +1,8 @@ (c) The University of Glasgow 2002-2006 \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# LANGUAGE CPP, 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 @@ -28,13 +29,10 @@ module IfaceEnv ( import TcRnMonad import TysWiredIn import HscTypes -import TyCon import Type -import DataCon import Var import Name import Avail -import PrelNames import Module import UniqFM import FastString @@ -183,23 +181,34 @@ lookupOrig mod occ See Note [The Name Cache] above. +Note [Built-in syntax and the OrigNameCache] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might think that usin isBuiltInOcc_maybe in lookupOrigNameCache is +unnecessary because tuple TyCon/DataCons are parsed as Exact RdrNames +and *don't* appear as original names in interface files (because +serialization gives them special treatment), so we will never look +them up in the original name cache. + +However, there are two reasons why we might look up an Orig RdrName: + + * If you use setRdrNameSpace on an Exact RdrName it may be + turned into an Orig RdrName. + + * Template Haskell turns a BuiltInSyntax Name into a TH.NameG + (DsMeta.globalVar), and parses a NameG into an Orig RdrName + (Convert.thRdrName). So, eg $(do { reify '(,); ... }) will + go this route (Trac #8954). + \begin{code} lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name -lookupOrigNameCache _ mod occ - -- Don't need to mention gHC_UNIT here because it is explicitly - -- included in TysWiredIn.wiredInTyCons - | mod == gHC_TUPLE || mod == gHC_PRIM, -- Boxed tuples from one, - Just tup_info <- isTupleOcc_maybe occ -- unboxed from the other - = -- Special case for tuples; there are too many +lookupOrigNameCache nc mod occ + | Just name <- isBuiltInOcc_maybe occ + = -- See Note [Known-key names], 3(c) in PrelNames + -- Special case for tuples; there are too many -- of them to pre-populate the original-name cache - Just (mk_tup_name tup_info) - where - mk_tup_name (ns, sort, arity) - | ns == tcName = tyConName (tupleTyCon sort arity) - | ns == dataName = dataConName (tupleCon sort arity) - | otherwise = Var.varName (dataConWorkId (tupleCon sort arity)) + Just name -lookupOrigNameCache nc mod occ -- The normal case + | otherwise = case lookupModuleEnv nc mod of Nothing -> Nothing Just occ_env -> lookupOccEnv occ_env occ diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 1283b095fd..935b8eda93 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -4,7 +4,8 @@ % \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -15,13 +16,14 @@ module IfaceSyn ( module IfaceType, IfaceDecl(..), IfaceSynTyConRhs(..), IfaceClassOp(..), IfaceAT(..), - IfaceConDecl(..), IfaceConDecls(..), + IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec, IfaceExpr(..), IfaceAlt, IfaceLetBndr(..), IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), IfaceBang(..), IfaceAxBranch(..), + IfaceTyConParent(..), -- Misc ifaceDeclImplicitBndrs, visibleIfConDecls, @@ -31,7 +33,9 @@ module IfaceSyn ( freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst, -- Pretty printing - pprIfaceExpr + pprIfaceExpr, + pprIfaceDecl, + ShowSub(..), ShowHowMuch(..) ) where #include "HsVersions.h" @@ -51,14 +55,17 @@ import BasicTypes import Outputable import FastString import Module -import TysWiredIn ( eqTyConName ) import Fingerprint import Binary import BooleanFormula ( BooleanFormula ) import HsBinds +import TyCon (Role (..)) +import StaticFlags (opt_PprStyle_Debug) +import Util( filterOut ) import Control.Monad import System.IO.Unsafe +import Data.Maybe (isJust) infixl 3 &&& \end{code} @@ -66,18 +73,27 @@ infixl 3 &&& %************************************************************************ %* * - Data type declarations + Declarations %* * %************************************************************************ \begin{code} +type IfaceTopBndr = OccName + -- It's convenient to have an OccName in the IfaceSyn, altough in each + -- case the namespace is implied by the context. However, having an + -- OccNames makes things like ifaceDeclImplicitBndrs and ifaceDeclFingerprints + -- very convenient. + -- + -- We don't serialise the namespace onto the disk though; rather we + -- drop it when serialising and add it back in when deserialising. + data IfaceDecl - = IfaceId { ifName :: OccName, + = IfaceId { ifName :: IfaceTopBndr, ifType :: IfaceType, ifIdDetails :: IfaceIdDetails, ifIdInfo :: IfaceIdInfo } - | IfaceData { ifName :: OccName, -- Type constructor + | IfaceData { ifName :: IfaceTopBndr, -- Type constructor ifCType :: Maybe CType, -- C type for CAPI FFI ifTyVars :: [IfaceTvBndr], -- Type variables ifRoles :: [Role], -- Roles @@ -87,355 +103,115 @@ data IfaceDecl ifPromotable :: Bool, -- Promotable to kind level? ifGadtSyntax :: Bool, -- True <=> declared using -- GADT syntax - ifAxiom :: Maybe IfExtName -- The axiom, for a newtype, - -- or data/newtype family instance + ifParent :: IfaceTyConParent -- The axiom, for a newtype, + -- or data/newtype family instance } - | IfaceSyn { ifName :: OccName, -- Type constructor + | IfaceSyn { ifName :: IfaceTopBndr, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables ifRoles :: [Role], -- Roles ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon) ifSynRhs :: IfaceSynTyConRhs } - | IfaceClass { ifCtxt :: IfaceContext, -- Context... - ifName :: OccName, -- Name of the class TyCon - ifTyVars :: [IfaceTvBndr], -- Type variables - ifRoles :: [Role], -- Roles - ifFDs :: [FunDep FastString], -- Functional dependencies - ifATs :: [IfaceAT], -- Associated type families - ifSigs :: [IfaceClassOp], -- Method signatures - ifMinDef :: BooleanFormula OccName, -- Minimal complete definition - ifRec :: RecFlag -- Is newtype/datatype associated - -- with the class recursive? + | IfaceClass { ifCtxt :: IfaceContext, -- Context... + ifName :: IfaceTopBndr, -- Name of the class TyCon + ifTyVars :: [IfaceTvBndr], -- Type variables + ifRoles :: [Role], -- Roles + ifFDs :: [FunDep FastString], -- Functional dependencies + ifATs :: [IfaceAT], -- Associated type families + ifSigs :: [IfaceClassOp], -- Method signatures + ifMinDef :: BooleanFormula IfLclName, -- Minimal complete definition + ifRec :: RecFlag -- Is newtype/datatype associated + -- with the class recursive? } - | IfaceAxiom { ifName :: OccName, -- Axiom name + | IfaceAxiom { ifName :: IfaceTopBndr, -- Axiom name ifTyCon :: IfaceTyCon, -- LHS TyCon ifRole :: Role, -- Role of axiom ifAxBranches :: [IfaceAxBranch] -- Branches } - | IfaceForeign { ifName :: OccName, -- Needs expanding when we move + | IfaceForeign { ifName :: IfaceTopBndr, -- Needs expanding when we move -- beyond .NET ifExtName :: Maybe FastString } - | IfacePatSyn { ifName :: OccName, -- Name of the pattern synonym - ifPatHasWrapper :: Bool, + | IfacePatSyn { ifName :: IfaceTopBndr, -- Name of the pattern synonym ifPatIsInfix :: Bool, + ifPatMatcher :: IfExtName, + ifPatWrapper :: Maybe IfExtName, + -- Everything below is redundant, + -- but needed to implement pprIfaceDecl ifPatUnivTvs :: [IfaceTvBndr], ifPatExTvs :: [IfaceTvBndr], ifPatProvCtxt :: IfaceContext, ifPatReqCtxt :: IfaceContext, - ifPatArgs :: [IfaceIdBndr], + ifPatArgs :: [IfaceType], ifPatTy :: IfaceType } --- A bit of magic going on here: there's no need to store the OccName --- for a decl on the disk, since we can infer the namespace from the --- context; however it is useful to have the OccName in the IfaceDecl --- to avoid re-building it in various places. So we build the OccName --- when de-serialising. - -instance Binary IfaceDecl where - put_ bh (IfaceId name ty details idinfo) = do - putByte bh 0 - put_ bh (occNameFS name) - put_ bh ty - put_ bh details - put_ bh idinfo - - put_ _ (IfaceForeign _ _) = - error "Binary.put_(IfaceDecl): IfaceForeign" - - put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do - putByte bh 2 - put_ bh (occNameFS a1) - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - put_ bh a9 - put_ bh a10 - - put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do - putByte bh 3 - put_ bh (occNameFS a1) - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - - put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8 a9) = do - putByte bh 4 - put_ bh a1 - put_ bh (occNameFS a2) - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - put_ bh a9 - - put_ bh (IfaceAxiom a1 a2 a3 a4) = do - putByte bh 5 - put_ bh (occNameFS a1) - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh (IfacePatSyn name a2 a3 a4 a5 a6 a7 a8 a9) = do - putByte bh 6 - put_ bh (occNameFS name) - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - put_ bh a9 - - get bh = do - h <- getByte bh - case h of - 0 -> do name <- get bh - ty <- get bh - details <- get bh - idinfo <- get bh - occ <- return $! mkOccNameFS varName name - return (IfaceId occ ty details idinfo) - 1 -> error "Binary.get(TyClDecl): ForeignType" - 2 -> do a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - a9 <- get bh - a10 <- get bh - occ <- return $! mkOccNameFS tcName a1 - return (IfaceData occ a2 a3 a4 a5 a6 a7 a8 a9 a10) - 3 -> do a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - occ <- return $! mkOccNameFS tcName a1 - return (IfaceSyn occ a2 a3 a4 a5) - 4 -> do a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - a9 <- get bh - occ <- return $! mkOccNameFS clsName a2 - return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8 a9) - 5 -> do a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - occ <- return $! mkOccNameFS tcName a1 - return (IfaceAxiom occ a2 a3 a4) - 6 -> do a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - a9 <- get bh - occ <- return $! mkOccNameFS dataName a1 - return (IfacePatSyn occ a2 a3 a4 a5 a6 a7 a8 a9) - _ -> panic (unwords ["Unknown IfaceDecl tag:", show h]) +data IfaceTyConParent + = IfNoParent + | IfDataInstance IfExtName + IfaceTyCon + IfaceTcArgs data IfaceSynTyConRhs = IfaceOpenSynFamilyTyCon - | IfaceClosedSynFamilyTyCon IfExtName -- name of associated axiom + | IfaceClosedSynFamilyTyCon IfExtName -- name of associated axiom + [IfaceAxBranch] -- for pretty printing purposes only | IfaceAbstractClosedSynFamilyTyCon | IfaceSynonymTyCon IfaceType + | IfaceBuiltInSynFamTyCon -- for pretty printing purposes only -instance Binary IfaceSynTyConRhs where - put_ bh IfaceOpenSynFamilyTyCon = putByte bh 0 - put_ bh (IfaceClosedSynFamilyTyCon ax) = putByte bh 1 >> put_ bh ax - put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 2 - put_ bh (IfaceSynonymTyCon ty) = putByte bh 3 >> put_ bh ty - - get bh = do { h <- getByte bh - ; case h of - 0 -> return IfaceOpenSynFamilyTyCon - 1 -> do { ax <- get bh - ; return (IfaceClosedSynFamilyTyCon ax) } - 2 -> return IfaceAbstractClosedSynFamilyTyCon - _ -> do { ty <- get bh - ; return (IfaceSynonymTyCon ty) } } - -data IfaceClassOp = IfaceClassOp OccName DefMethSpec IfaceType +data IfaceClassOp = IfaceClassOp IfaceTopBndr DefMethSpec IfaceType -- Nothing => no default method -- Just False => ordinary polymorphic default method -- Just True => generic default method -instance Binary IfaceClassOp where - put_ bh (IfaceClassOp n def ty) = do - put_ bh (occNameFS n) - put_ bh def - put_ bh ty - get bh = do - n <- get bh - def <- get bh - ty <- get bh - occ <- return $! mkOccNameFS varName n - return (IfaceClassOp occ def ty) +data IfaceAT = IfaceAT -- See Class.ClassATItem + IfaceDecl -- The associated type declaration + (Maybe IfaceType) -- Default associated type instance, if any -data IfaceAT = IfaceAT - IfaceDecl -- The associated type declaration - [IfaceAxBranch] -- Default associated type instances, if any -instance Binary IfaceAT where - put_ bh (IfaceAT dec defs) = do - put_ bh dec - put_ bh defs - get bh = do - dec <- get bh - defs <- get bh - return (IfaceAT dec defs) - -instance Outputable IfaceAxBranch where - ppr = pprAxBranch Nothing - -pprAxBranch :: Maybe IfaceTyCon -> IfaceAxBranch -> SDoc -pprAxBranch mtycon (IfaceAxBranch { ifaxbTyVars = tvs - , ifaxbLHS = pat_tys - , ifaxbRHS = ty - , ifaxbIncomps = incomps }) - = ppr tvs <+> ppr_lhs <+> char '=' <+> ppr ty $+$ - nest 2 maybe_incomps - where - ppr_lhs - | Just tycon <- mtycon - = ppr (IfaceTyConApp tycon pat_tys) - | otherwise - = hsep (map ppr pat_tys) - - maybe_incomps - | [] <- incomps - = empty - - | otherwise - = parens (ptext (sLit "incompatible indices:") <+> ppr incomps) - --- this is just like CoAxBranch +-- This is just like CoAxBranch data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] - , ifaxbLHS :: [IfaceType] + , ifaxbLHS :: IfaceTcArgs , ifaxbRoles :: [Role] , ifaxbRHS :: IfaceType , ifaxbIncomps :: [BranchIndex] } -- See Note [Storing compatibility] in CoAxiom -instance Binary IfaceAxBranch where - put_ bh (IfaceAxBranch a1 a2 a3 a4 a5) = do - put_ bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - get bh = do - a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - return (IfaceAxBranch a1 a2 a3 a4 a5) - data IfaceConDecls = IfAbstractTyCon Bool -- c.f TyCon.AbstractTyCon | IfDataFamTyCon -- Data family | IfDataTyCon [IfaceConDecl] -- Data type decls | IfNewTyCon IfaceConDecl -- Newtype decls -instance Binary IfaceConDecls where - put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d - put_ bh IfDataFamTyCon = putByte bh 1 - put_ bh (IfDataTyCon cs) = putByte bh 2 >> put_ bh cs - put_ bh (IfNewTyCon c) = putByte bh 3 >> put_ bh c - get bh = do - h <- getByte bh - case h of - 0 -> liftM IfAbstractTyCon $ get bh - 1 -> return IfDataFamTyCon - 2 -> liftM IfDataTyCon $ get bh - _ -> liftM IfNewTyCon $ get bh - -visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] -visibleIfConDecls (IfAbstractTyCon {}) = [] -visibleIfConDecls IfDataFamTyCon = [] -visibleIfConDecls (IfDataTyCon cs) = cs -visibleIfConDecls (IfNewTyCon c) = [c] - data IfaceConDecl = IfCon { - ifConOcc :: OccName, -- Constructor name + ifConOcc :: IfaceTopBndr, -- Constructor name ifConWrapper :: Bool, -- True <=> has a wrapper ifConInfix :: Bool, -- True <=> declared infix - ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars + + -- The universal type variables are precisely those + -- of the type constructor of this data constructor + -- This is *easy* to guarantee when creating the IfCon + -- but it's not so easy for the original TyCon/DataCon + -- So this guarantee holds for IfaceConDecl, but *not* for DataCon + ifConExTvs :: [IfaceTvBndr], -- Existential tyvars - ifConEqSpec :: [(OccName,IfaceType)], -- Equality constraints + ifConEqSpec :: IfaceEqSpec, -- Equality constraints ifConCtxt :: IfaceContext, -- Non-stupid context ifConArgTys :: [IfaceType], -- Arg types - ifConFields :: [OccName], -- ...ditto... (field labels) + ifConFields :: [IfaceTopBndr], -- ...ditto... (field labels) ifConStricts :: [IfaceBang]} -- Empty (meaning all lazy), -- or 1-1 corresp with arg tys -instance Binary IfaceConDecl where - put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do - put_ bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - put_ bh a9 - put_ bh a10 - get bh = do - a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - a9 <- get bh - a10 <- get bh - return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) +type IfaceEqSpec = [(IfLclName,IfaceType)] data IfaceBang = IfNoBang | IfStrict | IfUnpack | IfUnpackCo IfaceCoercion -instance Binary IfaceBang where - put_ bh IfNoBang = putByte bh 0 - put_ bh IfStrict = putByte bh 1 - put_ bh IfUnpack = putByte bh 2 - put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co - - get bh = do - h <- getByte bh - case h of - 0 -> do return IfNoBang - 1 -> do return IfStrict - 2 -> do return IfUnpack - _ -> do { a <- get bh; return (IfUnpackCo a) } - data IfaceClsInst = IfaceClsInst { ifInstCls :: IfExtName, -- See comments with ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst @@ -449,21 +225,6 @@ data IfaceClsInst -- If this instance decl is *used*, we'll record a usage on the dfun; -- and if the head does not change it won't be used if it wasn't before -instance Binary IfaceClsInst where - put_ bh (IfaceClsInst cls tys dfun flag orph) = do - put_ bh cls - put_ bh tys - put_ bh dfun - put_ bh flag - put_ bh orph - get bh = do - cls <- get bh - tys <- get bh - dfun <- get bh - flag <- get bh - orph <- get bh - return (IfaceClsInst cls tys dfun flag orph) - -- The ifFamInstTys field of IfaceFamInst contains a list of the rough -- match types data IfaceFamInst @@ -473,19 +234,6 @@ data IfaceFamInst , ifFamInstOrph :: Maybe OccName -- Just like IfaceClsInst } -instance Binary IfaceFamInst where - put_ bh (IfaceFamInst fam tys name orph) = do - put_ bh fam - put_ bh tys - put_ bh name - put_ bh orph - get bh = do - fam <- get bh - tys <- get bh - name <- get bh - orph <- get bh - return (IfaceFamInst fam tys name orph) - data IfaceRule = IfaceRule { ifRuleName :: RuleName, @@ -498,82 +246,14 @@ data IfaceRule ifRuleOrph :: Maybe OccName -- Just like IfaceClsInst } -instance Binary IfaceRule where - put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do - put_ bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - get bh = do - a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) - data IfaceAnnotation = IfaceAnnotation { ifAnnotatedTarget :: IfaceAnnTarget, ifAnnotatedValue :: AnnPayload } -instance Outputable IfaceAnnotation where - ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value - -instance Binary IfaceAnnotation where - put_ bh (IfaceAnnotation a1 a2) = do - put_ bh a1 - put_ bh a2 - get bh = do - a1 <- get bh - a2 <- get bh - return (IfaceAnnotation a1 a2) - type IfaceAnnTarget = AnnTarget OccName --- We only serialise the IdDetails of top-level Ids, and even then --- we only need a very limited selection. Notably, none of the --- implicit ones are needed here, because they are not put it --- interface files - -data IfaceIdDetails - = IfVanillaId - | IfRecSelId IfaceTyCon Bool - | IfDFunId Int -- Number of silent args - -instance Binary IfaceIdDetails where - put_ bh IfVanillaId = putByte bh 0 - put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b - put_ bh (IfDFunId n) = do { putByte bh 2; put_ bh n } - get bh = do - h <- getByte bh - case h of - 0 -> return IfVanillaId - 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) } - _ -> do { n <- get bh; return (IfDFunId n) } - -data IfaceIdInfo - = NoInfo -- When writing interface file without -O - | HasInfo [IfaceInfoItem] -- Has info, and here it is - -instance Binary IfaceIdInfo where - put_ bh NoInfo = putByte bh 0 - put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut - - get bh = do - h <- getByte bh - case h of - 0 -> return NoInfo - _ -> liftM HasInfo $ lazyGet bh -- NB lazyGet - -- Here's a tricky case: -- * Compile with -O module A, and B which imports A.f -- * Change function f in A, and recompile without -O @@ -584,6 +264,10 @@ instance Binary IfaceIdInfo where -- * The version comparison sees that new (=NoInfo) differs from old (=HasInfo *) -- and so gives a new version. +data IfaceIdInfo + = NoInfo -- When writing interface file without -O + | HasInfo [IfaceInfoItem] -- Has info, and here it is + data IfaceInfoItem = HsArity Arity | HsStrictness StrictSig @@ -592,23 +276,6 @@ data IfaceInfoItem IfaceUnfolding -- See Note [Expose recursive functions] | HsNoCafRefs -instance Binary IfaceInfoItem where - put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa - put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab - put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad - put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad - put_ bh HsNoCafRefs = putByte bh 4 - get bh = do - h <- getByte bh - case h of - 0 -> liftM HsArity $ get bh - 1 -> liftM HsStrictness $ get bh - 2 -> do lb <- get bh - ad <- get bh - return (HsUnfold lb ad) - 3 -> liftM HsInline $ get bh - _ -> return HsNoCafRefs - -- NB: Specialisations and rules come in separately and are -- only later attached to the Id. Partial reason: some are orphans. @@ -626,253 +293,18 @@ data IfaceUnfolding | IfDFunUnfold [IfaceBndr] [IfaceExpr] -instance Binary IfaceUnfolding where - put_ bh (IfCoreUnfold s e) = do - putByte bh 0 - put_ bh s - put_ bh e - put_ bh (IfInlineRule a b c d) = do - putByte bh 1 - put_ bh a - put_ bh b - put_ bh c - put_ bh d - put_ bh (IfDFunUnfold as bs) = do - putByte bh 2 - put_ bh as - put_ bh bs - put_ bh (IfCompulsory e) = do - putByte bh 3 - put_ bh e - get bh = do - h <- getByte bh - case h of - 0 -> do s <- get bh - e <- get bh - return (IfCoreUnfold s e) - 1 -> do a <- get bh - b <- get bh - c <- get bh - d <- get bh - return (IfInlineRule a b c d) - 2 -> do as <- get bh - bs <- get bh - return (IfDFunUnfold as bs) - _ -> do e <- get bh - return (IfCompulsory e) - --------------------------------- -data IfaceExpr - = IfaceLcl IfLclName - | IfaceExt IfExtName - | IfaceType IfaceType - | IfaceCo IfaceCoercion - | IfaceTuple TupleSort [IfaceExpr] -- Saturated; type arguments omitted - | IfaceLam IfaceBndr IfaceExpr - | IfaceApp IfaceExpr IfaceExpr - | IfaceCase IfaceExpr IfLclName [IfaceAlt] - | IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives] - | IfaceLet IfaceBinding IfaceExpr - | IfaceCast IfaceExpr IfaceCoercion - | IfaceLit Literal - | IfaceFCall ForeignCall IfaceType - | IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E -instance Binary IfaceExpr where - put_ bh (IfaceLcl aa) = do - putByte bh 0 - put_ bh aa - put_ bh (IfaceType ab) = do - putByte bh 1 - put_ bh ab - put_ bh (IfaceCo ab) = do - putByte bh 2 - put_ bh ab - put_ bh (IfaceTuple ac ad) = do - putByte bh 3 - put_ bh ac - put_ bh ad - put_ bh (IfaceLam ae af) = do - putByte bh 4 - put_ bh ae - put_ bh af - put_ bh (IfaceApp ag ah) = do - putByte bh 5 - put_ bh ag - put_ bh ah - put_ bh (IfaceCase ai aj ak) = do - putByte bh 6 - put_ bh ai - put_ bh aj - put_ bh ak - put_ bh (IfaceLet al am) = do - putByte bh 7 - put_ bh al - put_ bh am - put_ bh (IfaceTick an ao) = do - putByte bh 8 - put_ bh an - put_ bh ao - put_ bh (IfaceLit ap) = do - putByte bh 9 - put_ bh ap - put_ bh (IfaceFCall as at) = do - putByte bh 10 - put_ bh as - put_ bh at - put_ bh (IfaceExt aa) = do - putByte bh 11 - put_ bh aa - put_ bh (IfaceCast ie ico) = do - putByte bh 12 - put_ bh ie - put_ bh ico - put_ bh (IfaceECase a b) = do - putByte bh 13 - put_ bh a - put_ bh b - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (IfaceLcl aa) - 1 -> do ab <- get bh - return (IfaceType ab) - 2 -> do ab <- get bh - return (IfaceCo ab) - 3 -> do ac <- get bh - ad <- get bh - return (IfaceTuple ac ad) - 4 -> do ae <- get bh - af <- get bh - return (IfaceLam ae af) - 5 -> do ag <- get bh - ah <- get bh - return (IfaceApp ag ah) - 6 -> do ai <- get bh - aj <- get bh - ak <- get bh - return (IfaceCase ai aj ak) - 7 -> do al <- get bh - am <- get bh - return (IfaceLet al am) - 8 -> do an <- get bh - ao <- get bh - return (IfaceTick an ao) - 9 -> do ap <- get bh - return (IfaceLit ap) - 10 -> do as <- get bh - at <- get bh - return (IfaceFCall as at) - 11 -> do aa <- get bh - return (IfaceExt aa) - 12 -> do ie <- get bh - ico <- get bh - return (IfaceCast ie ico) - 13 -> do a <- get bh - b <- get bh - return (IfaceECase a b) - _ -> panic ("get IfaceExpr " ++ show h) - -data IfaceTickish - = IfaceHpcTick Module Int -- from HpcTick x - | IfaceSCC CostCentre Bool Bool -- from ProfNote - -- no breakpoints: we never export these into interface files - -instance Binary IfaceTickish where - put_ bh (IfaceHpcTick m ix) = do - putByte bh 0 - put_ bh m - put_ bh ix - put_ bh (IfaceSCC cc tick push) = do - putByte bh 1 - put_ bh cc - put_ bh tick - put_ bh push - - get bh = do - h <- getByte bh - case h of - 0 -> do m <- get bh - ix <- get bh - return (IfaceHpcTick m ix) - 1 -> do cc <- get bh - tick <- get bh - push <- get bh - return (IfaceSCC cc tick push) - _ -> panic ("get IfaceTickish " ++ show h) - -type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr) - -- Note: IfLclName, not IfaceBndr (and same with the case binder) - -- We reconstruct the kind/type of the thing from the context - -- thus saving bulk in interface files - -data IfaceConAlt = IfaceDefault - | IfaceDataAlt IfExtName - | IfaceLitAlt Literal - -instance Binary IfaceConAlt where - put_ bh IfaceDefault = putByte bh 0 - put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa - put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> return IfaceDefault - 1 -> liftM IfaceDataAlt $ get bh - _ -> liftM IfaceLitAlt $ get bh - -data IfaceBinding - = IfaceNonRec IfaceLetBndr IfaceExpr - | IfaceRec [(IfaceLetBndr, IfaceExpr)] - -instance Binary IfaceBinding where - put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab - put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) } - _ -> do { ac <- get bh; return (IfaceRec ac) } - --- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too --- It's used for *non-top-level* let/rec binders --- See Note [IdInfo on nested let-bindings] -data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo +-- We only serialise the IdDetails of top-level Ids, and even then +-- we only need a very limited selection. Notably, none of the +-- implicit ones are needed here, because they are not put it +-- interface files -instance Binary IfaceLetBndr where - put_ bh (IfLetBndr a b c) = do - put_ bh a - put_ bh b - put_ bh c - get bh = do a <- get bh - b <- get bh - c <- get bh - return (IfLetBndr a b c) +data IfaceIdDetails + = IfVanillaId + | IfRecSelId IfaceTyCon Bool + | IfDFunId Int -- Number of silent args \end{code} -Note [Empty case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In IfaceSyn an IfaceCase does not record the types of the alternatives, -unlike CorSyn Case. But we need this type if the alternatives are empty. -Hence IfaceECase. See Note [Empty case alternatives] in CoreSyn. - -Note [Expose recursive functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For supercompilation we want to put *all* unfoldings in the interface -file, even for functions that are recursive (or big). So we need to -know when an unfolding belongs to a loop-breaker so that we can refrain -from inlining it (except during supercompilation). - -Note [IdInfo on nested let-bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Occasionally we want to preserve IdInfo on nested let bindings. The one -that came up was a NOINLINE pragma on a let-binding inside an INLINE -function. The user (Duncan Coutts) really wanted the NOINLINE control -to cross the separate compilation boundary. - -In general we retain all info that is left by CoreTidy.tidyLetBndr, since -that is what is seen by importing module with --make Note [Orphans]: the ifInstOrph and ifRuleOrph fields ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -949,10 +381,22 @@ Note [Versioning of instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See [http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance#Instances] + +%************************************************************************ +%* * + Functions over declarations +%* * +%************************************************************************ + \begin{code} --- ----------------------------------------------------------------------------- --- Utils on IfaceSyn +visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] +visibleIfConDecls (IfAbstractTyCon {}) = [] +visibleIfConDecls IfDataFamTyCon = [] +visibleIfConDecls (IfDataTyCon cs) = cs +visibleIfConDecls (IfNewTyCon c) = [c] +\end{code} +\begin{code} ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName] -- *Excludes* the 'main' name, but *includes* the implicitly-bound names -- Deeply revolting, because it has to predict what gets bound, @@ -1015,11 +459,6 @@ ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ, dc_occ = mkClassDataConOcc cls_tc_occ is_newtype = n_sigs + n_ctxt == 1 -- Sigh -ifaceDeclImplicitBndrs (IfacePatSyn{ ifName = ps_occ, ifPatHasWrapper = has_wrapper }) - = [wrap_occ | has_wrapper] - where - wrap_occ = mkDataConWrapperOcc ps_occ -- Id namespace - ifaceDeclImplicitBndrs _ = [] -- ----------------------------------------------------------------------------- @@ -1038,80 +477,308 @@ ifaceDeclFingerprints hash decl computeFingerprint' = unsafeDupablePerformIO . computeFingerprint (panic "ifaceDeclFingerprints") +\end{code} ------------------------------ Printing IfaceDecl ------------------------------ +%************************************************************************ +%* * + Expressions +%* * +%************************************************************************ -instance Outputable IfaceDecl where - ppr = pprIfaceDecl +\begin{code} +data IfaceExpr + = IfaceLcl IfLclName + | IfaceExt IfExtName + | IfaceType IfaceType + | IfaceCo IfaceCoercion + | IfaceTuple TupleSort [IfaceExpr] -- Saturated; type arguments omitted + | IfaceLam IfaceBndr IfaceExpr + | IfaceApp IfaceExpr IfaceExpr + | IfaceCase IfaceExpr IfLclName [IfaceAlt] + | IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives] + | IfaceLet IfaceBinding IfaceExpr + | IfaceCast IfaceExpr IfaceCoercion + | IfaceLit Literal + | IfaceFCall ForeignCall IfaceType + | IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E + +data IfaceTickish + = IfaceHpcTick Module Int -- from HpcTick x + | IfaceSCC CostCentre Bool Bool -- from ProfNote + -- no breakpoints: we never export these into interface files + +type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr) + -- Note: IfLclName, not IfaceBndr (and same with the case binder) + -- We reconstruct the kind/type of the thing from the context + -- thus saving bulk in interface files -pprIfaceDecl :: IfaceDecl -> SDoc -pprIfaceDecl (IfaceId {ifName = var, ifType = ty, - ifIdDetails = details, ifIdInfo = info}) - = sep [ pprPrefixOcc var <+> dcolon <+> ppr ty, - nest 2 (ppr details), - nest 2 (ppr info) ] +data IfaceConAlt = IfaceDefault + | IfaceDataAlt IfExtName + | IfaceLitAlt Literal -pprIfaceDecl (IfaceForeign {ifName = tycon}) - = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon] +data IfaceBinding + = IfaceNonRec IfaceLetBndr IfaceExpr + | IfaceRec [(IfaceLetBndr, IfaceExpr)] + +-- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too +-- It's used for *non-top-level* let/rec binders +-- See Note [IdInfo on nested let-bindings] +data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo +\end{code} + +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In IfaceSyn an IfaceCase does not record the types of the alternatives, +unlike CorSyn Case. But we need this type if the alternatives are empty. +Hence IfaceECase. See Note [Empty case alternatives] in CoreSyn. + +Note [Expose recursive functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For supercompilation we want to put *all* unfoldings in the interface +file, even for functions that are recursive (or big). So we need to +know when an unfolding belongs to a loop-breaker so that we can refrain +from inlining it (except during supercompilation). + +Note [IdInfo on nested let-bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Occasionally we want to preserve IdInfo on nested let bindings. The one +that came up was a NOINLINE pragma on a let-binding inside an INLINE +function. The user (Duncan Coutts) really wanted the NOINLINE control +to cross the separate compilation boundary. -pprIfaceDecl (IfaceSyn {ifName = tycon, - ifTyVars = tyvars, - ifSynRhs = IfaceSynonymTyCon mono_ty}) - = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars) - 2 (vcat [equals <+> ppr mono_ty]) +In general we retain all info that is left by CoreTidy.tidyLetBndr, since +that is what is seen by importing module with --make + + +%************************************************************************ +%* * + Printing IfaceDecl +%* * +%************************************************************************ -pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifSynRhs = rhs, ifSynKind = kind }) - = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars) - 2 (sep [dcolon <+> ppr kind, parens (pp_rhs rhs)]) +\begin{code} +pprAxBranch :: SDoc -> IfaceAxBranch -> SDoc +-- The TyCon might be local (just an OccName), or this might +-- be a branch for an imported TyCon, so it would be an ExtName +-- So it's easier to take an SDoc here +pprAxBranch pp_tc (IfaceAxBranch { ifaxbTyVars = tvs + , ifaxbLHS = pat_tys + , ifaxbRHS = rhs + , ifaxbIncomps = incomps }) + = hang (pprUserIfaceForAll tvs) + 2 (hang pp_lhs 2 (equals <+> ppr rhs)) + $+$ + nest 2 maybe_incomps where - pp_rhs IfaceOpenSynFamilyTyCon = ptext (sLit "open") - pp_rhs (IfaceClosedSynFamilyTyCon ax) = ptext (sLit "closed, axiom") <+> ppr ax - pp_rhs IfaceAbstractClosedSynFamilyTyCon = ptext (sLit "closed, abstract") - pp_rhs _ = panic "pprIfaceDecl syn" + pp_lhs = hang pp_tc 2 (pprParendIfaceTcArgs pat_tys) + maybe_incomps = ppUnless (null incomps) $ parens $ + ptext (sLit "incompatible indices:") <+> ppr incomps + +instance Outputable IfaceAnnotation where + ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value + +instance HasOccName IfaceClassOp where + occName (IfaceClassOp n _ _) = n + +instance HasOccName IfaceConDecl where + occName = ifConOcc -pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType, - ifCtxt = context, - ifTyVars = tyvars, ifRoles = roles, ifCons = condecls, - ifRec = isrec, ifPromotable = is_prom, - ifAxiom = mbAxiom}) - = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) - 2 (vcat [ pprCType cType - , pprRoles roles - , pprRec isrec <> comma <+> pp_prom - , pp_condecls tycon condecls - , pprAxiom mbAxiom]) +instance HasOccName IfaceDecl where + occName = ifName + +instance Outputable IfaceDecl where + ppr = pprIfaceDecl showAll + +data ShowSub + = ShowSub + { ss_ppr_bndr :: OccName -> SDoc -- Pretty-printer for binders in IfaceDecl + -- See Note [Printing IfaceDecl binders] + , ss_how_much :: ShowHowMuch } + +data ShowHowMuch + = ShowHeader -- Header information only, not rhs + | ShowSome [OccName] -- [] <=> Print all sub-components + -- (n:ns) <=> print sub-component 'n' with ShowSub=ns + -- elide other sub-components to "..." + -- May 14: the list is max 1 element long at the moment + | ShowIface -- Everything including GHC-internal information (used in --show-iface) + +showAll :: ShowSub +showAll = ShowSub { ss_how_much = ShowIface, ss_ppr_bndr = ppr } + +ppShowIface :: ShowSub -> SDoc -> SDoc +ppShowIface (ShowSub { ss_how_much = ShowIface }) doc = doc +ppShowIface _ _ = empty + +ppShowRhs :: ShowSub -> SDoc -> SDoc +ppShowRhs (ShowSub { ss_how_much = ShowHeader }) _ = empty +ppShowRhs _ doc = doc + +showSub :: HasOccName n => ShowSub -> n -> Bool +showSub (ShowSub { ss_how_much = ShowHeader }) _ = False +showSub (ShowSub { ss_how_much = ShowSome (n:_) }) thing = n == occName thing +showSub (ShowSub { ss_how_much = _ }) _ = True +\end{code} + +Note [Printing IfaceDecl binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The binders in an IfaceDecl are just OccNames, so we don't know what module they +come from. But when we pretty-print a TyThing by converting to an IfaceDecl +(see PprTyThing), the TyThing may come from some other module so we really need +the module qualifier. We solve this by passing in a pretty-printer for the +binders. + +When printing an interface file (--show-iface), we want to print +everything unqualified, so we can just print the OccName directly. + +\begin{code} +ppr_trim :: [Maybe SDoc] -> [SDoc] +-- Collapse a group of Nothings to a single "..." +ppr_trim xs + = snd (foldr go (False, []) xs) where - pp_prom | is_prom = ptext (sLit "Promotable") - | otherwise = ptext (sLit "Not promotable") + go (Just doc) (_, so_far) = (False, doc : so_far) + go Nothing (True, so_far) = (True, so_far) + go Nothing (False, so_far) = (True, ptext (sLit "...") : so_far) + +isIfaceDataInstance :: IfaceTyConParent -> Bool +isIfaceDataInstance IfNoParent = False +isIfaceDataInstance _ = True + +pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc +-- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi +-- See Note [Pretty-printing TyThings] in PprTyThing +pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, + ifCtxt = context, ifTyVars = tc_tyvars, + ifRoles = roles, ifCons = condecls, + ifParent = parent, ifRec = isrec, + ifGadtSyntax = gadt, + ifPromotable = is_prom }) + + | gadt_style = vcat [ pp_roles + , pp_nd <+> pp_lhs <+> pp_where + , nest 2 (vcat pp_cons) + , nest 2 $ ppShowIface ss pp_extra ] + | otherwise = vcat [ pp_roles + , hang (pp_nd <+> pp_lhs) 2 (add_bars pp_cons) + , nest 2 $ ppShowIface ss pp_extra ] + where + is_data_instance = isIfaceDataInstance parent + + gadt_style = gadt || any (not . isVanillaIfaceConDecl) cons + cons = visibleIfConDecls condecls + pp_where = ppWhen (gadt_style && not (null cons)) $ ptext (sLit "where") + pp_cons = ppr_trim (map show_con cons) :: [SDoc] + + pp_lhs = case parent of + IfNoParent -> pprIfaceDeclHead context ss tycon tc_tyvars + _ -> ptext (sLit "instance") <+> pprIfaceTyConParent parent + + pp_roles + | is_data_instance = empty + | otherwise = pprRoles (== Representational) (pprPrefixIfDeclBndr ss tycon) + tc_tyvars roles + -- Don't display roles for data family instances (yet) + -- See discussion on Trac #8672. + + add_bars [] = empty + add_bars (c:cs) = sep ((equals <+> c) : map (char '|' <+>) cs) + + ok_con dc = showSub ss dc || any (showSub ss) (ifConFields dc) + + show_con dc + | ok_con dc = Just $ pprIfaceConDecl ss gadt_style mk_user_con_res_ty dc + | otherwise = Nothing + + mk_user_con_res_ty :: IfaceEqSpec -> ([IfaceTvBndr], SDoc) + -- See Note [Result type of a data family GADT] + mk_user_con_res_ty eq_spec + | IfDataInstance _ tc tys <- parent + = (con_univ_tvs, pprIfaceType (IfaceTyConApp tc (substIfaceTcArgs gadt_subst tys))) + | otherwise + = (con_univ_tvs, sdocWithDynFlags (ppr_tc_app gadt_subst)) + where + gadt_subst = mkFsEnv eq_spec + done_univ_tv (tv,_) = isJust (lookupFsEnv gadt_subst tv) + con_univ_tvs = filterOut done_univ_tv tc_tyvars + + ppr_tc_app gadt_subst dflags + = pprPrefixIfDeclBndr ss tycon + <+> sep [ pprParendIfaceType (substIfaceTyVar gadt_subst tv) + | (tv,_kind) <- stripIfaceKindVars dflags tc_tyvars ] + pp_nd = case condecls of - IfAbstractTyCon dis -> ptext (sLit "abstract") <> parens (ppr dis) - IfDataFamTyCon -> ptext (sLit "data family") - IfDataTyCon _ -> ptext (sLit "data") - IfNewTyCon _ -> ptext (sLit "newtype") - -pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, - ifRoles = roles, ifFDs = fds, ifATs = ats, ifSigs = sigs, - ifRec = isrec}) - = hang (ptext (sLit "class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds) - 2 (vcat [pprRoles roles, - pprRec isrec, - sep (map ppr ats), - sep (map ppr sigs)]) - -pprIfaceDecl (IfaceAxiom {ifName = name, ifTyCon = tycon, ifAxBranches = branches }) - = hang (ptext (sLit "axiom") <+> ppr name <> dcolon) - 2 (vcat $ map (pprAxBranch $ Just tycon) branches) - -pprIfaceDecl (IfacePatSyn { ifName = name, ifPatHasWrapper = has_wrap, - ifPatIsInfix = is_infix, - ifPatUnivTvs = _univ_tvs, ifPatExTvs = _ex_tvs, - ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt, - ifPatArgs = args, - ifPatTy = ty }) + IfAbstractTyCon d -> ptext (sLit "abstract") <> ppShowIface ss (parens (ppr d)) + IfDataFamTyCon -> ptext (sLit "data family") + IfDataTyCon _ -> ptext (sLit "data") + IfNewTyCon _ -> ptext (sLit "newtype") + + pp_extra = vcat [pprCType ctype, pprRec isrec, pp_prom] + + pp_prom | is_prom = ptext (sLit "Promotable") + | otherwise = empty + + +pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec + , ifCtxt = context, ifName = clas + , ifTyVars = tyvars, ifRoles = roles + , ifFDs = fds }) + = vcat [ pprRoles (== Nominal) (pprPrefixIfDeclBndr ss clas) tyvars roles + , ptext (sLit "class") <+> pprIfaceDeclHead context ss clas tyvars + <+> pprFundeps fds <+> pp_where + , nest 2 (vcat [vcat asocs, vcat dsigs, pprec])] + where + pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (ptext (sLit "where")) + + asocs = ppr_trim $ map maybeShowAssoc ats + dsigs = ppr_trim $ map maybeShowSig sigs + pprec = ppShowIface ss (pprRec isrec) + + maybeShowAssoc :: IfaceAT -> Maybe SDoc + maybeShowAssoc asc@(IfaceAT d _) + | showSub ss d = Just $ pprIfaceAT ss asc + | otherwise = Nothing + + maybeShowSig :: IfaceClassOp -> Maybe SDoc + maybeShowSig sg + | showSub ss sg = Just $ pprIfaceClassOp ss sg + | otherwise = Nothing + +pprIfaceDecl ss (IfaceSyn { ifName = tc + , ifTyVars = tv + , ifSynRhs = IfaceSynonymTyCon mono_ty }) + = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] ss tc tv <+> equals) + 2 (sep [pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau]) + where + (tvs, theta, tau) = splitIfaceSigmaTy mono_ty + +pprIfaceDecl ss (IfaceSyn { ifName = tycon, ifTyVars = tyvars + , ifSynRhs = rhs, ifSynKind = kind }) + = vcat [ hang (text "type family" <+> pprIfaceDeclHead [] ss tycon tyvars <+> dcolon) + 2 (ppr kind <+> ppShowRhs ss (pp_rhs rhs)) + , ppShowRhs ss (nest 2 (pp_branches rhs)) ] + where + pp_rhs IfaceOpenSynFamilyTyCon = ppShowIface ss (ptext (sLit "open")) + pp_rhs IfaceAbstractClosedSynFamilyTyCon = ppShowIface ss (ptext (sLit "closed, abstract")) + pp_rhs (IfaceClosedSynFamilyTyCon _ (_:_)) = ptext (sLit "where") + pp_rhs IfaceBuiltInSynFamTyCon = ppShowIface ss (ptext (sLit "built-in")) + pp_rhs _ = panic "pprIfaceDecl syn" + + pp_branches (IfaceClosedSynFamilyTyCon ax brs) + = vcat (map (pprAxBranch (pprPrefixIfDeclBndr ss tycon)) brs) + $$ ppShowIface ss (ptext (sLit "axiom") <+> ppr ax) + pp_branches _ = empty + +pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatWrapper = wrapper, + ifPatIsInfix = is_infix, + ifPatUnivTvs = _univ_tvs, ifPatExTvs = _ex_tvs, + ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt, + ifPatArgs = args, + ifPatTy = ty }) = pprPatSynSig name has_wrap args' ty' (pprCtxt prov_ctxt) (pprCtxt req_ctxt) where - args' = case (is_infix, map snd args) of + has_wrap = isJust wrapper + args' = case (is_infix, args) of (True, [left_ty, right_ty]) -> InfixPatSyn (pprParendIfaceType left_ty) (pprParendIfaceType right_ty) (_, tys) -> @@ -1122,70 +789,105 @@ pprIfaceDecl (IfacePatSyn { ifName = name, ifPatHasWrapper = has_wrap, pprCtxt [] = Nothing pprCtxt ctxt = Just $ pprIfaceContext ctxt +pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty, + ifIdDetails = details, ifIdInfo = info }) + = vcat [ hang (pprPrefixIfDeclBndr ss var <+> dcolon) + 2 (pprIfaceSigmaType ty) + , ppShowIface ss (ppr details) + , ppShowIface ss (ppr info) ] + +pprIfaceDecl _ (IfaceForeign {ifName = tycon}) + = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon] + +pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon + , ifAxBranches = branches }) + = hang (ptext (sLit "axiom") <+> ppr name <> dcolon) + 2 (vcat $ map (pprAxBranch (ppr tycon)) branches) + + pprCType :: Maybe CType -> SDoc -pprCType Nothing = ptext (sLit "No C type associated") +pprCType Nothing = empty pprCType (Just cType) = ptext (sLit "C type:") <+> ppr cType -pprRoles :: [Role] -> SDoc -pprRoles [] = empty -pprRoles roles = text "Roles:" <+> ppr roles +-- if, for each role, suppress_if role is True, then suppress the role +-- output +pprRoles :: (Role -> Bool) -> SDoc -> [IfaceTvBndr] -> [Role] -> SDoc +pprRoles suppress_if tyCon tyvars roles + = sdocWithDynFlags $ \dflags -> + let froles = suppressIfaceKinds dflags tyvars roles + in ppUnless (all suppress_if roles || null froles) $ + ptext (sLit "type role") <+> tyCon <+> hsep (map ppr froles) pprRec :: RecFlag -> SDoc -pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec +pprRec NonRecursive = empty +pprRec Recursive = ptext (sLit "RecFlag: Recursive") -pprAxiom :: Maybe Name -> SDoc -pprAxiom Nothing = ptext (sLit "FamilyInstance: none") -pprAxiom (Just ax) = ptext (sLit "FamilyInstance:") <+> ppr ax +pprInfixIfDeclBndr, pprPrefixIfDeclBndr :: ShowSub -> OccName -> SDoc +pprInfixIfDeclBndr (ShowSub { ss_ppr_bndr = ppr_bndr }) occ + = pprInfixVar (isSymOcc occ) (ppr_bndr occ) +pprPrefixIfDeclBndr (ShowSub { ss_ppr_bndr = ppr_bndr }) occ + = parenSymOcc occ (ppr_bndr occ) instance Outputable IfaceClassOp where - ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty + ppr = pprIfaceClassOp showAll + +pprIfaceClassOp :: ShowSub -> IfaceClassOp -> SDoc +pprIfaceClassOp ss (IfaceClassOp n dm ty) = hang opHdr 2 (pprIfaceSigmaType ty) + where opHdr = pprPrefixIfDeclBndr ss n + <+> ppShowIface ss (ppr dm) <+> dcolon instance Outputable IfaceAT where - ppr (IfaceAT d defs) - = vcat [ ppr d - , ppUnless (null defs) $ nest 2 $ - ptext (sLit "Defaults:") <+> vcat (map ppr defs) ] - -pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc -pprIfaceDeclHead context thing tyvars - = hsep [pprIfaceContextArr context, parenSymOcc thing (ppr thing), - pprIfaceTvBndrs tyvars] - -pp_condecls :: OccName -> IfaceConDecls -> SDoc -pp_condecls _ (IfAbstractTyCon {}) = empty -pp_condecls _ IfDataFamTyCon = empty -pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c -pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |")) - (map (pprIfaceConDecl tc) cs)) - -mkIfaceEqPred :: IfaceType -> IfaceType -> IfacePredType --- IA0_NOTE: This is wrong, but only used for pretty-printing. -mkIfaceEqPred ty1 ty2 = IfaceTyConApp (IfaceTc eqTyConName) [ty1, ty2] - -pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc -pprIfaceConDecl tc - (IfCon { ifConOcc = name, ifConInfix = is_infix, ifConWrapper = has_wrap, - ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs, + ppr = pprIfaceAT showAll + +pprIfaceAT :: ShowSub -> IfaceAT -> SDoc +pprIfaceAT ss (IfaceAT d mb_def) + = vcat [ pprIfaceDecl ss d + , case mb_def of + Nothing -> empty + Just rhs -> nest 2 $ + ptext (sLit "Default:") <+> ppr rhs ] + +instance Outputable IfaceTyConParent where + ppr p = pprIfaceTyConParent p + +pprIfaceTyConParent :: IfaceTyConParent -> SDoc +pprIfaceTyConParent IfNoParent + = empty +pprIfaceTyConParent (IfDataInstance _ tc tys) + = sdocWithDynFlags $ \dflags -> + let ftys = stripKindArgs dflags tys + in pprIfaceTypeApp tc ftys + +pprIfaceDeclHead :: IfaceContext -> ShowSub -> OccName -> [IfaceTvBndr] -> SDoc +pprIfaceDeclHead context ss tc_occ tv_bndrs + = sdocWithDynFlags $ \ dflags -> + sep [ pprIfaceContextArr context + , pprPrefixIfDeclBndr ss tc_occ + <+> pprIfaceTvBndrs (stripIfaceKindVars dflags tv_bndrs) ] + +isVanillaIfaceConDecl :: IfaceConDecl -> Bool +isVanillaIfaceConDecl (IfCon { ifConExTvs = ex_tvs + , ifConEqSpec = eq_spec + , ifConCtxt = ctxt }) + = (null ex_tvs) && (null eq_spec) && (null ctxt) + +pprIfaceConDecl :: ShowSub -> Bool + -> (IfaceEqSpec -> ([IfaceTvBndr], SDoc)) + -> IfaceConDecl -> SDoc +pprIfaceConDecl ss gadt_style mk_user_con_res_ty + (IfCon { ifConOcc = name, ifConInfix = is_infix, + ifConExTvs = ex_tvs, ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, - ifConStricts = strs, ifConFields = fields }) - = sep [main_payload, - if is_infix then ptext (sLit "Infix") else empty, - if has_wrap then ptext (sLit "HasWrapper") else empty, - ppUnless (null strs) $ - nest 2 (ptext (sLit "Stricts:") <+> hsep (map ppr_bang strs)), - ppUnless (null fields) $ - nest 2 (ptext (sLit "Fields:") <+> hsep (map ppr fields))] + ifConStricts = stricts, ifConFields = labels }) + | gadt_style = pp_prefix_con <+> dcolon <+> ppr_ty + | otherwise = ppr_fields tys_w_strs where - ppr_bang IfNoBang = char '_' -- Want to see these - ppr_bang IfStrict = char '!' - ppr_bang IfUnpack = ptext (sLit "!!") - ppr_bang (IfUnpackCo co) = ptext (sLit "!!") <> pprParendIfaceCoercion co - - main_payload = ppr name <+> dcolon <+> - pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau + tys_w_strs :: [(IfaceBang, IfaceType)] + tys_w_strs = zip stricts arg_tys + pp_prefix_con = pprPrefixIfDeclBndr ss name - eq_ctxt = [(mkIfaceEqPred (IfaceTyVar (occNameFS tv)) ty) - | (tv,ty) <- eq_spec] + (univ_tvs, pp_res_ty) = mk_user_con_res_ty eq_spec + ppr_ty = pprIfaceForAllPart (univ_tvs ++ ex_tvs) ctxt pp_tau -- A bit gruesome this, but we can't form the full con_tau, and ppr it, -- because we don't have a Name for the tycon, only an OccName @@ -1193,7 +895,26 @@ pprIfaceConDecl tc (t:ts) -> fsep (t : map (arrow <+>) ts) [] -> panic "pp_con_taus" - pp_res_ty = ppr tc <+> fsep [ppr tv | (tv,_) <- univ_tvs] + ppr_bang IfNoBang = ppWhen opt_PprStyle_Debug $ char '_' + ppr_bang IfStrict = char '!' + ppr_bang IfUnpack = ptext (sLit "{-# UNPACK #-}") + ppr_bang (IfUnpackCo co) = ptext (sLit "! {-# UNPACK #-}") <> + pprParendIfaceCoercion co + + pprParendBangTy (bang, ty) = ppr_bang bang <> pprParendIfaceType ty + pprBangTy (bang, ty) = ppr_bang bang <> ppr ty + + maybe_show_label (lbl,bty) + | showSub ss lbl = Just (pprPrefixIfDeclBndr ss lbl <+> dcolon <+> pprBangTy bty) + | otherwise = Nothing + + ppr_fields [ty1, ty2] + | is_infix && null labels + = sep [pprParendBangTy ty1, pprInfixIfDeclBndr ss name, pprParendBangTy ty2] + ppr_fields fields + | null labels = pp_prefix_con <+> sep (map pprParendBangTy fields) + | otherwise = pp_prefix_con <+> (braces $ sep $ punctuate comma $ ppr_trim $ + map maybe_show_label (zip labels fields)) instance Outputable IfaceRule where ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, @@ -1205,15 +926,15 @@ instance Outputable IfaceRule where ] instance Outputable IfaceClsInst where - ppr (IfaceClsInst {ifDFun = dfun_id, ifOFlag = flag, - ifInstCls = cls, ifInstTys = mb_tcs}) + ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag + , ifInstCls = cls, ifInstTys = mb_tcs}) = hang (ptext (sLit "instance") <+> ppr flag <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs)) 2 (equals <+> ppr dfun_id) instance Outputable IfaceFamInst where - ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs, - ifFamInstAxiom = tycon_ax}) + ppr (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs + , ifFamInstAxiom = tycon_ax}) = hang (ptext (sLit "family instance") <+> ppr fam <+> pprWithCommas (brackets . ppr_rough) mb_tcs) 2 (equals <+> ppr tycon_ax) @@ -1223,6 +944,26 @@ ppr_rough Nothing = dot ppr_rough (Just tc) = ppr tc \end{code} +Note [Result type of a data family GADT] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family T a + data instance T (p,q) where + T1 :: T (Int, Maybe c) + T2 :: T (Bool, q) + +The IfaceDecl actually looks like + + data TPr p q where + T1 :: forall p q. forall c. (p~Int,q~Maybe c) => TPr p q + T2 :: forall p q. (p~Bool) => TPr p q + +To reconstruct the result types for T1 and T2 that we +want to pretty print, we substitute the eq-spec +[p->Int, q->Maybe c] in the arg pattern (p,q) to give + T (Int, Maybe c) +Remember that in IfaceSyn, the TyCon and DataCon share the same +universal type variables. ----------------------------- Printing IfaceExpr ------------------------------------ @@ -1230,6 +971,9 @@ ppr_rough (Just tc) = ppr tc instance Outputable IfaceExpr where ppr e = pprIfaceExpr noParens e +noParens :: SDoc -> SDoc +noParens pp = pp + pprParendIfaceExpr :: IfaceExpr -> SDoc pprParendIfaceExpr = pprIfaceExpr parens @@ -1355,17 +1099,22 @@ instance Outputable IfaceUnfolding where pprParendIfaceExpr e] ppr (IfDFunUnfold bs es) = hang (ptext (sLit "DFun:") <+> sep (map ppr bs) <> dot) 2 (sep (map pprParendIfaceExpr es)) +\end{code} --- ----------------------------------------------------------------------------- --- | Finding the Names in IfaceSyn +%************************************************************************ +%* * + Finding the Names in IfaceSyn +%* * +%************************************************************************ --- This is used for dependency analysis in MkIface, so that we --- fingerprint a declaration before the things that depend on it. It --- is specific to interface-file fingerprinting in the sense that we --- don't collect *all* Names: for example, the DFun of an instance is --- recorded textually rather than by its fingerprint when --- fingerprinting the instance, so DFuns are not dependencies. +This is used for dependency analysis in MkIface, so that we +fingerprint a declaration before the things that depend on it. It +is specific to interface-file fingerprinting in the sense that we +don't collect *all* Names: for example, the DFun of an instance is +recorded textually rather than by its fingerprint when +fingerprinting the instance, so DFuns are not dependencies. +\begin{code} freeNamesIfDecl :: IfaceDecl -> NameSet freeNamesIfDecl (IfaceId _s t d i) = freeNamesIfType t &&& @@ -1375,7 +1124,7 @@ freeNamesIfDecl IfaceForeign{} = emptyNameSet freeNamesIfDecl d@IfaceData{} = freeNamesIfTvBndrs (ifTyVars d) &&& - maybe emptyNameSet unitNameSet (ifAxiom d) &&& + freeNamesIfaceTyConParent (ifParent d) &&& freeNamesIfContext (ifCtxt d) &&& freeNamesIfConDecls (ifCons d) freeNamesIfDecl d@IfaceSyn{} = @@ -1392,11 +1141,13 @@ freeNamesIfDecl d@IfaceAxiom{} = freeNamesIfTc (ifTyCon d) &&& fnList freeNamesIfAxBranch (ifAxBranches d) freeNamesIfDecl d@IfacePatSyn{} = + unitNameSet (ifPatMatcher d) &&& + maybe emptyNameSet unitNameSet (ifPatWrapper d) &&& freeNamesIfTvBndrs (ifPatUnivTvs d) &&& freeNamesIfTvBndrs (ifPatExTvs d) &&& freeNamesIfContext (ifPatProvCtxt d) &&& freeNamesIfContext (ifPatReqCtxt d) &&& - fnList freeNamesIfType (map snd (ifPatArgs d)) &&& + fnList freeNamesIfType (ifPatArgs d) &&& freeNamesIfType (ifPatTy d) freeNamesIfAxBranch :: IfaceAxBranch -> NameSet @@ -1404,7 +1155,7 @@ freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars , ifaxbLHS = lhs , ifaxbRHS = rhs }) = freeNamesIfTvBndrs tyvars &&& - fnList freeNamesIfType lhs &&& + freeNamesIfTcArgs lhs &&& freeNamesIfType rhs freeNamesIfIdDetails :: IfaceIdDetails -> NameSet @@ -1415,16 +1166,20 @@ freeNamesIfIdDetails _ = emptyNameSet freeNamesIfSynRhs :: IfaceSynTyConRhs -> NameSet freeNamesIfSynRhs (IfaceSynonymTyCon ty) = freeNamesIfType ty freeNamesIfSynRhs IfaceOpenSynFamilyTyCon = emptyNameSet -freeNamesIfSynRhs (IfaceClosedSynFamilyTyCon ax) = unitNameSet ax +freeNamesIfSynRhs (IfaceClosedSynFamilyTyCon ax br) + = unitNameSet ax &&& fnList freeNamesIfAxBranch br freeNamesIfSynRhs IfaceAbstractClosedSynFamilyTyCon = emptyNameSet +freeNamesIfSynRhs IfaceBuiltInSynFamTyCon = emptyNameSet 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 @@ -1435,25 +1190,30 @@ freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c freeNamesIfConDecls _ = emptyNameSet freeNamesIfConDecl :: IfaceConDecl -> NameSet -freeNamesIfConDecl c = - freeNamesIfTvBndrs (ifConUnivTvs c) &&& - freeNamesIfTvBndrs (ifConExTvs c) &&& - freeNamesIfContext (ifConCtxt c) &&& - fnList freeNamesIfType (ifConArgTys c) &&& - fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints +freeNamesIfConDecl c + = freeNamesIfTvBndrs (ifConExTvs c) &&& + freeNamesIfContext (ifConCtxt c) &&& + fnList freeNamesIfType (ifConArgTys c) &&& + fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints freeNamesIfKind :: IfaceType -> NameSet freeNamesIfKind = freeNamesIfType +freeNamesIfTcArgs :: IfaceTcArgs -> NameSet +freeNamesIfTcArgs (ITC_Type t ts) = freeNamesIfType t &&& freeNamesIfTcArgs ts +freeNamesIfTcArgs (ITC_Kind k ks) = freeNamesIfKind k &&& freeNamesIfTcArgs ks +freeNamesIfTcArgs ITC_Nil = emptyNameSet + freeNamesIfType :: IfaceType -> NameSet freeNamesIfType (IfaceTyVar _) = emptyNameSet freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t freeNamesIfType (IfaceTyConApp tc ts) = - freeNamesIfTc tc &&& fnList freeNamesIfType ts + freeNamesIfTc tc &&& freeNamesIfTcArgs ts freeNamesIfType (IfaceLitTy _) = emptyNameSet freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfTvBndr tv &&& freeNamesIfType t freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t +freeNamesIfType (IfaceDFunTy s t) = freeNamesIfType s &&& freeNamesIfType t freeNamesIfCoercion :: IfaceCoercion -> NameSet freeNamesIfCoercion (IfaceReflCo _ t) = freeNamesIfType t @@ -1535,8 +1295,7 @@ freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co freeNamesIfExpr (IfaceTick _ e) = freeNamesIfExpr e freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty freeNamesIfExpr (IfaceCase s _ alts) - = freeNamesIfExpr s - &&& fnList fn_alt alts &&& fn_cons alts + = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts where fn_alt (_con,_bs,r) = freeNamesIfExpr r @@ -1558,7 +1317,7 @@ freeNamesIfExpr (IfaceLet (IfaceRec as) x) freeNamesIfExpr _ = emptyNameSet freeNamesIfTc :: IfaceTyCon -> NameSet -freeNamesIfTc (IfaceTc tc) = unitNameSet tc +freeNamesIfTc tc = unitNameSet (ifaceTyConName tc) -- ToDo: shouldn't we include IfaceIntTc & co.? freeNamesIfRule :: IfaceRule -> NameSet @@ -1568,13 +1327,18 @@ freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f fnList freeNamesIfBndr bs &&& fnList freeNamesIfExpr es &&& freeNamesIfExpr rhs - + freeNamesIfFamInst :: IfaceFamInst -> NameSet freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName , ifFamInstAxiom = axName }) = unitNameSet famName &&& unitNameSet axName +freeNamesIfaceTyConParent :: IfaceTyConParent -> NameSet +freeNamesIfaceTyConParent IfNoParent = emptyNameSet +freeNamesIfaceTyConParent (IfDataInstance ax tc tys) + = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfTcArgs tys + -- helpers (&&&) :: NameSet -> NameSet -> NameSet (&&&) = unionNameSets @@ -1608,3 +1372,538 @@ Now, lookupModule depends on DynFlags, but the transitive dependency on the *locally-defined* type PackageState is not visible. We need to take account of the use of the data constructor PS in the pattern match. + +%************************************************************************ +%* * + Binary instances +%* * +%************************************************************************ + +\begin{code} +instance Binary IfaceDecl where + put_ bh (IfaceId name ty details idinfo) = do + putByte bh 0 + put_ bh (occNameFS name) + put_ bh ty + put_ bh details + put_ bh idinfo + + put_ _ (IfaceForeign _ _) = + error "Binary.put_(IfaceDecl): IfaceForeign" + + put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do + putByte bh 2 + put_ bh (occNameFS a1) + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + put_ bh a10 + + put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do + putByte bh 3 + put_ bh (occNameFS a1) + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + + put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8 a9) = do + putByte bh 4 + put_ bh a1 + put_ bh (occNameFS a2) + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + + put_ bh (IfaceAxiom a1 a2 a3 a4) = do + putByte bh 5 + put_ bh (occNameFS a1) + put_ bh a2 + put_ bh a3 + put_ bh a4 + + put_ bh (IfacePatSyn name a2 a3 a4 a5 a6 a7 a8 a9 a10) = do + putByte bh 6 + put_ bh (occNameFS name) + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + put_ bh a10 + + get bh = do + h <- getByte bh + case h of + 0 -> do name <- get bh + ty <- get bh + details <- get bh + idinfo <- get bh + occ <- return $! mkVarOccFS name + return (IfaceId occ ty details idinfo) + 1 -> error "Binary.get(TyClDecl): ForeignType" + 2 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + a10 <- get bh + occ <- return $! mkTcOccFS a1 + return (IfaceData occ a2 a3 a4 a5 a6 a7 a8 a9 a10) + 3 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + occ <- return $! mkTcOccFS a1 + return (IfaceSyn occ a2 a3 a4 a5) + 4 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + occ <- return $! mkClsOccFS a2 + return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8 a9) + 5 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + occ <- return $! mkTcOccFS a1 + return (IfaceAxiom occ a2 a3 a4) + 6 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + a10 <- get bh + occ <- return $! mkDataOccFS a1 + return (IfacePatSyn occ a2 a3 a4 a5 a6 a7 a8 a9 a10) + _ -> panic (unwords ["Unknown IfaceDecl tag:", show h]) + +instance Binary IfaceSynTyConRhs where + put_ bh IfaceOpenSynFamilyTyCon = putByte bh 0 + put_ bh (IfaceClosedSynFamilyTyCon ax br) = putByte bh 1 >> put_ bh ax + >> put_ bh br + put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 2 + put_ bh (IfaceSynonymTyCon ty) = putByte bh 3 >> put_ bh ty + put_ _ IfaceBuiltInSynFamTyCon + = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" empty + + get bh = do { h <- getByte bh + ; case h of + 0 -> return IfaceOpenSynFamilyTyCon + 1 -> do { ax <- get bh + ; br <- get bh + ; return (IfaceClosedSynFamilyTyCon ax br) } + 2 -> return IfaceAbstractClosedSynFamilyTyCon + _ -> do { ty <- get bh + ; return (IfaceSynonymTyCon ty) } } + +instance Binary IfaceClassOp where + put_ bh (IfaceClassOp n def ty) = do + put_ bh (occNameFS n) + put_ bh def + put_ bh ty + get bh = do + n <- get bh + def <- get bh + ty <- get bh + occ <- return $! mkVarOccFS n + return (IfaceClassOp occ def ty) + +instance Binary IfaceAT where + put_ bh (IfaceAT dec defs) = do + put_ bh dec + put_ bh defs + get bh = do + dec <- get bh + defs <- get bh + return (IfaceAT dec defs) + +instance Binary IfaceAxBranch where + put_ bh (IfaceAxBranch a1 a2 a3 a4 a5) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + return (IfaceAxBranch a1 a2 a3 a4 a5) + +instance Binary IfaceConDecls where + put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d + put_ bh IfDataFamTyCon = putByte bh 1 + put_ bh (IfDataTyCon cs) = putByte bh 2 >> put_ bh cs + put_ bh (IfNewTyCon c) = putByte bh 3 >> put_ bh c + get bh = do + h <- getByte bh + case h of + 0 -> liftM IfAbstractTyCon $ get bh + 1 -> return IfDataFamTyCon + 2 -> liftM IfDataTyCon $ get bh + _ -> liftM IfNewTyCon $ get bh + +instance Binary IfaceConDecl where + put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) + +instance Binary IfaceBang where + put_ bh IfNoBang = putByte bh 0 + put_ bh IfStrict = putByte bh 1 + put_ bh IfUnpack = putByte bh 2 + put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co + + get bh = do + h <- getByte bh + case h of + 0 -> do return IfNoBang + 1 -> do return IfStrict + 2 -> do return IfUnpack + _ -> do { a <- get bh; return (IfUnpackCo a) } + +instance Binary IfaceClsInst where + put_ bh (IfaceClsInst cls tys dfun flag orph) = do + put_ bh cls + put_ bh tys + put_ bh dfun + put_ bh flag + put_ bh orph + get bh = do + cls <- get bh + tys <- get bh + dfun <- get bh + flag <- get bh + orph <- get bh + return (IfaceClsInst cls tys dfun flag orph) + +instance Binary IfaceFamInst where + put_ bh (IfaceFamInst fam tys name orph) = do + put_ bh fam + put_ bh tys + put_ bh name + put_ bh orph + get bh = do + fam <- get bh + tys <- get bh + name <- get bh + orph <- get bh + return (IfaceFamInst fam tys name orph) + +instance Binary IfaceRule where + put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) + +instance Binary IfaceAnnotation where + put_ bh (IfaceAnnotation a1 a2) = do + put_ bh a1 + put_ bh a2 + get bh = do + a1 <- get bh + a2 <- get bh + return (IfaceAnnotation a1 a2) + +instance Binary IfaceIdDetails where + put_ bh IfVanillaId = putByte bh 0 + put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b + put_ bh (IfDFunId n) = do { putByte bh 2; put_ bh n } + get bh = do + h <- getByte bh + case h of + 0 -> return IfVanillaId + 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) } + _ -> do { n <- get bh; return (IfDFunId n) } + +instance Binary IfaceIdInfo where + put_ bh NoInfo = putByte bh 0 + put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut + + get bh = do + h <- getByte bh + case h of + 0 -> return NoInfo + _ -> liftM HasInfo $ lazyGet bh -- NB lazyGet + +instance Binary IfaceInfoItem where + put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa + put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab + put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad + put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad + put_ bh HsNoCafRefs = putByte bh 4 + get bh = do + h <- getByte bh + case h of + 0 -> liftM HsArity $ get bh + 1 -> liftM HsStrictness $ get bh + 2 -> do lb <- get bh + ad <- get bh + return (HsUnfold lb ad) + 3 -> liftM HsInline $ get bh + _ -> return HsNoCafRefs + +instance Binary IfaceUnfolding where + put_ bh (IfCoreUnfold s e) = do + putByte bh 0 + put_ bh s + put_ bh e + put_ bh (IfInlineRule a b c d) = do + putByte bh 1 + put_ bh a + put_ bh b + put_ bh c + put_ bh d + put_ bh (IfDFunUnfold as bs) = do + putByte bh 2 + put_ bh as + put_ bh bs + put_ bh (IfCompulsory e) = do + putByte bh 3 + put_ bh e + get bh = do + h <- getByte bh + case h of + 0 -> do s <- get bh + e <- get bh + return (IfCoreUnfold s e) + 1 -> do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (IfInlineRule a b c d) + 2 -> do as <- get bh + bs <- get bh + return (IfDFunUnfold as bs) + _ -> do e <- get bh + return (IfCompulsory e) + + +instance Binary IfaceExpr where + put_ bh (IfaceLcl aa) = do + putByte bh 0 + put_ bh aa + put_ bh (IfaceType ab) = do + putByte bh 1 + put_ bh ab + put_ bh (IfaceCo ab) = do + putByte bh 2 + put_ bh ab + put_ bh (IfaceTuple ac ad) = do + putByte bh 3 + put_ bh ac + put_ bh ad + put_ bh (IfaceLam ae af) = do + putByte bh 4 + put_ bh ae + put_ bh af + put_ bh (IfaceApp ag ah) = do + putByte bh 5 + put_ bh ag + put_ bh ah + put_ bh (IfaceCase ai aj ak) = do + putByte bh 6 + put_ bh ai + put_ bh aj + put_ bh ak + put_ bh (IfaceLet al am) = do + putByte bh 7 + put_ bh al + put_ bh am + put_ bh (IfaceTick an ao) = do + putByte bh 8 + put_ bh an + put_ bh ao + put_ bh (IfaceLit ap) = do + putByte bh 9 + put_ bh ap + put_ bh (IfaceFCall as at) = do + putByte bh 10 + put_ bh as + put_ bh at + put_ bh (IfaceExt aa) = do + putByte bh 11 + put_ bh aa + put_ bh (IfaceCast ie ico) = do + putByte bh 12 + put_ bh ie + put_ bh ico + put_ bh (IfaceECase a b) = do + putByte bh 13 + put_ bh a + put_ bh b + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (IfaceLcl aa) + 1 -> do ab <- get bh + return (IfaceType ab) + 2 -> do ab <- get bh + return (IfaceCo ab) + 3 -> do ac <- get bh + ad <- get bh + return (IfaceTuple ac ad) + 4 -> do ae <- get bh + af <- get bh + return (IfaceLam ae af) + 5 -> do ag <- get bh + ah <- get bh + return (IfaceApp ag ah) + 6 -> do ai <- get bh + aj <- get bh + ak <- get bh + return (IfaceCase ai aj ak) + 7 -> do al <- get bh + am <- get bh + return (IfaceLet al am) + 8 -> do an <- get bh + ao <- get bh + return (IfaceTick an ao) + 9 -> do ap <- get bh + return (IfaceLit ap) + 10 -> do as <- get bh + at <- get bh + return (IfaceFCall as at) + 11 -> do aa <- get bh + return (IfaceExt aa) + 12 -> do ie <- get bh + ico <- get bh + return (IfaceCast ie ico) + 13 -> do a <- get bh + b <- get bh + return (IfaceECase a b) + _ -> panic ("get IfaceExpr " ++ show h) + +instance Binary IfaceTickish where + put_ bh (IfaceHpcTick m ix) = do + putByte bh 0 + put_ bh m + put_ bh ix + put_ bh (IfaceSCC cc tick push) = do + putByte bh 1 + put_ bh cc + put_ bh tick + put_ bh push + + get bh = do + h <- getByte bh + case h of + 0 -> do m <- get bh + ix <- get bh + return (IfaceHpcTick m ix) + 1 -> do cc <- get bh + tick <- get bh + push <- get bh + return (IfaceSCC cc tick push) + _ -> panic ("get IfaceTickish " ++ show h) + +instance Binary IfaceConAlt where + put_ bh IfaceDefault = putByte bh 0 + put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa + put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac + get bh = do + h <- getByte bh + case h of + 0 -> return IfaceDefault + 1 -> liftM IfaceDataAlt $ get bh + _ -> liftM IfaceLitAlt $ get bh + +instance Binary IfaceBinding where + put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab + put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac + get bh = do + h <- getByte bh + case h of + 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) } + _ -> do { ac <- get bh; return (IfaceRec ac) } + +instance Binary IfaceLetBndr where + put_ bh (IfLetBndr a b c) = do + put_ bh a + put_ bh b + put_ bh c + get bh = do a <- get bh + b <- get bh + c <- get bh + return (IfLetBndr a b c) + +instance Binary IfaceTyConParent where + put_ bh IfNoParent = putByte bh 0 + put_ bh (IfDataInstance ax pr ty) = do + putByte bh 1 + put_ bh ax + put_ bh pr + put_ bh ty + get bh = do + h <- getByte bh + case h of + 0 -> return IfNoParent + _ -> do + ax <- get bh + pr <- get bh + ty <- get bh + return $ IfDataInstance ax pr ty +\end{code}
\ No newline at end of file diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index e4a789f0f5..c55edc6185 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -6,17 +6,22 @@ This module defines interface types and binders \begin{code} +{-# LANGUAGE CPP #-} module IfaceType ( IfExtName, IfLclName, IfaceType(..), IfacePredType, IfaceKind, IfaceTyCon(..), IfaceCoercion(..), - IfaceTyLit(..), - IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, + IfaceTyLit(..), IfaceTcArgs(..), + IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, -- Conversion from Type -> IfaceType - toIfaceType, toIfaceKind, toIfaceContext, - toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs, - toIfaceTyCon, toIfaceTyCon_name, + toIfaceType, toIfaceTypes, toIfaceKind, toIfaceTyVar, + toIfaceContext, toIfaceBndr, toIfaceIdBndr, + toIfaceTvBndrs, toIfaceTyCon, toIfaceTyCon_name, + toIfaceTcArgs, + + -- Conversion from IfaceTcArgs -> IfaceType + tcArgsIfaceTypes, -- Conversion from Coercion -> IfaceCoercion toIfaceCoercion, @@ -24,31 +29,40 @@ module IfaceType ( -- Printing pprIfaceType, pprParendIfaceType, pprIfaceContext, pprIfaceContextArr, pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs, - pprIfaceBndrs, - tOP_PREC, tYCON_PREC, noParens, maybeParen, pprIfaceForAllPart, - pprIfaceCoercion, pprParendIfaceCoercion - + pprIfaceBndrs, pprIfaceTcArgs, pprParendIfaceTcArgs, + pprIfaceForAllPart, pprIfaceForAll, pprIfaceSigmaType, + pprIfaceCoercion, pprParendIfaceCoercion, + splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll, + + suppressIfaceKinds, + stripIfaceKindVars, + stripKindArgs, + substIfaceType, substIfaceTyVar, substIfaceTcArgs, mkIfaceTySubst ) where +#include "HsVersions.h" + import Coercion +import DataCon ( dataConTyCon ) import TcType import DynFlags -import TypeRep hiding( maybeParen ) +import TypeRep import Unique( hasKey ) -import TyCon +import Util ( filterOut, lengthIs, zipWithEqual ) +import TyCon hiding ( pprPromotionQuote ) import CoAxiom import Id import Var +-- import RnEnv( FastStringEnv, mkFsEnv, lookupFsEnv ) import TysWiredIn import TysPrim -import PrelNames( funTyConKey ) +import PrelNames( funTyConKey, ipClassName ) import Name import BasicTypes import Binary import Outputable import FastString - -import Control.Monad +import UniqSet \end{code} %************************************************************************ @@ -77,8 +91,9 @@ data IfaceType -- A kind of universal type, used for types and kinds = IfaceTyVar IfLclName -- Type/coercion variable only, not tycon | IfaceAppTy IfaceType IfaceType | IfaceFunTy IfaceType IfaceType + | IfaceDFunTy IfaceType IfaceType | IfaceForAllTy IfaceTvBndr IfaceType - | IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated + | IfaceTyConApp IfaceTyCon IfaceTcArgs -- Not necessarily saturated -- Includes newtypes, synonyms, tuples | IfaceLitTy IfaceTyLit @@ -89,9 +104,24 @@ data IfaceTyLit = IfaceNumTyLit Integer | IfaceStrTyLit FastString --- Encodes type constructors, kind constructors --- coercion constructors, the lot -newtype IfaceTyCon = IfaceTc { ifaceTyConName :: IfExtName } +-- See Note [Suppressing kinds] +-- We use a new list type (rather than [(IfaceType,Bool)], because +-- it'll be more compact and faster to parse in interface +-- files. Rather than two bytes and two decisions (nil/cons, and +-- type/kind) there'll just be one. +data IfaceTcArgs + = ITC_Nil + | ITC_Type IfaceType IfaceTcArgs + | ITC_Kind IfaceKind IfaceTcArgs + +-- Encodes type constructors, kind constructors, +-- coercion constructors, the lot. +-- We have to tag them in order to pretty print them +-- properly. +data IfaceTyCon + = IfaceTc { ifaceTyConName :: IfExtName } + | IfacePromotedDataCon { ifaceTyConName :: IfExtName } + | IfacePromotedTyCon { ifaceTyConName :: IfExtName } data IfaceCoercion = IfaceReflCo Role IfaceType @@ -131,40 +161,167 @@ splitIfaceSigmaTy ty = case split_foralls ty of { (tvs, rho) -> (tv:tvs, rho) } split_foralls rho = ([], rho) - split_rho (IfaceFunTy ty1 ty2) - | isIfacePredTy ty1 = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) } + split_rho (IfaceDFunTy ty1 ty2) + = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) } split_rho tau = ([], tau) + +suppressIfaceKinds :: DynFlags -> [IfaceTvBndr] -> [a] -> [a] +suppressIfaceKinds dflags tys xs + | gopt Opt_PrintExplicitKinds dflags = xs + | otherwise = suppress tys xs + where + suppress _ [] = [] + suppress [] a = a + suppress (k:ks) a@(_:xs) + | isIfaceKindVar k = suppress ks xs + | otherwise = a + +stripIfaceKindVars :: DynFlags -> [IfaceTvBndr] -> [IfaceTvBndr] +stripIfaceKindVars dflags tyvars + | gopt Opt_PrintExplicitKinds dflags = tyvars + | otherwise = filterOut isIfaceKindVar tyvars + +isIfaceKindVar :: IfaceTvBndr -> Bool +isIfaceKindVar (_, IfaceTyConApp tc _) = ifaceTyConName tc == superKindTyConName +isIfaceKindVar _ = False + +ifTyVarsOfType :: IfaceType -> UniqSet IfLclName +ifTyVarsOfType ty + = case ty of + IfaceTyVar v -> unitUniqSet v + IfaceAppTy fun arg + -> ifTyVarsOfType fun `unionUniqSets` ifTyVarsOfType arg + IfaceFunTy arg res + -> ifTyVarsOfType arg `unionUniqSets` ifTyVarsOfType res + IfaceDFunTy arg res + -> ifTyVarsOfType arg `unionUniqSets` ifTyVarsOfType res + IfaceForAllTy (var,t) ty + -> delOneFromUniqSet (ifTyVarsOfType ty) var `unionUniqSets` + ifTyVarsOfType t + IfaceTyConApp _ args -> ifTyVarsOfArgs args + IfaceLitTy _ -> emptyUniqSet + +ifTyVarsOfArgs :: IfaceTcArgs -> UniqSet IfLclName +ifTyVarsOfArgs args = argv emptyUniqSet args + where + argv vs (ITC_Type t ts) = argv (vs `unionUniqSets` (ifTyVarsOfType t)) ts + argv vs (ITC_Kind k ks) = argv (vs `unionUniqSets` (ifTyVarsOfType k)) ks + argv vs ITC_Nil = vs +\end{code} + +Substitutions on IfaceType. This is only used during pretty-printing to construct +the result type of a GADT, and does not deal with binders (eg IfaceForAll), so +it doesn't need fancy capture stuff. + +\begin{code} +type IfaceTySubst = FastStringEnv IfaceType + +mkIfaceTySubst :: [IfaceTvBndr] -> [IfaceType] -> IfaceTySubst +mkIfaceTySubst tvs tys = mkFsEnv $ zipWithEqual "mkIfaceTySubst" (\(fs,_) ty -> (fs,ty)) tvs tys + +substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType +substIfaceType env ty + = go ty + where + go (IfaceTyVar tv) = substIfaceTyVar env tv + go (IfaceAppTy t1 t2) = IfaceAppTy (go t1) (go t2) + go (IfaceFunTy t1 t2) = IfaceFunTy (go t1) (go t2) + go (IfaceDFunTy t1 t2) = IfaceDFunTy (go t1) (go t2) + go ty@(IfaceLitTy {}) = ty + go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceTcArgs env tys) + go (IfaceForAllTy {}) = pprPanic "substIfaceType" (ppr ty) + +substIfaceTcArgs :: IfaceTySubst -> IfaceTcArgs -> IfaceTcArgs +substIfaceTcArgs env args + = go args + where + go ITC_Nil = ITC_Nil + go (ITC_Type ty tys) = ITC_Type (substIfaceType env ty) (go tys) + go (ITC_Kind ty tys) = ITC_Kind (substIfaceType env ty) (go tys) + +substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType +substIfaceTyVar env tv + | Just ty <- lookupFsEnv env tv = ty + | otherwise = IfaceTyVar tv \end{code} %************************************************************************ %* * - Pretty-printing + Functions over IFaceTcArgs +%* * +%************************************************************************ + + +\begin{code} +stripKindArgs :: DynFlags -> IfaceTcArgs -> IfaceTcArgs +stripKindArgs dflags tys + | gopt Opt_PrintExplicitKinds dflags = tys + | otherwise = suppressKinds tys + where + suppressKinds c + = case c of + ITC_Kind _ ts -> suppressKinds ts + _ -> c + +toIfaceTcArgs :: TyCon -> [Type] -> IfaceTcArgs +-- See Note [Suppressing kinds] +toIfaceTcArgs tc ty_args + = go (tyConKind tc) ty_args + where + go _ [] = ITC_Nil + go (ForAllTy _ res) (t:ts) = ITC_Kind (toIfaceKind t) (go res ts) + go (FunTy _ res) (t:ts) = ITC_Type (toIfaceType t) (go res ts) + go kind (t:ts) = WARN( True, ppr tc $$ ppr (tyConKind tc) $$ ppr ty_args ) + ITC_Type (toIfaceType t) (go kind ts) -- Ill-kinded + +tcArgsIfaceTypes :: IfaceTcArgs -> [IfaceType] +tcArgsIfaceTypes ITC_Nil = [] +tcArgsIfaceTypes (ITC_Kind t ts) = t : tcArgsIfaceTypes ts +tcArgsIfaceTypes (ITC_Type t ts) = t : tcArgsIfaceTypes ts +\end{code} + +Note [Suppressing kinds] +~~~~~~~~~~~~~~~~~~~~~~~~ +We use the IfaceTcArgs to specify which of the arguments to a type +constructor instantiate a for-all, and which are regular kind args. +This in turn used to control kind-suppression when printing types, +under the control of -fprint-explicit-kinds. See also TypeRep.suppressKinds. +For example, given + T :: forall k. (k->*) -> k -> * -- Ordinary kind polymorphism + 'Just :: forall k. k -> 'Maybe k -- Promoted +we want + T * Tree Int prints as T Tree Int + 'Just * prints as Just * + + +%************************************************************************ +%* * + Functions over IFaceTyCon %* * %************************************************************************ -Precedence -~~~~~~~~~~ -@ppr_ty@ takes an @Int@ that is the precedence of the context. -The precedence levels are: -\begin{description} -\item[tOP_PREC] No parens required. -\item[fUN_PREC] Left hand argument of a function arrow. -\item[tYCON_PREC] Argument of a type constructor. -\end{description} +\begin{code} +--isPromotedIfaceTyCon :: IfaceTyCon -> Bool +--isPromotedIfaceTyCon (IfacePromotedTyCon _) = True +--isPromotedIfaceTyCon _ = False +\end{code} +%************************************************************************ +%* * + Pretty-printing +%* * +%************************************************************************ \begin{code} -tOP_PREC, fUN_PREC, tYCON_PREC :: Int -tOP_PREC = 0 -- type in ParseIface.y -fUN_PREC = 1 -- btype in ParseIface.y -tYCON_PREC = 2 -- atype in ParseIface.y - -noParens :: SDoc -> SDoc -noParens pp = pp - -maybeParen :: Int -> Int -> SDoc -> SDoc -maybeParen ctxt_prec inner_prec pretty - | ctxt_prec < inner_prec = pretty - | otherwise = parens pretty +pprIfaceInfixApp :: (TyPrec -> a -> SDoc) -> TyPrec -> SDoc -> a -> a -> SDoc +pprIfaceInfixApp pp p pp_tc ty1 ty2 + = maybeParen p FunPrec $ + sep [pp FunPrec ty1, pprInfixVar True pp_tc <+> pp FunPrec ty2] + +pprIfacePrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc +pprIfacePrefixApp p pp_fun pp_tys + | null pp_tys = pp_fun + | otherwise = maybeParen p TyConPrec $ + hang pp_fun 2 (sep pp_tys) \end{code} @@ -182,9 +339,9 @@ pprIfaceIdBndr :: (IfLclName, IfaceType) -> SDoc pprIfaceIdBndr (name, ty) = hsep [ppr name, dcolon, ppr ty] pprIfaceTvBndr :: IfaceTvBndr -> SDoc -pprIfaceTvBndr (tv, IfaceTyConApp tc []) +pprIfaceTvBndr (tv, IfaceTyConApp tc ITC_Nil) | ifaceTyConName tc == liftedTypeKindTyConName = ppr tv -pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind) +pprIfaceTvBndr (tv, kind) = parens (ppr tv <+> dcolon <+> ppr kind) pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc pprIfaceTvBndrs tyvars = sep (map pprIfaceTvBndr tyvars) @@ -213,109 +370,200 @@ instance Outputable IfaceType where ppr ty = pprIfaceType ty pprIfaceType, pprParendIfaceType ::IfaceType -> SDoc -pprIfaceType = ppr_ty tOP_PREC -pprParendIfaceType = ppr_ty tYCON_PREC - -isIfacePredTy :: IfaceType -> Bool -isIfacePredTy _ = False --- FIXME: fix this to print iface pred tys correctly --- isIfacePredTy ty = isConstraintKind (ifaceTypeKind ty) +pprIfaceType = ppr_ty TopPrec +pprParendIfaceType = ppr_ty TyConPrec -ppr_ty :: Int -> IfaceType -> SDoc +ppr_ty :: TyPrec -> IfaceType -> SDoc ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -ppr_ty ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ppr_ty ctxt_prec tc tys - -ppr_ty _ (IfaceLitTy n) = ppr_tylit n - +ppr_ty ctxt_prec (IfaceTyConApp tc tys) = sdocWithDynFlags (pprTyTcApp ctxt_prec tc tys) +ppr_ty _ (IfaceLitTy n) = ppr_tylit n -- Function types ppr_ty ctxt_prec (IfaceFunTy ty1 ty2) = -- We don't want to lose synonyms, so we mustn't use splitFunTys here. - maybeParen ctxt_prec fUN_PREC $ - sep (ppr_ty fUN_PREC ty1 : ppr_fun_tail ty2) + maybeParen ctxt_prec FunPrec $ + sep [ppr_ty FunPrec ty1, sep (ppr_fun_tail ty2)] where - arr | isIfacePredTy ty1 = darrow - | otherwise = arrow - ppr_fun_tail (IfaceFunTy ty1 ty2) - = (arr <+> ppr_ty fUN_PREC ty1) : ppr_fun_tail ty2 + = (arrow <+> ppr_ty FunPrec ty1) : ppr_fun_tail ty2 ppr_fun_tail other_ty - = [arr <+> pprIfaceType other_ty] + = [arrow <+> pprIfaceType other_ty] ppr_ty ctxt_prec (IfaceAppTy ty1 ty2) - = maybeParen ctxt_prec tYCON_PREC $ - ppr_ty fUN_PREC ty1 <+> pprParendIfaceType ty2 + = maybeParen ctxt_prec TyConPrec $ + ppr_ty FunPrec ty1 <+> pprParendIfaceType ty2 -ppr_ty ctxt_prec ty@(IfaceForAllTy _ _) - = maybeParen ctxt_prec fUN_PREC (pprIfaceForAllPart tvs theta (pprIfaceType tau)) - where - (tvs, theta, tau) = splitIfaceSigmaTy ty +ppr_ty ctxt_prec ty + = maybeParen ctxt_prec FunPrec (ppr_iface_sigma_type True ty) + +instance Outputable IfaceTcArgs where + ppr tca = pprIfaceTcArgs tca + +pprIfaceTcArgs, pprParendIfaceTcArgs :: IfaceTcArgs -> SDoc +pprIfaceTcArgs = ppr_tc_args TopPrec +pprParendIfaceTcArgs = ppr_tc_args TyConPrec + +ppr_tc_args :: TyPrec -> IfaceTcArgs -> SDoc +ppr_tc_args ctx_prec args + = let pprTys t ts = ppr_ty ctx_prec t <+> ppr_tc_args ctx_prec ts + in case args of + ITC_Nil -> empty + ITC_Type t ts -> pprTys t ts + ITC_Kind t ts -> pprTys t ts ------------------- --- needs to handle type contexts and coercion contexts, hence the --- generality -pprIfaceForAllPart :: Outputable a => [IfaceTvBndr] -> [a] -> SDoc -> SDoc -pprIfaceForAllPart tvs ctxt doc - = sep [ppr_tvs, pprIfaceContextArr ctxt, doc] +ppr_iface_sigma_type :: Bool -> IfaceType -> SDoc +ppr_iface_sigma_type show_foralls_unconditionally ty + = ppr_iface_forall_part show_foralls_unconditionally tvs theta (ppr tau) where - ppr_tvs | null tvs = empty - | otherwise = sdocWithDynFlags $ \ dflags -> - if gopt Opt_PrintExplicitForalls dflags - then ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot - else empty + (tvs, theta, tau) = splitIfaceSigmaTy ty +pprIfaceForAllPart :: Outputable a => [IfaceTvBndr] -> [a] -> SDoc -> SDoc +pprIfaceForAllPart tvs ctxt sdoc = ppr_iface_forall_part False tvs ctxt sdoc + +ppr_iface_forall_part :: Outputable a + => Bool -> [IfaceTvBndr] -> [a] -> SDoc -> SDoc +ppr_iface_forall_part show_foralls_unconditionally tvs ctxt sdoc + = sep [ if show_foralls_unconditionally + then pprIfaceForAll tvs + else pprUserIfaceForAll tvs + , pprIfaceContextArr ctxt + , sdoc] + +pprIfaceForAll :: [IfaceTvBndr] -> SDoc +pprIfaceForAll [] = empty +pprIfaceForAll tvs = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot + +pprIfaceSigmaType :: IfaceType -> SDoc +pprIfaceSigmaType ty = ppr_iface_sigma_type False ty + +pprUserIfaceForAll :: [IfaceTvBndr] -> SDoc +pprUserIfaceForAll tvs + = sdocWithDynFlags $ \dflags -> + ppWhen (any tv_has_kind_var tvs || gopt Opt_PrintExplicitForalls dflags) $ + pprIfaceForAll tvs + where + tv_has_kind_var (_,t) = not (isEmptyUniqSet (ifTyVarsOfType t)) ------------------- -ppr_tc_app :: (Int -> a -> SDoc) -> Int -> IfaceTyCon -> [a] -> SDoc -ppr_tc_app _ _ tc [] = ppr_tc tc - - -ppr_tc_app pp _ (IfaceTc n) [ty] - | n == listTyConName - = brackets (pp tOP_PREC ty) - | n == parrTyConName - = paBrackets (pp tOP_PREC ty) -ppr_tc_app pp _ (IfaceTc n) tys - | Just (ATyCon tc) <- wiredInNameTyThing_maybe n - , Just sort <- tyConTuple_maybe tc - , tyConArity tc == length tys - = tupleParens sort (sep (punctuate comma (map (pp tOP_PREC) tys))) -ppr_tc_app pp ctxt_prec tc tys - = maybeParen ctxt_prec tYCON_PREC - (sep [ppr_tc tc, nest 4 (sep (map (pp tYCON_PREC) tys))]) - -ppr_tc :: IfaceTyCon -> SDoc --- Wrap infix type constructors in parens -ppr_tc tc = wrap (ifaceTyConName tc) (ppr tc) + +-- See equivalent function in TypeRep.lhs +pprIfaceTyList :: TyPrec -> IfaceType -> IfaceType -> SDoc +-- Given a type-level list (t1 ': t2), see if we can print +-- it in list notation [t1, ...]. +-- Precondition: Opt_PrintExplicitKinds is off +pprIfaceTyList ctxt_prec ty1 ty2 + = case gather ty2 of + (arg_tys, Nothing) + -> char '\'' <> brackets (fsep (punctuate comma + (map (ppr_ty TopPrec) (ty1:arg_tys)))) + (arg_tys, Just tl) + -> maybeParen ctxt_prec FunPrec $ hang (ppr_ty FunPrec ty1) + 2 (fsep [ colon <+> ppr_ty FunPrec ty | ty <- arg_tys ++ [tl]]) + where + gather :: IfaceType -> ([IfaceType], Maybe IfaceType) + -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn] + -- = (tys, Just tl) means ty is of form t1:t2:...tn:tl + gather (IfaceTyConApp tc tys) + | tcname == consDataConName + , (ITC_Kind _ (ITC_Type ty1 (ITC_Type ty2 ITC_Nil))) <- tys + , (args, tl) <- gather ty2 + = (ty1:args, tl) + | tcname == nilDataConName + = ([], Nothing) + where tcname = ifaceTyConName tc + gather ty = ([], Just ty) + +pprIfaceTypeApp :: IfaceTyCon -> IfaceTcArgs -> SDoc +pprIfaceTypeApp tc args = sdocWithDynFlags (pprTyTcApp TopPrec tc args) + +pprTyTcApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> DynFlags -> SDoc +pprTyTcApp ctxt_prec tc tys dflags + | ifaceTyConName tc == ipClassName + , ITC_Type (IfaceLitTy (IfaceStrTyLit n)) (ITC_Type ty ITC_Nil) <- tys + = char '?' <> ftext n <> ptext (sLit "::") <> ppr_ty TopPrec ty + + | ifaceTyConName tc == consDataConName + , not (gopt Opt_PrintExplicitKinds dflags) + , ITC_Kind _ (ITC_Type ty1 (ITC_Type ty2 ITC_Nil)) <- tys + = pprIfaceTyList ctxt_prec ty1 ty2 + + | otherwise + = ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds + where + tys_wo_kinds = tcArgsIfaceTypes $ stripKindArgs dflags tys + +pprIfaceCoTcApp :: TyPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc +pprIfaceCoTcApp ctxt_prec tc tys = ppr_iface_tc_app ppr_co ctxt_prec tc tys + +ppr_iface_tc_app :: (TyPrec -> a -> SDoc) -> TyPrec -> IfaceTyCon -> [a] -> SDoc +ppr_iface_tc_app pp _ tc [ty] + | n == listTyConName = pprPromotionQuote tc <> brackets (pp TopPrec ty) + | n == parrTyConName = pprPromotionQuote tc <> paBrackets (pp TopPrec ty) + where + n = ifaceTyConName tc + +ppr_iface_tc_app pp ctxt_prec tc tys + | Just (tup_sort, tup_args) <- is_tuple + = pprPromotionQuote tc <> + tupleParens tup_sort (sep (punctuate comma (map (pp TopPrec) tup_args))) + + | not (isSymOcc (nameOccName tc_name)) + = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp TyConPrec) tys) + + | [ty1,ty2] <- tys -- Infix, two arguments; + -- we know nothing of precedence though + = pprIfaceInfixApp pp ctxt_prec (ppr tc) ty1 ty2 + + | tc_name == liftedTypeKindTyConName || tc_name == unliftedTypeKindTyConName + = ppr tc -- Do not wrap *, # in parens + + | otherwise + = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp TyConPrec) tys) where - -- The kind * does not get wrapped in parens. - wrap name | name == liftedTypeKindTyConName = id - wrap name = parenSymOcc (getOccName name) + tc_name = ifaceTyConName tc + + is_tuple = case wiredInNameTyThing_maybe tc_name of + Just (ATyCon tc) + | Just sort <- tyConTuple_maybe tc + , tyConArity tc == length tys + -> Just (sort, tys) + + | Just dc <- isPromotedDataCon_maybe tc + , let dc_tc = dataConTyCon dc + , isTupleTyCon dc_tc + , let arity = tyConArity dc_tc + ty_args = drop arity tys + , ty_args `lengthIs` arity + -> Just (tupleTyConSort tc, ty_args) + + _ -> Nothing + ppr_tylit :: IfaceTyLit -> SDoc ppr_tylit (IfaceNumTyLit n) = integer n ppr_tylit (IfaceStrTyLit n) = text (show n) pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc -pprIfaceCoercion = ppr_co tOP_PREC -pprParendIfaceCoercion = ppr_co tYCON_PREC +pprIfaceCoercion = ppr_co TopPrec +pprParendIfaceCoercion = ppr_co TyConPrec -ppr_co :: Int -> IfaceCoercion -> SDoc +ppr_co :: TyPrec -> IfaceCoercion -> SDoc ppr_co _ (IfaceReflCo r ty) = angleBrackets (ppr ty) <> ppr_role r ppr_co ctxt_prec (IfaceFunCo r co1 co2) - = maybeParen ctxt_prec fUN_PREC $ - sep (ppr_co fUN_PREC co1 : ppr_fun_tail co2) + = maybeParen ctxt_prec FunPrec $ + sep (ppr_co FunPrec co1 : ppr_fun_tail co2) where ppr_fun_tail (IfaceFunCo r co1 co2) - = (arrow <> ppr_role r <+> ppr_co fUN_PREC co1) : ppr_fun_tail co2 + = (arrow <> ppr_role r <+> ppr_co FunPrec co1) : ppr_fun_tail co2 ppr_fun_tail other_co = [arrow <> ppr_role r <+> pprIfaceCoercion other_co] ppr_co _ (IfaceTyConAppCo r tc cos) - = parens (ppr_tc_app ppr_co tOP_PREC tc cos) <> ppr_role r + = parens (pprIfaceCoTcApp TopPrec tc cos) <> ppr_role r ppr_co ctxt_prec (IfaceAppCo co1 co2) - = maybeParen ctxt_prec tYCON_PREC $ - ppr_co fUN_PREC co1 <+> pprParendIfaceCoercion co2 + = maybeParen ctxt_prec TyConPrec $ + ppr_co FunPrec co1 <+> pprParendIfaceCoercion co2 ppr_co ctxt_prec co@(IfaceForAllCo _ _) - = maybeParen ctxt_prec fUN_PREC (sep [ppr_tvs, pprIfaceCoercion inner_co]) + = maybeParen ctxt_prec FunPrec (sep [ppr_tvs, pprIfaceCoercion inner_co]) where (tvs, inner_co) = split_co co ppr_tvs = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot @@ -327,16 +575,16 @@ ppr_co ctxt_prec co@(IfaceForAllCo _ _) ppr_co _ (IfaceCoVarCo covar) = ppr covar ppr_co ctxt_prec (IfaceUnivCo r ty1 ty2) - = maybeParen ctxt_prec tYCON_PREC $ + = maybeParen ctxt_prec TyConPrec $ ptext (sLit "UnivCo") <+> ppr r <+> pprParendIfaceType ty1 <+> pprParendIfaceType ty2 ppr_co ctxt_prec (IfaceInstCo co ty) - = maybeParen ctxt_prec tYCON_PREC $ + = maybeParen ctxt_prec TyConPrec $ ptext (sLit "Inst") <+> pprParendIfaceCoercion co <+> pprParendIfaceType ty ppr_co ctxt_prec (IfaceAxiomRuleCo tc tys cos) - = maybeParen ctxt_prec tYCON_PREC + = maybeParen ctxt_prec TyConPrec (sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys ++ map pprParendIfaceCoercion cos))]) ppr_co ctxt_prec co @@ -351,9 +599,9 @@ ppr_co ctxt_prec co ; IfaceSubCo co -> (ptext (sLit "Sub"), [co]) ; _ -> panic "pprIfaceCo" } -ppr_special_co :: Int -> SDoc -> [IfaceCoercion] -> SDoc +ppr_special_co :: TyPrec -> SDoc -> [IfaceCoercion] -> SDoc ppr_special_co ctxt_prec doc cos - = maybeParen ctxt_prec tYCON_PREC + = maybeParen ctxt_prec TyConPrec (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))]) ppr_role :: Role -> SDoc @@ -365,14 +613,30 @@ ppr_role r = underscore <> pp_role ------------------- instance Outputable IfaceTyCon where - ppr = ppr . ifaceTyConName + ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc) + +pprPromotionQuote :: IfaceTyCon -> SDoc +pprPromotionQuote (IfacePromotedDataCon _ ) = char '\'' +pprPromotionQuote (IfacePromotedTyCon _) = ifPprDebug (char '\'') +pprPromotionQuote _ = empty instance Outputable IfaceCoercion where ppr = pprIfaceCoercion instance Binary IfaceTyCon where - put_ bh (IfaceTc ext) = put_ bh ext - get bh = liftM IfaceTc (get bh) + put_ bh tc = + case tc of + IfaceTc n -> putByte bh 0 >> put_ bh n + IfacePromotedDataCon n -> putByte bh 1 >> put_ bh n + IfacePromotedTyCon n -> putByte bh 2 >> put_ bh n + + get bh = + do tc <- getByte bh + case tc of + 0 -> get bh >>= return . IfaceTc + 1 -> get bh >>= return . IfacePromotedDataCon + 2 -> get bh >>= return . IfacePromotedTyCon + _ -> panic ("get IfaceTyCon " ++ show tc) instance Outputable IfaceTyLit where ppr = ppr_tylit @@ -390,6 +654,27 @@ instance Binary IfaceTyLit where ; return (IfaceStrTyLit n) } _ -> panic ("get IfaceTyLit " ++ show tag) +instance Binary IfaceTcArgs where + put_ bh tk = + case tk of + ITC_Type t ts -> putByte bh 0 >> put_ bh t >> put_ bh ts + ITC_Kind t ts -> putByte bh 1 >> put_ bh t >> put_ bh ts + ITC_Nil -> putByte bh 2 + + get bh = + do c <- getByte bh + case c of + 0 -> do + t <- get bh + ts <- get bh + return $! ITC_Type t ts + 1 -> do + t <- get bh + ts <- get bh + return $! ITC_Kind t ts + 2 -> return ITC_Nil + _ -> panic ("get IfaceTcArgs " ++ show c) + ------------------- pprIfaceContextArr :: Outputable a => [a] -> SDoc -- Prints "(C a, D b) =>", including the arrow @@ -398,7 +683,7 @@ pprIfaceContextArr theta = pprIfaceContext theta <+> darrow pprIfaceContext :: Outputable a => [a] -> SDoc pprIfaceContext [pred] = ppr pred -- No parens -pprIfaceContext preds = parens (sep (punctuate comma (map ppr preds))) +pprIfaceContext preds = parens (fsep (punctuate comma (map ppr preds))) instance Binary IfaceType where put_ bh (IfaceForAllTy aa ab) = do @@ -416,6 +701,10 @@ instance Binary IfaceType where putByte bh 3 put_ bh ag put_ bh ah + put_ bh (IfaceDFunTy ag ah) = do + putByte bh 4 + put_ bh ag + put_ bh ah put_ bh (IfaceTyConApp tc tys) = do { putByte bh 5; put_ bh tc; put_ bh tys } @@ -436,9 +725,11 @@ instance Binary IfaceType where 3 -> do ag <- get bh ah <- get bh return (IfaceFunTy ag ah) + 4 -> do ag <- get bh + ah <- get bh + return (IfaceDFunTy ag ah) 5 -> do { tc <- get bh; tys <- get bh ; return (IfaceTyConApp tc tys) } - 30 -> do n <- get bh return (IfaceLitTy n) @@ -558,7 +849,7 @@ instance Binary IfaceCoercion where b <- get bh c <- get bh return $ IfaceAxiomRuleCo a b c - _ -> panic ("get IfaceCoercion " ++ show tag) + _ -> panic ("get IfaceCoercion " ++ show tag) \end{code} @@ -590,8 +881,10 @@ toIfaceType :: Type -> IfaceType -- Synonyms are retained in the interface type toIfaceType (TyVarTy tv) = IfaceTyVar (toIfaceTyVar tv) toIfaceType (AppTy t1 t2) = IfaceAppTy (toIfaceType t1) (toIfaceType t2) -toIfaceType (FunTy t1 t2) = IfaceFunTy (toIfaceType t1) (toIfaceType t2) -toIfaceType (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys) +toIfaceType (FunTy t1 t2) + | isPredTy t1 = IfaceDFunTy (toIfaceType t1) (toIfaceType t2) + | otherwise = IfaceFunTy (toIfaceType t1) (toIfaceType t2) +toIfaceType (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTcArgs tc tys) toIfaceType (LitTy n) = IfaceLitTy (toIfaceTyLit n) toIfaceType (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t) @@ -603,7 +896,11 @@ toIfaceCoVar = occNameFS . getOccName ---------------- toIfaceTyCon :: TyCon -> IfaceTyCon -toIfaceTyCon = toIfaceTyCon_name . tyConName +toIfaceTyCon tc + | isPromotedDataCon tc = IfacePromotedDataCon tc_name + | isPromotedTyCon tc = IfacePromotedTyCon tc_name + | otherwise = IfaceTc tc_name + where tc_name = tyConName tc toIfaceTyCon_name :: Name -> IfaceTyCon toIfaceTyCon_name = IfaceTc @@ -652,4 +949,3 @@ toIfaceCoercion (AxiomRuleCo co ts cs) = IfaceAxiomRuleCo (map toIfaceType ts) (map toIfaceCoercion cs) \end{code} - diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index d787794326..2be6e9d4d8 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -6,6 +6,7 @@ Loading interface files \begin{code} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module LoadIface ( -- RnM/TcM functions @@ -352,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] @@ -391,7 +392,7 @@ compiler expects. -- the declaration itself, will find the fully-glorious Name -- -- We handle ATs specially. They are not main declarations, but also not --- implict things (in particular, adding them to `implicitTyThings' would mess +-- implicit things (in particular, adding them to `implicitTyThings' would mess -- things up in the renaming/type checking of source programs). ----------------------------------------------------- @@ -416,7 +417,6 @@ loadDecl ignore_prags mod (_version, decl) = do { -- Populate the name cache with final versions of all -- the names associated with the decl main_name <- lookupOrig mod (ifName decl) --- ; traceIf (text "Loading decl for " <> ppr main_name) -- Typecheck the thing, lazily -- NB. Firstly, the laziness is there in case we never need the @@ -445,11 +445,11 @@ loadDecl ignore_prags mod (_version, decl) -- [ "MkT" -> <datacon MkT>, "x" -> <selector x>, ... ] -- (where the "MkT" is the *Name* associated with MkT, etc.) -- - -- We do this by mapping the implict_names to the associated + -- We do this by mapping the implicit_names to the associated -- TyThings. By the invariant on ifaceDeclImplicitBndrs and -- implicitTyThings, we can use getOccName on the implicit -- TyThings to make this association: each Name's OccName should - -- be the OccName of exactly one implictTyThing. So the key is + -- be the OccName of exactly one implicitTyThing. So the key is -- to define a "mini-env" -- -- [ 'MkT' -> <datacon MkT>, 'x' -> <selector x>, ... ] @@ -457,7 +457,7 @@ loadDecl ignore_prags mod (_version, decl) -- -- However, there is a subtlety: due to how type checking needs -- to be staged, we can't poke on the forkM'd thunks inside the - -- implictTyThings while building this mini-env. + -- implicitTyThings while building this mini-env. -- If we poke these thunks too early, two problems could happen: -- (1) When processing mutually recursive modules across -- hs-boot boundaries, poking too early will do the @@ -490,9 +490,11 @@ loadDecl ignore_prags mod (_version, decl) pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl)) ; implicit_names <- mapM (lookupOrig mod) (ifaceDeclImplicitBndrs decl) + +-- ; traceIf (text "Loading decl for " <> ppr main_name $$ ppr implicit_names) ; return $ (main_name, thing) : -- uses the invariant that implicit_names and - -- implictTyThings are bijective + -- implicitTyThings are bijective [(n, lookup n) | n <- implicit_names] } where @@ -571,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 @@ -751,7 +753,7 @@ pprModIface iface , vcat (map pprUsage (mi_usages iface)) , vcat (map pprIfaceAnnotation (mi_anns iface)) , pprFixities (mi_fixities iface) - , vcat (map pprIfaceDecl (mi_decls iface)) + , vcat [ppr ver $$ nest 2 (ppr decl) | (ver,decl) <- mi_decls iface] , vcat (map ppr (mi_insts iface)) , vcat (map ppr (mi_fam_insts iface)) , vcat (map ppr (mi_rules iface)) @@ -817,10 +819,6 @@ pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs, ppr_boot True = text "[boot]" ppr_boot False = empty -pprIfaceDecl :: (Fingerprint, IfaceDecl) -> SDoc -pprIfaceDecl (ver, decl) - = ppr ver $$ nest 2 (ppr decl) - pprFixities :: [(OccName, Fixity)] -> SDoc pprFixities [] = empty pprFixities fixes = ptext (sLit "fixities") <+> pprWithCommas pprFix fixes @@ -878,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 bb51cdae9d..1aba9eee44 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -4,6 +4,8 @@ % \begin{code} +{-# LANGUAGE CPP, NondecreasingIndentation #-} + -- | Module for constructing @ModIface@ values (interface files), -- writing them to disk and comparing two versions to see if -- recompilation is required. @@ -78,6 +80,7 @@ import DataCon import PatSyn import Type import TcType +import TysPrim ( alphaTyVars ) import InstEnv import FamInstEnv import TcRnMonad @@ -215,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 @@ -556,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 @@ -658,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} @@ -876,6 +879,13 @@ instOrphWarn :: DynFlags -> PrintUnqualified -> ClsInst -> WarnMsg instOrphWarn dflags unqual inst = mkWarnMsg dflags (getSrcSpan inst) unqual $ hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst) + $$ text "To avoid this" + $$ nest 4 (vcat possibilities) + where + possibilities = + text "move the instance declaration to the module of the class or of the type, or" : + text "wrap the type with a newtype and declare the instance on the new type." : + [] ruleOrphWarn :: DynFlags -> PrintUnqualified -> Module -> IfaceRule -> WarnMsg ruleOrphWarn dflags unqual mod rule @@ -979,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 } @@ -1131,27 +1141,35 @@ recompileRequired _ = True -- first element is a bool saying if we should recompile the object file -- and the second is maybe the interface file, where Nothng means to -- rebuild the interface file not use the exisitng one. -checkOldIface :: HscEnv - -> ModSummary - -> SourceModified - -> Maybe ModIface -- Old interface from compilation manager, if any - -> IO (RecompileRequired, Maybe ModIface) +checkOldIface + :: HscEnv + -> ModSummary + -> SourceModified + -> Maybe ModIface -- Old interface from compilation manager, if any + -> IO (RecompileRequired, Maybe ModIface) checkOldIface hsc_env mod_summary source_modified maybe_iface = do let dflags = hsc_dflags hsc_env showPass dflags $ - "Checking old interface for " ++ (showPpr dflags $ ms_mod mod_summary) + "Checking old interface for " ++ + (showPpr dflags $ ms_mod mod_summary) initIfaceCheck hsc_env $ check_old_iface hsc_env mod_summary source_modified maybe_iface -check_old_iface :: HscEnv -> ModSummary -> SourceModified -> Maybe ModIface - -> IfG (RecompileRequired, Maybe ModIface) +check_old_iface + :: HscEnv + -> ModSummary + -> SourceModified + -> Maybe ModIface + -> IfG (RecompileRequired, Maybe ModIface) + check_old_iface hsc_env mod_summary src_modified maybe_iface = let dflags = hsc_dflags hsc_env getIface = case maybe_iface of Just _ -> do - traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary)) + traceIf (text "We already have the old interface for" <+> + ppr (ms_mod mod_summary)) return maybe_iface Nothing -> loadIface @@ -1300,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) @@ -1329,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 } @@ -1458,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 @@ -1488,25 +1506,24 @@ dataConToIfaceDecl dataCon patSynToIfaceDecl :: PatSyn -> IfaceDecl patSynToIfaceDecl ps = IfacePatSyn { ifName = getOccName . getName $ ps - , ifPatHasWrapper = isJust $ patSynWrapper ps + , ifPatMatcher = matcher + , ifPatWrapper = wrapper , ifPatIsInfix = patSynIsInfix ps , ifPatUnivTvs = toIfaceTvBndrs univ_tvs' , ifPatExTvs = toIfaceTvBndrs ex_tvs' , ifPatProvCtxt = tidyToIfaceContext env2 prov_theta , ifPatReqCtxt = tidyToIfaceContext env2 req_theta - , ifPatArgs = map toIfaceArg args + , ifPatArgs = map (tidyToIfaceType env2) args , ifPatTy = tidyToIfaceType env2 rhs_ty } where - toIfaceArg var = (occNameFS (getOccName var), - tidyToIfaceType env2 (varType var)) - - (univ_tvs, ex_tvs, (prov_theta, req_theta)) = patSynSig ps - args = patSynArgs ps - rhs_ty = patSynType ps + (univ_tvs, ex_tvs, prov_theta, req_theta, args, rhs_ty) = patSynSig ps (env1, univ_tvs') = tidyTyVarBndrs emptyTidyEnv univ_tvs (env2, ex_tvs') = tidyTyVarBndrs env1 ex_tvs + matcher = idName (patSynMatcher ps) + wrapper = fmap idName (patSynWrapper ps) + -------------------------- coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl @@ -1517,19 +1534,19 @@ coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches = IfaceAxiom { ifName = name , ifTyCon = toIfaceTyCon tycon , ifRole = role - , ifAxBranches = brListMap (coAxBranchToIfaceBranch - emptyTidyEnv - (brListMap coAxBranchLHS branches)) branches } + , ifAxBranches = brListMap (coAxBranchToIfaceBranch tycon + (brListMap coAxBranchLHS branches)) + branches } where name = getOccName ax -- 2nd parameter is the list of branch LHSs, for conversion from incompatible branches -- to incompatible indices -- See Note [Storing compatibility] in CoAxiom -coAxBranchToIfaceBranch :: TidyEnv -> [[Type]] -> CoAxBranch -> IfaceAxBranch -coAxBranchToIfaceBranch env0 lhs_s +coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch +coAxBranchToIfaceBranch tc lhs_s branch@(CoAxBranch { cab_incomps = incomps }) - = (coAxBranchToIfaceBranch' env0 branch) { ifaxbIncomps = iface_incomps } + = (coAxBranchToIfaceBranch' tc branch) { ifaxbIncomps = iface_incomps } where iface_incomps = map (expectJust "iface_incomps" . (flip findIndex lhs_s @@ -1537,63 +1554,91 @@ coAxBranchToIfaceBranch env0 lhs_s . coAxBranchLHS) incomps -- use this one for standalone branches without incompatibles -coAxBranchToIfaceBranch' :: TidyEnv -> CoAxBranch -> IfaceAxBranch -coAxBranchToIfaceBranch' env0 - (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs - , cab_roles = roles, cab_rhs = rhs }) +coAxBranchToIfaceBranch' :: TyCon -> CoAxBranch -> IfaceAxBranch +coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs + , cab_roles = roles, cab_rhs = rhs }) = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tv_bndrs - , ifaxbLHS = map (tidyToIfaceType env1) lhs + , ifaxbLHS = tidyToIfaceTcArgs env1 tc lhs , ifaxbRoles = roles , ifaxbRHS = tidyToIfaceType env1 rhs , ifaxbIncomps = [] } where - (env1, tv_bndrs) = tidyTyClTyVarBndrs env0 tvs + (env1, tv_bndrs) = tidyTyClTyVarBndrs emptyTidyEnv tvs -- Don't re-bind in-scope tyvars -- 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 = toIfaceTvBndrs tyvars, - ifRoles = tyConRoles tycon, - ifSynRhs = to_ifsyn_rhs syn_rhs, - ifSynKind = tidyToIfaceType 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 = toIfaceTvBndrs tyvars, - ifRoles = tyConRoles tycon, - ifCtxt = tidyToIfaceContext env1 (tyConStupidTheta tycon), - ifCons = ifaceConDecls (algTyConRhs tycon), - ifRec = boolToRecFlag (isRecursiveTyCon tycon), - ifGadtSyntax = isGadtSyntaxTyCon tycon, - ifPromotable = isJust (promotableTyCon_maybe tycon), - ifAxiom = fmap coAxiomName (tyConFamilyCoercion_maybe tycon) } + = ( 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 } - - | otherwise = pprPanic "toIfaceDecl" (ppr tycon) + = (env, IfaceForeign { ifName = getOccName tycon, + ifExtName = tyConExtName tycon }) + + | otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon + -- For pretty printing purposes only. + = ( 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 - (env1, tyvars) = tidyTyClTyVarBndrs env (tyConTyVars tycon) + (tc_env1, tc_tyvars) = tidyTyClTyVarBndrs env (tyConTyVars tycon) + if_tc_tyvars = toIfaceTvBndrs tc_tyvars + + funAndPrimTyVars = toIfaceTvBndrs $ take (tyConArity tycon) alphaTyVars + + parent = case tyConFamInstSig_maybe tycon of + Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax) + (toIfaceTyCon tc) + (tidyToIfaceTcArgs tc_env1 tc ty) + Nothing -> IfNoParent + + to_ifsyn_rhs OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon + to_ifsyn_rhs (ClosedSynFamilyTyCon ax) = IfaceClosedSynFamilyTyCon axn ibr + where defs = fromBranchList $ coAxiomBranches ax + ibr = map (coAxBranchToIfaceBranch' tycon) defs + axn = coAxiomName ax + to_ifsyn_rhs AbstractClosedSynFamilyTyCon + = IfaceAbstractClosedSynFamilyTyCon - to_ifsyn_rhs OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon - to_ifsyn_rhs (ClosedSynFamilyTyCon ax) - = IfaceClosedSynFamilyTyCon (coAxiomName ax) - to_ifsyn_rhs AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon to_ifsyn_rhs (SynonymTyCon ty) - = IfaceSynonymTyCon (tidyToIfaceType env1 ty) + = IfaceSynonymTyCon (tidyToIfaceType tc_env1 ty) - to_ifsyn_rhs (BuiltInSynFamTyCon {}) = pprPanic "toIfaceDecl: BuiltInFamTyCon" (ppr tycon) + to_ifsyn_rhs (BuiltInSynFamTyCon {}) + = IfaceBuiltInSynFamTyCon ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) @@ -1609,23 +1654,28 @@ tyConToIfaceDecl env tycon = IfCon { ifConOcc = getOccName (dataConName data_con), ifConInfix = dataConIsInfix data_con, ifConWrapper = isJust (dataConWrapId_maybe data_con), - ifConUnivTvs = toIfaceTvBndrs univ_tvs', ifConExTvs = toIfaceTvBndrs ex_tvs', - ifConEqSpec = to_eq_spec eq_spec, - ifConCtxt = tidyToIfaceContext env2 theta, - ifConArgTys = map (tidyToIfaceType env2) arg_tys, + ifConEqSpec = map to_eq_spec eq_spec, + ifConCtxt = tidyToIfaceContext con_env2 theta, + ifConArgTys = map (tidyToIfaceType con_env2) arg_tys, ifConFields = map getOccName (dataConFieldLabels data_con), - ifConStricts = map (toIfaceBang env2) (dataConRepBangs data_con) } + ifConStricts = map (toIfaceBang con_env2) (dataConRepBangs data_con) } where (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con - -- Start with 'emptyTidyEnv' not 'env1', because the type of the - -- data constructor is fully standalone - (env1, univ_tvs') = tidyTyVarBndrs emptyTidyEnv univ_tvs - (env2, ex_tvs') = tidyTyVarBndrs env1 ex_tvs - to_eq_spec spec = [ (getOccName (tidyTyVar env2 tv), tidyToIfaceType env2 ty) - | (tv,ty) <- spec] + -- Tidy the univ_tvs of the data constructor to be identical + -- to the tyConTyVars of the type constructor. This means + -- (a) we don't need to redundantly put them into the interface file + -- (b) when pretty-printing an Iface data declaration in H98-style syntax, + -- we know that the type variables will line up + -- The latter (b) is important because we pretty-print type construtors + -- by converting to IfaceSyn and pretty-printing that + con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars)) + -- A bit grimy, perhaps, but it's simple! + + (con_env2, ex_tvs') = tidyTyVarBndrs con_env1 ex_tvs + to_eq_spec (tv,ty) = (toIfaceTyVar (tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty) toIfaceBang :: TidyEnv -> HsBang -> IfaceBang toIfaceBang _ HsNoBang = IfNoBang @@ -1634,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 getOccName (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 @@ -1653,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' env1) 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) @@ -1680,6 +1733,9 @@ classToIfaceDecl env clas tidyToIfaceType :: TidyEnv -> Type -> IfaceType tidyToIfaceType env ty = toIfaceType (tidyType env ty) +tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceTcArgs +tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys) + tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext tidyToIfaceContext env theta = map (tidyToIfaceType env) theta diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index cc45648ea2..68f9e8fd65 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -6,14 +6,15 @@ Type checking of type signatures in interface files \begin{code} +{-# LANGUAGE CPP #-} + module TcIface ( tcLookupImported_maybe, importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, tcIfaceVectInfo, tcIfaceAnnotations, tcIfaceExpr, -- Desired by HERMIT (Trac #7683) - tcIfaceGlobal, - tcExtCoreBindings + tcIfaceGlobal ) where #include "HsVersions.h" @@ -343,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 @@ -451,41 +460,26 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name, ifCtxt = ctxt, ifGadtSyntax = gadt_syn, ifCons = rdr_cons, ifRec = is_rec, ifPromotable = is_prom, - ifAxiom = mb_axiom_name }) + ifParent = mb_parent }) = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name ; tycon <- fixM $ \ tycon -> do { stupid_theta <- tcIfaceCtxt ctxt - ; parent' <- tc_parent tyvars mb_axiom_name + ; parent' <- tc_parent mb_parent ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons ; return (buildAlgTyCon tc_name tyvars roles cType stupid_theta cons is_rec is_prom gadt_syn parent') } ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) } where - tc_parent :: [TyVar] -> Maybe Name -> IfL TyConParent - tc_parent _ Nothing = return parent - tc_parent tyvars (Just ax_name) + tc_parent :: IfaceTyConParent -> IfL TyConParent + tc_parent IfNoParent = return parent + tc_parent (IfDataInstance ax_name _ arg_tys) = ASSERT( isNoParent parent ) do { ax <- tcIfaceCoAxiom ax_name - ; let fam_tc = coAxiomTyCon ax + ; let fam_tc = coAxiomTyCon ax ax_unbr = toUnbranchedAxiom ax - -- data families don't have branches: - branch = coAxiomSingleBranch ax_unbr - ax_tvs = coAxBranchTyVars branch - ax_lhs = coAxBranchLHS branch - tycon_tys = mkTyVarTys tyvars - subst = mkTopTvSubst (ax_tvs `zip` tycon_tys) - -- The subst matches the tyvar of the TyCon - -- with those from the CoAxiom. They aren't - -- necessarily the same, since the two may be - -- gotten from separate interface-file declarations - -- NB: ax_tvs may be shorter because of eta-reduction - -- See Note [Eta reduction for data family axioms] in TcInstDcls - lhs_tys = substTys subst ax_lhs `chkAppend` - dropList ax_tvs tycon_tys - -- The 'lhs_tys' should be 1-1 with the 'tyvars' - -- but ax_tvs maybe shorter because of eta-reduction + ; lhs_tys <- tcIfaceTcArgs arg_tys ; return (FamInstTyCon ax_unbr fam_tc lhs_tys) } tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, @@ -502,12 +496,14 @@ tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, where mk_doc n = ptext (sLit "Type syonym") <+> ppr n tc_syn_rhs IfaceOpenSynFamilyTyCon = return OpenSynFamilyTyCon - tc_syn_rhs (IfaceClosedSynFamilyTyCon ax_name) + tc_syn_rhs (IfaceClosedSynFamilyTyCon ax_name _) = do { ax <- tcIfaceCoAxiom ax_name ; return (ClosedSynFamilyTyCon ax) } tc_syn_rhs IfaceAbstractClosedSynFamilyTyCon = return AbstractClosedSynFamilyTyCon tc_syn_rhs (IfaceSynonymTyCon ty) = do { rhs_ty <- tcIfaceType ty ; return (SynonymTyCon rhs_ty) } + tc_syn_rhs IfaceBuiltInSynFamTyCon = pprPanic "tc_iface_decl" + (ptext (sLit "IfaceBuiltInSynFamTyCon in interface file")) tc_iface_decl _parent ignore_prags (IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ, @@ -524,11 +520,11 @@ tc_iface_decl _parent ignore_prags ; sigs <- mapM tc_sig rdr_sigs ; fds <- mapM tc_fd rdr_fds ; traceIf (text "tc-iface-class3" <+> ppr tc_occ) - ; mindef <- traverse lookupIfaceTop mindef_occ + ; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ ; cls <- fixM $ \ cls -> do { ats <- mapM (tc_at cls) rdr_ats ; traceIf (text "tc-iface-class4" <+> ppr tc_occ) - ; buildClass ignore_prags tc_name tyvars roles ctxt fds ats sigs mindef tc_isrec } + ; buildClass tc_name tyvars roles ctxt fds ats sigs mindef tc_isrec } ; return (ATyCon (classTyCon cls)) } where tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred) @@ -548,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 tc 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 @@ -573,7 +574,7 @@ tc_iface_decl _ _ (IfaceAxiom { ifName = ax_occ, ifTyCon = tc , ifAxBranches = branches, ifRole = role }) = do { tc_name <- lookupIfaceTop ax_occ ; tc_tycon <- tcIfaceTyCon tc - ; tc_branches <- tc_ax_branches tc_tycon branches + ; tc_branches <- tc_ax_branches branches ; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name , co_ax_name = tc_name , co_ax_tc = tc_tycon @@ -583,7 +584,8 @@ tc_iface_decl _ _ (IfaceAxiom { ifName = ax_occ, ifTyCon = tc ; return (ACoAxiom axiom) } tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name - , ifPatHasWrapper = has_wrapper + , ifPatMatcher = matcher_name + , ifPatWrapper = wrapper_name , ifPatIsInfix = is_infix , ifPatUnivTvs = univ_tvs , ifPatExTvs = ex_tvs @@ -593,31 +595,35 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name , ifPatTy = pat_ty }) = do { name <- lookupIfaceTop occ_name ; traceIf (ptext (sLit "tc_iface_decl") <+> ppr name) + ; matcher <- tcExt "Matcher" matcher_name + ; wrapper <- case wrapper_name of + Nothing -> return Nothing + Just wn -> do { wid <- tcExt "Wrapper" wn + ; return (Just wid) } ; bindIfaceTyVars univ_tvs $ \univ_tvs -> do { bindIfaceTyVars ex_tvs $ \ex_tvs -> do - { bindIfaceIdVars args $ \args -> do - { ~(prov_theta, req_theta, pat_ty) <- forkM (mk_doc name) $ + { patsyn <- forkM (mk_doc name) $ do { prov_theta <- tcIfaceCtxt prov_ctxt ; req_theta <- tcIfaceCtxt req_ctxt ; pat_ty <- tcIfaceType pat_ty - ; return (prov_theta, req_theta, pat_ty) } - ; bindIfaceTyVar (fsLit "r", toIfaceKind liftedTypeKind) $ \tv -> do - { patsyn <- buildPatSyn name is_infix has_wrapper args univ_tvs ex_tvs prov_theta req_theta pat_ty tv - ; return (AConLike (PatSynCon patsyn)) }}}}} + ; arg_tys <- mapM tcIfaceType args + ; return $ buildPatSyn name is_infix matcher wrapper + arg_tys univ_tvs ex_tvs prov_theta req_theta pat_ty } + ; return $ AConLike . PatSynCon $ patsyn }}} where mk_doc n = ptext (sLit "Pattern synonym") <+> ppr n + tcExt s name = forkM (ptext (sLit s) <+> ppr name) $ tcIfaceExtId name +tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch] +tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches -tc_ax_branches :: TyCon -> [IfaceAxBranch] -> IfL [CoAxBranch] -tc_ax_branches tc if_branches = foldlM (tc_ax_branch (tyConKind tc)) [] if_branches - -tc_ax_branch :: Kind -> [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch] -tc_ax_branch tc_kind prev_branches +tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch] +tc_ax_branch prev_branches (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbLHS = lhs, ifaxbRHS = rhs , ifaxbRoles = roles, ifaxbIncomps = incomps }) = bindIfaceTyVars_AT tv_bndrs $ \ tvs -> do -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom - { tc_lhs <- tcIfaceTcArgs tc_kind lhs -- See Note [Checking IfaceTypes vs IfaceKinds] + { tc_lhs <- tcIfaceTcArgs lhs -- See Note [Checking IfaceTypes vs IfaceKinds] ; tc_rhs <- tcIfaceType rhs ; let br = CoAxBranch { cab_loc = noSrcSpan , cab_tvs = tvs @@ -628,7 +634,7 @@ tc_ax_branch tc_kind prev_branches ; return (prev_branches ++ [br]) } tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs -tcIfaceDataCons tycon_name tycon _ if_cons +tcIfaceDataCons tycon_name tycon tc_tyvars if_cons = case if_cons of IfAbstractTyCon dis -> return (AbstractTyCon dis) IfDataFamTyCon -> return DataFamilyTyCon @@ -638,11 +644,12 @@ tcIfaceDataCons tycon_name tycon _ if_cons ; mkNewTyConRhs tycon_name tycon data_con } where tc_con_decl (IfCon { ifConInfix = is_infix, - ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs, + ifConExTvs = ex_tvs, ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec, ifConArgTys = args, ifConFields = field_lbls, ifConStricts = if_stricts}) - = bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do + = -- Universally-quantified tyvars are shared with + -- parent TyCon, and are alrady in scope bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do { traceIf (text "Start interface-file tc_con_decl" <+> ppr occ) ; name <- lookupIfaceTop occ @@ -664,12 +671,12 @@ tcIfaceDataCons tycon_name tycon _ if_cons -- Remember, tycon is the representation tycon ; let orig_res_ty = mkFamilyTyConApp tycon - (substTyVars (mkTopTvSubst eq_spec) univ_tyvars) + (substTyVars (mkTopTvSubst eq_spec) tc_tyvars) ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr name)) name is_infix stricts lbl_names - univ_tyvars ex_tyvars + tc_tyvars ex_tyvars eq_spec theta arg_tys orig_res_ty tycon ; traceIf (text "Done interface-file tc_con_decl" <+> ppr name) @@ -682,11 +689,11 @@ tcIfaceDataCons tycon_name tycon _ if_cons tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co ; return (HsUnpack (Just co)) } -tcIfaceEqSpec :: [(OccName, IfaceType)] -> IfL [(TyVar, Type)] +tcIfaceEqSpec :: IfaceEqSpec -> IfL [(TyVar, Type)] tcIfaceEqSpec spec = mapM do_item spec where - do_item (occ, if_ty) = do { tv <- tcIfaceTyVar (occNameFS occ) + do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ ; ty <- tcIfaceType if_ty ; return (tv,ty) } \end{code} @@ -957,25 +964,38 @@ tcIfaceType :: IfaceType -> IfL Type tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) } tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') } tcIfaceType (IfaceLitTy l) = do { l1 <- tcIfaceTyLit l; return (LitTy l1) } -tcIfaceType (IfaceFunTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') } +tcIfaceType (IfaceFunTy t1 t2) = tcIfaceTypeFun t1 t2 +tcIfaceType (IfaceDFunTy t1 t2) = tcIfaceTypeFun t1 t2 tcIfaceType (IfaceTyConApp tc tks) = do { tc' <- tcIfaceTyCon tc - ; tks' <- tcIfaceTcArgs (tyConKind tc') tks + ; tks' <- tcIfaceTcArgs tks ; return (mkTyConApp tc' tks') } tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') } -tcIfaceTypes :: [IfaceType] -> IfL [Type] -tcIfaceTypes tys = mapM tcIfaceType tys - -tcIfaceTcArgs :: Kind -> [IfaceType] -> IfL [Type] -tcIfaceTcArgs _ [] - = return [] -tcIfaceTcArgs kind (tk:tks) - = case splitForAllTy_maybe kind of - Nothing -> tcIfaceTypes (tk:tks) - Just (_, kind') -> do { k' <- tcIfaceKind tk - ; tks' <- tcIfaceTcArgs kind' tks - ; return (k':tks') } - +tcIfaceTypeFun :: IfaceType -> IfaceType -> IfL Type +tcIfaceTypeFun t1 t2 = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') } + +tcIfaceKind :: IfaceKind -> IfL Type +tcIfaceKind (IfaceAppTy t1 t2) = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (AppTy t1' t2') } +tcIfaceKind (IfaceFunTy t1 t2) = tcIfaceKindFun t1 t2 +tcIfaceKind (IfaceDFunTy t1 t2) = tcIfaceKindFun t1 t2 +tcIfaceKind (IfaceLitTy l) = pprPanic "tcIfaceKind" (ppr l) +tcIfaceKind k = tcIfaceType k + +tcIfaceKindFun :: IfaceKind -> IfaceKind -> IfL Type +tcIfaceKindFun t1 t2 = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (FunTy t1' t2') } + +tcIfaceTcArgs :: IfaceTcArgs -> IfL [Type] +tcIfaceTcArgs args + = case args of + ITC_Type t ts -> + do { t' <- tcIfaceType t + ; ts' <- tcIfaceTcArgs ts + ; return (t':ts') } + ITC_Kind k ks -> + do { k' <- tcIfaceKind k + ; ks' <- tcIfaceTcArgs ks + ; return (k':ks') } + ITC_Nil -> return [] ----------------------------------------- tcIfaceCtxt :: IfaceContext -> IfL ThetaType tcIfaceCtxt sts = mapM tcIfaceType sts @@ -984,43 +1004,8 @@ tcIfaceCtxt sts = mapM tcIfaceType sts tcIfaceTyLit :: IfaceTyLit -> IfL TyLit tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n) tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n) - ------------------------------------------ -tcIfaceKind :: IfaceKind -> IfL Kind -- See Note [Checking IfaceTypes vs IfaceKinds] -tcIfaceKind (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) } -tcIfaceKind (IfaceAppTy t1 t2) = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (AppTy t1' t2') } -tcIfaceKind (IfaceFunTy t1 t2) = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (FunTy t1' t2') } -tcIfaceKind (IfaceTyConApp tc ts) = do { tc' <- tcIfaceKindCon tc; ts' <- tcIfaceKinds ts; return (mkTyConApp tc' ts') } -tcIfaceKind (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceKind t; return (ForAllTy tv' t') } -tcIfaceKind t = pprPanic "tcIfaceKind" (ppr t) -- IfaceCoApp, IfaceLitTy - -tcIfaceKinds :: [IfaceKind] -> IfL [Kind] -tcIfaceKinds tys = mapM tcIfaceKind tys \end{code} -Note [Checking IfaceTypes vs IfaceKinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to know whether we are checking a *type* or a *kind*. -Consider module M where - Proxy :: forall k. k -> * - data T = T -and consider the two IfaceTypes - M.Proxy * M.T{tc} - M.Proxy 'M.T{tc} 'M.T(d} -The first is conventional, but in the latter we use the promoted -type constructor (as a kind) and data constructor (as a type). However, -the Name of the promoted type constructor is just M.T; it's the *same name* -as the ordinary type constructor. - -We could add a "promoted" flag to an IfaceTyCon, but that's a bit heavy. -Instead we use context to distinguish, as in the source language. - - When checking a kind, we look up M.T{tc} and promote it - - When checking a type, we look up M.T{tc} and don't promote it - and M.T{d} and promote it - See tcIfaceKindCon and tcIfaceKTyCon respectively - -This context business is why we need tcIfaceTcArgs, and tcIfaceApps - %************************************************************************ %* * @@ -1186,7 +1171,7 @@ tcIfaceApps fun arg go_up fun _ [] = return fun go_up fun fun_ty (IfaceType t : args) | Just (tv,body_ty) <- splitForAllTy_maybe fun_ty - = do { t' <- if isKindVar tv -- See Note [Checking IfaceTypes vs IfaceKinds] + = do { t' <- if isKindVar tv then tcIfaceKind t else tcIfaceType t ; let fun_ty' = substTyWith [tv] [t'] body_ty @@ -1251,30 +1236,6 @@ tcIfaceDataAlt con inst_tys arg_strs rhs \end{code} -\begin{code} -tcExtCoreBindings :: [IfaceBinding] -> IfL CoreProgram -- Used for external core -tcExtCoreBindings [] = return [] -tcExtCoreBindings (b:bs) = do_one b (tcExtCoreBindings bs) - -do_one :: IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind] -do_one (IfaceNonRec bndr rhs) thing_inside - = do { rhs' <- tcIfaceExpr rhs - ; bndr' <- newExtCoreBndr bndr - ; extendIfaceIdEnv [bndr'] $ do - { core_binds <- thing_inside - ; return (NonRec bndr' rhs' : core_binds) }} - -do_one (IfaceRec pairs) thing_inside - = do { bndrs' <- mapM newExtCoreBndr bndrs - ; extendIfaceIdEnv bndrs' $ do - { rhss' <- mapM tcIfaceExpr rhss - ; core_binds <- thing_inside - ; return (Rec (bndrs' `zip` rhss') : core_binds) }} - where - (bndrs,rhss) = unzip pairs -\end{code} - - %************************************************************************ %* * IdInfo @@ -1457,26 +1418,19 @@ tcIfaceGlobal name -- emasculated form (e.g. lacking data constructors). tcIfaceTyCon :: IfaceTyCon -> IfL TyCon -tcIfaceTyCon (IfaceTc name) - = do { thing <- tcIfaceGlobal name - ; case thing of -- A "type constructor" can be a promoted data constructor - -- c.f. Trac #5881 - ATyCon tc -> return tc - AConLike (RealDataCon dc) -> return (promoteDataCon dc) - _ -> pprPanic "tcIfaceTyCon" (ppr name $$ ppr thing) } - -tcIfaceKindCon :: IfaceTyCon -> IfL TyCon -tcIfaceKindCon (IfaceTc name) - = do { thing <- tcIfaceGlobal name - ; case thing of -- A "type constructor" here is a promoted type constructor - -- c.f. Trac #5881 - ATyCon tc - | isSuperKind (tyConKind tc) - -> return tc -- Mainly just '*' or 'AnyK' - | Just prom_tc <- promotableTyCon_maybe tc - -> return prom_tc - - _ -> pprPanic "tcIfaceKindCon" (ppr name $$ ppr thing) } +tcIfaceTyCon itc + = do { + ; thing <- tcIfaceGlobal (ifaceTyConName itc) + ; case itc of + IfaceTc _ -> return $ tyThingTyCon thing + IfacePromotedDataCon _ -> return $ promoteDataCon $ tyThingDataCon thing + IfacePromotedTyCon name -> + let ktycon tc + | isSuperKind (tyConKind tc) = return tc + | Just prom_tc <- promotableTyCon_maybe tc = return prom_tc + | otherwise = pprPanic "tcIfaceTyCon" (ppr name $$ ppr thing) + in ktycon (tyThingTyCon thing) + } tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched) tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name @@ -1519,14 +1473,6 @@ bindIfaceBndrs (b:bs) thing_inside thing_inside (b':bs') ----------------------- -newExtCoreBndr :: IfaceLetBndr -> IfL Id -newExtCoreBndr (IfLetBndr var ty _) -- Ignoring IdInfo for now - = do { mod <- getIfModule - ; name <- newGlobalBinder mod (mkVarOccFS var) noSrcSpan - ; ty' <- tcIfaceType ty - ; return (mkLocalId name ty') } - ------------------------ bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a bindIfaceTyVar (occ,kind) thing_inside = do { name <- newIfaceName (mkTyVarOccFS occ) @@ -1547,22 +1493,8 @@ bindIfaceTyVars bndrs thing_inside where (occs,kinds) = unzip bndrs -bindIfaceIdVar :: IfaceIdBndr -> (Id -> IfL a) -> IfL a -bindIfaceIdVar (occ, ty) thing_inside - = do { name <- newIfaceName (mkVarOccFS occ) - ; ty' <- tcIfaceType ty - ; let id = mkLocalId name ty' - ; extendIfaceIdEnv [id] (thing_inside id) } - -bindIfaceIdVars :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a -bindIfaceIdVars [] thing_inside = thing_inside [] -bindIfaceIdVars (v:vs) thing_inside - = bindIfaceIdVar v $ \ v' -> - bindIfaceIdVars vs $ \ vs' -> - thing_inside (v':vs') - isSuperIfaceKind :: IfaceKind -> Bool -isSuperIfaceKind (IfaceTyConApp (IfaceTc n) []) = n == superKindTyConName +isSuperIfaceKind (IfaceTyConApp tc ITC_Nil) = ifaceTyConName tc == superKindTyConName isSuperIfaceKind _ = False mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar 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 b8343ceff3..73077257f8 100644 --- a/compiler/llvmGen/Llvm/PpLlvm.hs +++ b/compiler/llvmGen/Llvm/PpLlvm.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -------------------------------------------------------------------------------- -- | Pretty print LLVM IR Code. -- @@ -237,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 @@ -325,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/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs index 6b9c8c181a..89b0e4e141 100644 --- a/compiler/llvmGen/Llvm/Types.hs +++ b/compiler/llvmGen/Llvm/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} -------------------------------------------------------------------------------- -- | The LLVM Type System. diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index d0f343fa92..dd16e52868 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -1,7 +1,8 @@ +{-# LANGUAGE CPP, TypeFamilies #-} + -- ----------------------------------------------------------------------------- -- | This is the top-level module in the LLVM code generator. -- - module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where #include "HsVersions.h" diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 5d5f385ade..50cd824b24 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- ---------------------------------------------------------------------------- -- | Base LLVM Code Generation module -- @@ -404,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 808c591d92..2673eed6b8 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -1,9 +1,8 @@ -{-# OPTIONS -fno-warn-type-defaults #-} +{-# LANGUAGE CPP, GADTs #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} -- ---------------------------------------------------------------------------- -- | Handle conversion of CmmProc to LLVM code. -- - -{-# LANGUAGE GADTs #-} module LlvmCodeGen.CodeGen ( genLlvmProc ) where #include "HsVersions.h" @@ -16,6 +15,7 @@ import BlockId import CodeGen.Platform ( activeStgRegs, callerSaves ) import CLabel import Cmm +import CPrim import PprCmm import CmmUtils import Hoopl @@ -33,6 +33,7 @@ import Unique import Data.List ( nub ) import Data.Maybe ( catMaybes ) +type Atomic = Bool type LlvmStatements = OrdList LlvmStatement -- ----------------------------------------------------------------------------- @@ -223,12 +224,28 @@ genCall t@(PrimTarget (MO_Prefetch_Data localityInt)) [] args return (stmts, top1 ++ top2) | otherwise = panic $ "prefetch locality level integer must be between 0 and 3, given: " ++ (show localityInt) --- Handle PopCnt and BSwap that need to only convert arg and return types +-- Handle PopCnt, Clz, Ctz, and BSwap that need to only convert arg +-- and return types genCall t@(PrimTarget (MO_PopCnt w)) dsts args = genCallSimpleCast w t dsts args +genCall t@(PrimTarget (MO_Clz w)) dsts args = + genCallSimpleCast w t dsts args +genCall t@(PrimTarget (MO_Ctz w)) dsts args = + genCallSimpleCast w t 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' @@ -546,10 +563,11 @@ cmmPrimOpFunctions mop = do (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ showSDoc dflags (ppr $ widthToLlvmInt w) (MO_BSwap w) -> fsLit $ "llvm.bswap." ++ showSDoc dflags (ppr $ widthToLlvmInt w) + (MO_Clz w) -> fsLit $ "llvm.ctlz." ++ showSDoc dflags (ppr $ widthToLlvmInt w) + (MO_Ctz w) -> fsLit $ "llvm.cttz." ++ showSDoc dflags (ppr $ widthToLlvmInt w) (MO_Prefetch_Data _ )-> fsLit "llvm.prefetch" - MO_S_QuotRem {} -> unsupported MO_U_QuotRem {} -> unsupported MO_U_QuotRem2 {} -> unsupported @@ -559,6 +577,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 @@ -805,7 +829,7 @@ genSwitch cond maybe_ids = do let pairs = [ (ix, id) | (ix,Just id) <- zip [0..] maybe_ids ] let labels = map (\(ix, b) -> (mkIntLit ty ix, blockIdToLlvm b)) pairs - -- out of range is undefied, so lets just branch to first label + -- out of range is undefined, so let's just branch to first label let (_, defLbl) = head labels let s1 = Switch vc defLbl labels @@ -850,7 +874,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. @@ -1002,8 +1026,8 @@ genMachOp _ op [x] = case op of sameConv from ty reduce expand = do x'@(vx, stmts, top) <- exprToVar x let sameConv' op = do - (v1, s1) <- doExpr ty $ Cast op vx ty - return (v1, stmts `snocOL` s1, top) + (v1, s1) <- doExpr ty $ Cast op vx ty + return (v1, stmts `snocOL` s1, top) dflags <- getDynFlags let toWidth = llvmWidthInBits dflags ty -- LLVM doesn't like trying to convert to same width, so @@ -1269,41 +1293,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 @@ -1316,7 +1340,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, []) @@ -1324,32 +1348,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 @@ -1358,6 +1384,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/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs index 6212cfc9fb..1dbfb4b527 100644 --- a/compiler/llvmGen/LlvmCodeGen/Data.hs +++ b/compiler/llvmGen/LlvmCodeGen/Data.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- ---------------------------------------------------------------------------- -- | Handle conversion of CmmData to LLVM code. -- diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index 202e685c0e..9c6a719613 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -1,7 +1,8 @@ +{-# LANGUAGE CPP #-} + -- ---------------------------------------------------------------------------- -- | Pretty print helpers for the LLVM Code generator. -- - module LlvmCodeGen.Ppr ( pprLlvmHeader, pprLlvmCmmDecl, pprLlvmData, infoSection, iTableSuf ) where diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs index 9f20aa5de5..0048659069 100644 --- a/compiler/llvmGen/LlvmCodeGen/Regs.hs +++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -------------------------------------------------------------------------------- -- | Deal with Cmm registers -- diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs index a9054174e1..8652a890cf 100644 --- a/compiler/llvmGen/LlvmMangler.hs +++ b/compiler/llvmGen/LlvmMangler.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- ----------------------------------------------------------------------------- -- | GHC LLVM Mangler -- @@ -56,13 +58,23 @@ llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-} do hClose w return () +-- | This rewrites @.type@ annotations of function symbols to @%object@. +-- This is done as the linker can relocate @%functions@ through the +-- Procedure Linking Table (PLT). This is bad since we expect that the +-- info table will appear directly before the symbol's location. In the +-- case that the PLT is used, this will be not an info table but instead +-- some random PLT garbage. rewriteSymType :: B.ByteString -> B.ByteString rewriteSymType s = - foldl (\s' (typeFunc,typeObj)->replace typeFunc typeObj s') s types + B.unlines $ map (rewrite '@' . rewrite '%') $ B.lines s where - types = [ (B.pack "@function", B.pack "@object") - , (B.pack "%function", B.pack "%object") - ] + rewrite :: Char -> B.ByteString -> B.ByteString + rewrite prefix x + | isType x = replace funcType objType x + | otherwise = x + where + funcType = prefix `B.cons` B.pack "function" + objType = prefix `B.cons` B.pack "object" -- | Splits the file contents into its sections readSections :: Handle -> Handle -> IO [Section] diff --git a/compiler/main/BreakArray.hs b/compiler/main/BreakArray.hs index d16d6f229d..6455912b67 100644 --- a/compiler/main/BreakArray.hs +++ b/compiler/main/BreakArray.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} + ------------------------------------------------------------------------------- -- -- | Break Arrays in the IO monad diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs index 22811d44cc..5ee7086cbc 100644 --- a/compiler/main/CmdLineParser.hs +++ b/compiler/main/CmdLineParser.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ------------------------------------------------------------------------------- -- -- | Command-line parser diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index b8b187241b..72803c0d6b 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -4,6 +4,8 @@ \section{Code output phase} \begin{code} +{-# LANGUAGE CPP #-} + module CodeOutput( codeOutput, outputForeignStubs ) where #include "HsVersions.h" @@ -48,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-})) @@ -72,7 +74,6 @@ codeOutput dflags this_mod filenm location foreign_stubs pkg_deps cmm_stream ; return cmm } - ; showPass dflags "CodeOutput" ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs ; case hscTarget dflags of { HscAsm -> outputAsm dflags this_mod filenm linted_cmm_stream; @@ -99,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 @@ -114,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 = @@ -123,8 +124,7 @@ outputC dflags filenm cmm_stream packages '<':_ -> "#include "++h_file _ -> "#include \""++h_file++"\"" - pkg_configs <- getPreloadPackagesAnd dflags packages - let pkg_names = map (display.sourcePackageId) pkg_configs + let pkg_names = map packageKeyString packages doOutput filenm $ \ h -> do hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") @@ -190,11 +190,8 @@ outputForeignStubs dflags mod location stubs stub_c <- newTempName dflags "c" case stubs of - NoStubs -> do - -- When compiling External Core files, may need to use stub - -- files from a previous compilation - stub_h_exists <- doesFileExist stub_h - return (stub_h_exists, Nothing) + NoStubs -> + return (False, Nothing) ForeignStubs h_code c_code -> do let @@ -212,7 +209,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/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs index cda0b4729f..03545d4828 100644 --- a/compiler/main/DriverMkDepend.hs +++ b/compiler/main/DriverMkDepend.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Makefile Dependency Generation diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs index c406f6ad0d..fa8b2d060f 100644 --- a/compiler/main/DriverPhases.hs +++ b/compiler/main/DriverPhases.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- $Id: DriverPhases.hs,v 1.38 2005/05/17 11:01:59 simonmar Exp $ -- @@ -18,7 +20,6 @@ module DriverPhases ( isHaskellSrcSuffix, isObjectSuffix, isCishSuffix, - isExtCoreSuffix, isDynLibSuffix, isHaskellUserSrcSuffix, isSourceSuffix, @@ -27,7 +28,6 @@ module DriverPhases ( isHaskellSrcFilename, isObjectFilename, isCishFilename, - isExtCoreFilename, isDynLibFilename, isHaskellUserSrcFilename, isSourceFilename @@ -56,7 +56,7 @@ import System.FilePath -} data HscSource - = HsSrcFile | HsBootFile | ExtCoreFile + = HsSrcFile | HsBootFile deriving( Eq, Ord, Show ) -- Ord needed for the finite maps we build in CompManager @@ -64,7 +64,6 @@ data HscSource hscSourceString :: HscSource -> String hscSourceString HsSrcFile = "" hscSourceString HsBootFile = "[boot]" -hscSourceString ExtCoreFile = "[ext core]" isHsBoot :: HscSource -> Bool isHsBoot HsBootFile = True @@ -82,7 +81,7 @@ data Phase | HCc -- Haskellised C (as opposed to vanilla C) compilation | Splitter -- Assembly file splitter (part of '-split-objs') | SplitAs -- Assembler for split assembly files (part of '-split-objs') - | As -- Assembler for regular assembly files + | As Bool -- Assembler for regular assembly files (Bool: with-cpp) | LlvmOpt -- Run LLVM opt tool over llvm assembly | LlvmLlc -- LLVM bitcode to native assembly | LlvmMangle -- Fix up TNTC by processing assembly produced by LLVM @@ -119,7 +118,7 @@ eqPhase Cobjcpp Cobjcpp = True eqPhase HCc HCc = True eqPhase Splitter Splitter = True eqPhase SplitAs SplitAs = True -eqPhase As As = True +eqPhase (As x) (As y) = x == y eqPhase LlvmOpt LlvmOpt = True eqPhase LlvmLlc LlvmLlc = True eqPhase LlvmMangle LlvmMangle = True @@ -150,21 +149,21 @@ nextPhase dflags p Splitter -> SplitAs LlvmOpt -> LlvmLlc LlvmLlc -> LlvmMangle - LlvmMangle -> As + LlvmMangle -> As False SplitAs -> MergeStub - As -> MergeStub - Ccpp -> As - Cc -> As - Cobjc -> As - Cobjcpp -> As + As _ -> MergeStub + Ccpp -> As False + Cc -> As False + Cobjc -> As False + Cobjcpp -> As False CmmCpp -> Cmm Cmm -> maybeHCc - HCc -> As + HCc -> As False MergeStub -> StopLn StopLn -> panic "nextPhase: nothing after StopLn" where maybeHCc = if platformUnregisterised (targetPlatform dflags) then HCc - else As + else As False -- the first compilation phase for a given file is determined -- by its suffix. @@ -175,7 +174,6 @@ startPhase "hs" = Cpp HsSrcFile startPhase "hs-boot" = Cpp HsBootFile startPhase "hscpp" = HsPp HsSrcFile startPhase "hspp" = Hsc HsSrcFile -startPhase "hcr" = Hsc ExtCoreFile startPhase "hc" = HCc startPhase "c" = Cc startPhase "cpp" = Ccpp @@ -186,8 +184,8 @@ startPhase "mm" = Cobjcpp startPhase "cc" = Ccpp startPhase "cxx" = Ccpp startPhase "split_s" = Splitter -startPhase "s" = As -startPhase "S" = As +startPhase "s" = As False +startPhase "S" = As True startPhase "ll" = LlvmOpt startPhase "bc" = LlvmLlc startPhase "lm_s" = LlvmMangle @@ -202,7 +200,6 @@ startPhase _ = StopLn -- all unknown file types phaseInputExt :: Phase -> String phaseInputExt (Unlit HsSrcFile) = "lhs" phaseInputExt (Unlit HsBootFile) = "lhs-boot" -phaseInputExt (Unlit ExtCoreFile) = "lhcr" phaseInputExt (Cpp _) = "lpp" -- intermediate only phaseInputExt (HsPp _) = "hscpp" -- intermediate only phaseInputExt (Hsc _) = "hspp" -- intermediate only @@ -215,7 +212,8 @@ phaseInputExt Cobjc = "m" phaseInputExt Cobjcpp = "mm" phaseInputExt Cc = "c" phaseInputExt Splitter = "split_s" -phaseInputExt As = "s" +phaseInputExt (As True) = "S" +phaseInputExt (As False) = "s" phaseInputExt LlvmOpt = "ll" phaseInputExt LlvmLlc = "bc" phaseInputExt LlvmMangle = "lm_s" @@ -226,13 +224,12 @@ phaseInputExt MergeStub = "o" phaseInputExt StopLn = "o" haskellish_src_suffixes, haskellish_suffixes, cish_suffixes, - extcoreish_suffixes, haskellish_user_src_suffixes + haskellish_user_src_suffixes :: [String] haskellish_src_suffixes = haskellish_user_src_suffixes ++ [ "hspp", "hscpp", "hcr", "cmm", "cmmcpp" ] haskellish_suffixes = haskellish_src_suffixes ++ ["hc", "raw_s"] cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "lm_s", "m", "M", "mm" ] -extcoreish_suffixes = [ "hcr" ] -- Will not be deleted as temp files: haskellish_user_src_suffixes = [ "hs", "lhs", "hs-boot", "lhs-boot" ] @@ -249,13 +246,12 @@ dynlib_suffixes platform = case platformOS platform of OSDarwin -> ["dylib", "so"] _ -> ["so"] -isHaskellishSuffix, isHaskellSrcSuffix, isCishSuffix, isExtCoreSuffix, +isHaskellishSuffix, isHaskellSrcSuffix, isCishSuffix, isHaskellUserSrcSuffix :: String -> Bool isHaskellishSuffix s = s `elem` haskellish_suffixes isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes isCishSuffix s = s `elem` cish_suffixes -isExtCoreSuffix s = s `elem` extcoreish_suffixes isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes isObjectSuffix, isDynLibSuffix :: Platform -> String -> Bool @@ -266,13 +262,12 @@ isSourceSuffix :: String -> Bool isSourceSuffix suff = isHaskellishSuffix suff || isCishSuffix suff isHaskellishFilename, isHaskellSrcFilename, isCishFilename, - isExtCoreFilename, isHaskellUserSrcFilename, isSourceFilename + isHaskellUserSrcFilename, isSourceFilename :: FilePath -> Bool -- takeExtension return .foo, so we drop 1 to get rid of the . isHaskellishFilename f = isHaskellishSuffix (drop 1 $ takeExtension f) isHaskellSrcFilename f = isHaskellSrcSuffix (drop 1 $ takeExtension f) isCishFilename f = isCishSuffix (drop 1 $ takeExtension f) -isExtCoreFilename f = isExtCoreSuffix (drop 1 $ takeExtension f) isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (drop 1 $ takeExtension f) isSourceFilename f = isSourceSuffix (drop 1 $ takeExtension f) diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 564edd27f7..183f435296 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1,5 +1,5 @@ -{-# OPTIONS -fno-cse #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation #-} +{-# OPTIONS_GHC -fno-cse #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly ----------------------------------------------------------------------------- @@ -54,7 +54,6 @@ import Util import StringBuffer ( hGetStringBuffer ) import BasicTypes ( SuccessFlag(..) ) import Maybes ( expectJust ) -import ParserCoreUtils ( getCoreModuleName ) import SrcLoc import FastString import LlvmCodeGen ( llvmFixupAsm ) @@ -169,8 +168,6 @@ compileOne' m_tc_result mHscMessage output_fn <- getOutputFilename next_phase Temporary basename dflags next_phase (Just location) - let extCore_filename = basename ++ ".hcr" - -- -fforce-recomp should also work with --make let force_recomp = gopt Opt_ForceRecomp dflags source_modified @@ -207,7 +204,7 @@ compileOne' m_tc_result mHscMessage hm_linkable = maybe_old_linkable }) _ -> do guts0 <- hscDesugar hsc_env summary tc_result guts <- hscSimplify hsc_env guts0 - (iface, _changed, details, cgguts) <- hscNormalIface hsc_env extCore_filename guts mb_old_hash + (iface, _changed, details, cgguts) <- hscNormalIface hsc_env guts mb_old_hash (hasStub, comp_bc, modBreaks) <- hscInteractive hsc_env cgguts summary stub_o <- case hasStub of @@ -231,7 +228,9 @@ compileOne' m_tc_result mHscMessage hm_iface = iface, hm_linkable = Just linkable }) HscNothing -> - do (iface, _changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash + do (iface, changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash + when (gopt Opt_WriteInterface dflags) $ + hscWriteIface dflags iface changed summary let linkable = if isHsBoot src_flavour then maybe_old_linkable else Just (LM (ms_hs_date summary) this_mod []) @@ -251,7 +250,7 @@ compileOne' m_tc_result mHscMessage _ -> do guts0 <- hscDesugar hsc_env summary tc_result guts <- hscSimplify hsc_env guts0 - (iface, changed, details, cgguts) <- hscNormalIface hsc_env extCore_filename guts mb_old_hash + (iface, changed, details, cgguts) <- hscNormalIface hsc_env guts mb_old_hash hscWriteIface dflags iface changed summary -- We're in --make mode: finish the compilation pipeline. @@ -391,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 @@ -412,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 @@ -428,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 @@ -498,8 +496,8 @@ compileFile hsc_env stop_phase (src, mb_phase) = do | otherwise = Persistent stop_phase' = case stop_phase of - As | split -> SplitAs - _ -> stop_phase + As _ | split -> SplitAs + _ -> stop_phase ( _, out_file) <- runPipeline stop_phase' hsc_env (src, fmap RealPhase mb_phase) Nothing output @@ -730,7 +728,7 @@ getOutputFilename stop_phase output basename dflags next_phase maybe_location -- sometimes, we keep output from intermediate stages keep_this_output = case next_phase of - As | keep_s -> True + As _ | keep_s -> True LlvmOpt | keep_bc -> True HCc | keep_hc -> True _other -> False @@ -892,16 +890,11 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 setDynFlags dflags -- gather the imports and module name - (hspp_buf,mod_name,imps,src_imps) <- liftIO $ - case src_flavour of - ExtCoreFile -> do -- no explicit imports in ExtCore input. - m <- getCoreModuleName input_fn - return (Nothing, mkModuleName m, [], []) - - _ -> do - buf <- hGetStringBuffer input_fn - (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff) - return (Just buf, mod_name, imps, src_imps) + (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do + do + buf <- hGetStringBuffer input_fn + (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff) + return (Just buf, mod_name, imps, src_imps) -- Take -o into account if present -- Very like -ohi, but we must *only* do this if we aren't linking @@ -936,8 +929,6 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 then return SourceUnmodified else return SourceModified - let extCore_filename = basename ++ ".hcr" - PipeState{hsc_env=hsc_env'} <- getPipeState -- Tell the finder cache about this module @@ -957,7 +948,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 ms_srcimps = src_imps } -- run the compiler! - result <- liftIO $ hscCompileOneShot hsc_env' extCore_filename + result <- liftIO $ hscCompileOneShot hsc_env' mod_summary source_unchanged return (HscOut src_flavour mod_name result, @@ -1045,7 +1036,7 @@ runPhase (RealPhase cc_phase) input_fn dflags -- files; this is the Value Add(TM) that using ghc instead of -- gcc gives you :) pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs - let include_paths = foldr (\ x xs -> "-I" : x : xs) [] + let include_paths = foldr (\ x xs -> ("-I" ++ x) : xs) [] (cmdline_include_paths ++ pkg_include_dirs) let gcc_extra_viac_flags = extraGccViaCFlags dflags @@ -1078,7 +1069,7 @@ runPhase (RealPhase cc_phase) input_fn dflags | otherwise = [] -- Decide next phase - let next_phase = As + let next_phase = As False output_fn <- phaseOutputFilename next_phase let @@ -1121,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 []) @@ -1190,7 +1181,7 @@ runPhase (RealPhase Splitter) input_fn dflags -- As, SpitAs phase : Assembler -- This is for calling the assembler on a regular assembly file (not split). -runPhase (RealPhase As) input_fn dflags +runPhase (RealPhase (As with_cpp)) input_fn dflags = do -- LLVM from version 3.0 onwards doesn't support the OS X system -- assembler, so we use clang as the assembler instead. (#5636) @@ -1216,6 +1207,7 @@ runPhase (RealPhase As) input_fn dflags -- might be a hierarchical module. liftIO $ createDirectoryIfMissing True (takeDirectory output_fn) + ccInfo <- liftIO $ getCompilerInfo dflags let runAssembler inputFilename outputFilename = liftIO $ as_prog dflags ([ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ] @@ -1230,8 +1222,13 @@ runPhase (RealPhase As) input_fn dflags ++ (if platformArch (targetPlatform dflags) == ArchSPARC then [SysTools.Option "-mcpu=v9"] else []) - - ++ [ SysTools.Option "-x", SysTools.Option "assembler-with-cpp" + ++ (if any (ccInfo ==) [Clang, AppleClang, AppleClang51] + then [SysTools.Option "-Qunused-arguments"] + else []) + ++ [ SysTools.Option "-x" + , if with_cpp + then SysTools.Option "assembler-with-cpp" + else SysTools.Option "assembler" , SysTools.Option "-c" , SysTools.FileOption "" inputFilename , SysTools.Option "-o" @@ -1256,6 +1253,7 @@ runPhase (RealPhase SplitAs) _input_fn dflags osuf = objectSuf dflags split_odir = base_o ++ "_" ++ osuf ++ "_split" + -- this also creates the hierarchy liftIO $ createDirectoryIfMissing True split_odir -- remove M_split/ *.o, because we're going to archive M_split/ *.o @@ -1385,7 +1383,7 @@ runPhase (RealPhase LlvmLlc) input_fn dflags let next_phase = case gopt Opt_NoLlvmMangler dflags of False -> LlvmMangle True | gopt Opt_SplitObjs dflags -> Splitter - True -> As + True -> As False output_fn <- phaseOutputFilename next_phase @@ -1454,7 +1452,7 @@ runPhase (RealPhase LlvmLlc) input_fn dflags runPhase (RealPhase LlvmMangle) input_fn dflags = do - let next_phase = if gopt Opt_SplitObjs dflags then Splitter else As + let next_phase = if gopt Opt_SplitObjs dflags then Splitter else As False output_fn <- phaseOutputFilename next_phase liftIO $ llvmFixupAsm dflags input_fn output_fn return (RealPhase next_phase, output_fn) @@ -1466,6 +1464,7 @@ runPhase (RealPhase MergeStub) input_fn dflags = do PipeState{maybe_stub_o} <- getPipeState output_fn <- phaseOutputFilename StopLn + liftIO $ createDirectoryIfMissing True (takeDirectory output_fn) case maybe_stub_o of Nothing -> panic "runPhase(MergeStub): no stub" @@ -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 @@ -1873,7 +1872,7 @@ linkBinary' staticLink dflags o_files dep_packages = do let os = platformOS (targetPlatform dflags) in if os == OSOsf3 then ["-lpthread", "-lexc"] else if os `elem` [OSMinGW32, OSFreeBSD, OSOpenBSD, - OSNetBSD, OSHaiku, OSQNXNTO, OSiOS] + OSNetBSD, OSHaiku, OSQNXNTO, OSiOS, OSDarwin] then [] else ["-lpthread"] | otherwise = [] @@ -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]) $ @@ -2134,26 +2133,27 @@ joinObjectFiles dflags o_files output_fn = do let mySettings = settings dflags ldIsGnuLd = sLdIsGnuLd mySettings osInfo = platformOS (targetPlatform dflags) - ld_r args ccInfo = SysTools.runLink dflags ([ - SysTools.Option "-nostdlib", - SysTools.Option "-Wl,-r" - ] - ++ (if ccInfo == Clang then [] - else [SysTools.Option "-nodefaultlibs"]) - ++ (if osInfo == OSFreeBSD - then [SysTools.Option "-L/usr/lib"] - else []) - -- gcc on sparc sets -Wl,--relax implicitly, but - -- -r and --relax are incompatible for ld, so - -- disable --relax explicitly. - ++ (if platformArch (targetPlatform dflags) == ArchSPARC - && ldIsGnuLd - then [SysTools.Option "-Wl,-no-relax"] - else []) - ++ map SysTools.Option ld_build_id - ++ [ SysTools.Option "-o", - SysTools.FileOption "" output_fn ] - ++ args) + ld_r args cc = SysTools.runLink dflags ([ + SysTools.Option "-nostdlib", + SysTools.Option "-Wl,-r" + ] + ++ (if any (cc ==) [Clang, AppleClang, AppleClang51] + then [] + else [SysTools.Option "-nodefaultlibs"]) + ++ (if osInfo == OSFreeBSD + then [SysTools.Option "-L/usr/lib"] + else []) + -- gcc on sparc sets -Wl,--relax implicitly, but + -- -r and --relax are incompatible for ld, so + -- disable --relax explicitly. + ++ (if platformArch (targetPlatform dflags) == ArchSPARC + && ldIsGnuLd + then [SysTools.Option "-Wl,-no-relax"] + else []) + ++ map SysTools.Option ld_build_id + ++ [ SysTools.Option "-o", + SysTools.FileOption "" output_fn ] + ++ args) -- suppress the generation of the .note.gnu.build-id section, -- which we don't need and sometimes causes ld to emit a @@ -2165,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 @@ -2186,7 +2188,7 @@ hscPostBackendPhase dflags _ hsc_lang = case hsc_lang of HscC -> HCc HscAsm | gopt Opt_SplitObjs dflags -> Splitter - | otherwise -> As + | otherwise -> As False HscLlvm -> LlvmOpt HscNothing -> StopLn HscInterpreted -> StopLn diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 78fc3ec4c9..5b3eac4e5d 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -1,10 +1,19 @@ +{-# LANGUAGE CPP #-} +------------------------------------------------------------------------------- +-- +-- | Dynamic flags +-- +-- Most flags are dynamic flags, which means they can change from compilation +-- to compilation using @OPTIONS_GHC@ pragmas, and in a multi-session GHC each +-- session can be using different dynamic flags. Dynamic flags can also be set +-- at the prompt in GHCi. -- -- (c) The University of Glasgow 2005 -- ------------------------------------------------------------------------------- -{-# OPTIONS -fno-cse #-} +{-# OPTIONS_GHC -fno-cse #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly module DynFlags ( @@ -23,6 +32,7 @@ module DynFlags ( wopt, wopt_set, wopt_unset, xopt, xopt_set, xopt_unset, lang_set, + useUnicodeSyntax, whenGeneratingDynamicToo, ifGeneratingDynamicToo, whenCannotGenerateDynamicToo, dynamicTooMkDynamicDynFlags, @@ -33,7 +43,7 @@ module DynFlags ( targetRetainsAllBindings, GhcMode(..), isOneShot, GhcLink(..), isNoLink, - PackageFlag(..), + PackageFlag(..), PackageArg(..), ModRenaming, PkgConfRef(..), Option(..), showOpt, DynLibLoader(..), @@ -51,7 +61,7 @@ module DynFlags ( safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn, packageTrustOn, safeDirectImpsReq, safeImplicitImpsReq, - unsafeFlags, + unsafeFlags, unsafeFlagsForInfer, -- ** System tool settings and locations Settings(..), @@ -80,7 +90,7 @@ module DynFlags ( getVerbFlags, updOptLevel, setTmpDir, - setPackageName, + setPackageKey, -- ** Parsing DynFlags parseDynamicFlagsCmdLine, @@ -180,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 @@ -259,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_late_float | Opt_D_dump_view_pattern_commoning | Opt_D_verbose_core2core @@ -343,6 +356,7 @@ data GeneralFlag | Opt_IgnoreInterfacePragmas | Opt_OmitInterfacePragmas | Opt_ExposeAllUnfoldings + | Opt_WriteInterface -- forces .hi files to be written even with -fno-code -- profiling opts | Opt_AutoSccsOnIndividualCafs @@ -416,8 +430,6 @@ data GeneralFlag | Opt_SuppressUniques -- temporary flags - | Opt_RunCPS - | Opt_RunCPSZ | Opt_AutoLinkPackages | Opt_ImplicitImportQualified @@ -470,7 +482,6 @@ data WarningFlag = | Opt_WarnTabs | Opt_WarnUnrecognisedPragmas | Opt_WarnDodgyForeignImports - | Opt_WarnLazyUnliftedBindings | Opt_WarnUnusedDoBind | Opt_WarnWrongDoBind | Opt_WarnAlternativeLayoutRuleTransitional @@ -492,7 +503,6 @@ data SafeHaskellMode | Sf_Unsafe | Sf_Trustworthy | Sf_Safe - | Sf_SafeInferred deriving (Eq) instance Show SafeHaskellMode where @@ -500,7 +510,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 @@ -594,6 +603,7 @@ data ExtensionFlag | Opt_TraditionalRecordSyntax | Opt_LambdaCase | Opt_MultiWayIf + | Opt_BinaryLiterals | Opt_NegativeLiterals | Opt_EmptyCase | Opt_PatternSynonyms @@ -647,7 +657,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 @@ -754,11 +764,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, @@ -794,7 +807,7 @@ data DynFlags = DynFlags { pprCols :: Int, traceLevel :: Int, -- Standard level is 1. Less verbose is 0. - useUnicodeQuotes :: Bool, + useUnicode :: Bool, -- | what kind of {-# SCC #-} to add automatically profAuto :: ProfAuto, @@ -1036,9 +1049,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 @@ -1232,7 +1251,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"] _ -> [] @@ -1312,12 +1330,12 @@ initDynFlags dflags = do refRtldInfo <- newIORef Nothing refRtccInfo <- newIORef Nothing wrapperNum <- newIORef emptyModuleEnv - canUseUnicodeQuotes <- do let enc = localeEncoding - str = "‘’" - (withCString enc str $ \cstr -> - do str' <- peekCString enc cstr - return (str == str')) - `catchIOError` \_ -> return False + canUseUnicode <- do let enc = localeEncoding + str = "‘’" + (withCString enc str $ \cstr -> + do str' <- peekCString enc cstr + return (str == str')) + `catchIOError` \_ -> return False return dflags{ canGenerateDynamicToo = refCanGenerateDynamicToo, nextTempSuffix = refNextTempSuffix, @@ -1327,7 +1345,7 @@ initDynFlags dflags = do generatedDumps = refGeneratedDumps, llvmVersion = refLlvmVersion, nextWrapperNum = wrapperNum, - useUnicodeQuotes = canUseUnicodeQuotes, + useUnicode = canUseUnicode, rtldInfo = refRtldInfo, rtccInfo = refRtccInfo } @@ -1376,7 +1394,7 @@ defaultDynFlags mySettings = ctxtStkDepth = mAX_CONTEXT_REDUCTION_DEPTH, tyFunStkDepth = mAX_TYPE_FUNCTION_REDUCTION_DEPTH, - thisPackage = mainPackageId, + thisPackage = mainPackageKey, objectDir = Nothing, dylibInstallName = Nothing, @@ -1441,9 +1459,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, @@ -1473,7 +1494,7 @@ defaultDynFlags mySettings = flushErr = defaultFlushErr, pprUserLength = 5, pprCols = 100, - useUnicodeQuotes = False, + useUnicode = False, traceLevel = 1, profAuto = NoProfAuto, llvmVersion = panic "defaultDynFlags: No llvmVersion", @@ -1650,6 +1671,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 Opt_D_dump_late_float = False enableIfVerbose _ = True @@ -1710,6 +1732,9 @@ lang_set dflags lang = extensionFlags = flattenExtensionFlags lang (extensions dflags) } +useUnicodeSyntax :: DynFlags -> Bool +useUnicodeSyntax = xopt Opt_UnicodeSyntax + -- | Set the Haskell language standard to use setLanguage :: Language -> DynP () setLanguage l = upd (`lang_set` Just l) @@ -1724,7 +1749,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 @@ -1732,7 +1757,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 @@ -1746,7 +1771,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 @@ -1763,9 +1792,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) @@ -1777,13 +1804,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 @@ -2065,43 +2098,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] {- ********************************************************************** %* * @@ -2178,8 +2209,15 @@ dynamic_flags = [ ----- Linker -------------------------------------------------------- , Flag "static" (NoArg removeWayDyn) , Flag "dynamic" (NoArg (addWay WayDyn)) + , Flag "rdynamic" $ noArg $ +#ifdef linux_HOST_OS + addOptl "-rdynamic" +#elif defined (mingw32_HOST_OS) + addOptl "-export-all-symbols" +#else -- ignored for compat w/ gcc: - , Flag "rdynamic" (NoArg (return ())) + id +#endif , Flag "relative-dynlib-paths" (NoArg (setGeneralFlag Opt_RelativeDynlibPaths)) ------- Specific phases -------------------------------------------- @@ -2190,7 +2228,6 @@ dynamic_flags = [ , Flag "pgmP" (hasArg setPgmP) , Flag "pgmF" (hasArg (\f -> alterSettings (\s -> s { sPgm_F = f}))) , Flag "pgmc" (hasArg (\f -> alterSettings (\s -> s { sPgm_c = (f,[])}))) - , Flag "pgmm" (HasArg (\_ -> addWarn "The -pgmm flag does nothing; it will be removed in a future GHC release")) , Flag "pgms" (hasArg (\f -> alterSettings (\s -> s { sPgm_s = (f,[])}))) , Flag "pgma" (hasArg (\f -> alterSettings (\s -> s { sPgm_a = (f,[])}))) , Flag "pgml" (hasArg (\f -> alterSettings (\s -> s { sPgm_l = (f,[])}))) @@ -2205,7 +2242,6 @@ dynamic_flags = [ , Flag "optP" (hasArg addOptP) , Flag "optF" (hasArg (\f -> alterSettings (\s -> s { sOpt_F = f : sOpt_F s}))) , Flag "optc" (hasArg addOptc) - , Flag "optm" (HasArg (\_ -> addWarn "The -optm flag does nothing; it will be removed in a future GHC release")) , Flag "opta" (hasArg (\f -> alterSettings (\s -> s { sOpt_a = f : sOpt_a s}))) , Flag "optl" (hasArg addOptl) , Flag "optwindres" (hasArg (\f -> alterSettings (\s -> s { sOpt_windres = f : sOpt_windres s}))) @@ -2217,16 +2253,9 @@ dynamic_flags = [ -------- ghc -M ----------------------------------------------------- , Flag "dep-suffix" (hasArg addDepSuffix) - , Flag "optdep-s" (hasArgDF addDepSuffix "Use -dep-suffix instead") , Flag "dep-makefile" (hasArg setDepMakefile) - , Flag "optdep-f" (hasArgDF setDepMakefile "Use -dep-makefile instead") - , Flag "optdep-w" (NoArg (deprecate "doesn't do anything")) , Flag "include-pkg-deps" (noArg (setDepIncludePkgDeps True)) - , Flag "optdep--include-prelude" (noArgDF (setDepIncludePkgDeps True) "Use -include-pkg-deps instead") - , Flag "optdep--include-pkg-deps" (noArgDF (setDepIncludePkgDeps True) "Use -include-pkg-deps instead") , Flag "exclude-module" (hasArg addDepExcludeMod) - , Flag "optdep--exclude-module" (hasArgDF addDepExcludeMod "Use -exclude-module instead") - , Flag "optdep-x" (hasArgDF addDepExcludeMod "Use -exclude-module instead") -------- Linking ---------------------------------------------------- , Flag "no-link" (noArg (\d -> d{ ghcLink=NoLink })) @@ -2271,8 +2300,6 @@ dynamic_flags = [ , Flag "keep-hc-files" (NoArg (setGeneralFlag Opt_KeepHcFiles)) , Flag "keep-s-file" (NoArg (setGeneralFlag Opt_KeepSFiles)) , Flag "keep-s-files" (NoArg (setGeneralFlag Opt_KeepSFiles)) - , Flag "keep-raw-s-file" (NoArg (addWarn "The -keep-raw-s-file flag does nothing; it will be removed in a future GHC release")) - , Flag "keep-raw-s-files" (NoArg (addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) , Flag "keep-llvm-file" (NoArg (do setObjTarget HscLlvm setGeneralFlag Opt_KeepLlvmFiles)) , Flag "keep-llvm-files" (NoArg (do setObjTarget HscLlvm @@ -2397,6 +2424,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-llf" (setDumpFlag Opt_D_dump_late_float) , Flag "ddump-view-pattern-commoning" (setDumpFlag Opt_D_dump_view_pattern_commoning) , Flag "ddump-to-file" (NoArg (setGeneralFlag Opt_DumpToFile)) @@ -2413,9 +2441,6 @@ dynamic_flags = [ ------ Machine dependant (-m<blah>) stuff --------------------------- - , Flag "monly-2-regs" (NoArg (addWarn "The -monly-2-regs flag does nothing; it will be removed in a future GHC release")) - , Flag "monly-3-regs" (NoArg (addWarn "The -monly-3-regs flag does nothing; it will be removed in a future GHC release")) - , Flag "monly-4-regs" (NoArg (addWarn "The -monly-4-regs flag does nothing; it will be removed in a future GHC release")) , Flag "msse" (versionSuffix (\maj min d -> d{ sseVersion = Just (maj, min) })) , Flag "mavx" (noArg (\d -> d{ avx = True })) , Flag "mavx2" (noArg (\d -> d{ avx2 = True })) @@ -2532,7 +2557,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)) ] @@ -2571,9 +2596,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) @@ -2649,15 +2678,14 @@ fWarningFlags = [ ( "warn-warnings-deprecations", Opt_WarnWarningsDeprecations, nop ), ( "warn-deprecations", Opt_WarnWarningsDeprecations, nop ), ( "warn-deprecated-flags", Opt_WarnDeprecatedFlags, nop ), - ( "warn-amp", Opt_WarnAMP, nop ), + ( "warn-amp", Opt_WarnAMP, + \_ -> deprecate "it has no effect, and will be removed in GHC 7.12" ), ( "warn-orphans", Opt_WarnOrphans, nop ), ( "warn-identities", Opt_WarnIdentities, nop ), ( "warn-auto-orphans", Opt_WarnAutoOrphans, nop ), ( "warn-tabs", Opt_WarnTabs, nop ), ( "warn-typed-holes", Opt_WarnTypedHoles, nop ), ( "warn-unrecognised-pragmas", Opt_WarnUnrecognisedPragmas, nop ), - ( "warn-lazy-unlifted-bindings", Opt_WarnLazyUnliftedBindings, - \_ -> deprecate "it has no effect, and will be removed in GHC 7.10" ), ( "warn-unused-do-bind", Opt_WarnUnusedDoBind, nop ), ( "warn-wrong-do-bind", Opt_WarnWrongDoBind, nop ), ( "warn-alternative-layout-rule-transitional", Opt_WarnAlternativeLayoutRuleTransitional, nop ), @@ -2704,6 +2732,7 @@ fFlags = [ ( "pedantic-bottoms", Opt_PedanticBottoms, nop ), ( "ignore-interface-pragmas", Opt_IgnoreInterfacePragmas, nop ), ( "omit-interface-pragmas", Opt_OmitInterfacePragmas, nop ), + ( "write-interface", Opt_WriteInterface, nop ), ( "expose-all-unfoldings", Opt_ExposeAllUnfoldings, nop ), ( "do-lambda-eta-expansion", Opt_DoLambdaEtaExpansion, nop ), ( "ignore-asserts", Opt_IgnoreAsserts, nop ), @@ -2723,8 +2752,6 @@ fFlags = [ ( "break-on-error", Opt_BreakOnError, nop ), ( "print-evld-with-show", Opt_PrintEvldWithShow, nop ), ( "print-bind-contents", Opt_PrintBindContents, nop ), - ( "run-cps", Opt_RunCPS, nop ), - ( "run-cpsz", Opt_RunCPSZ, nop ), ( "vectorise", Opt_Vectorise, nop ), ( "vectorisation-avoidance", Opt_VectorisationAvoidance, nop ), ( "regs-graph", Opt_RegsGraph, nop ), @@ -2739,7 +2766,8 @@ fFlags = [ ( "fun-to-thunk", Opt_FunToThunk, nop ), ( "gen-manifest", Opt_GenManifest, nop ), ( "embed-manifest", Opt_EmbedManifest, nop ), - ( "ext-core", Opt_EmitExternalCore, nop ), + ( "ext-core", Opt_EmitExternalCore, + \_ -> deprecate "it has no effect, and will be removed in GHC 7.12" ), ( "shared-implib", Opt_SharedImplib, nop ), ( "ghci-sandbox", Opt_GhciSandbox, nop ), ( "ghci-history", Opt_GhciHistory, nop ), @@ -2938,13 +2966,17 @@ xFlags = [ ( "FlexibleInstances", Opt_FlexibleInstances, nop ), ( "ConstrainedClassMethods", Opt_ConstrainedClassMethods, nop ), ( "MultiParamTypeClasses", Opt_MultiParamTypeClasses, nop ), - ( "NullaryTypeClasses", Opt_NullaryTypeClasses, nop ), + ( "NullaryTypeClasses", Opt_NullaryTypeClasses, + 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 ), + ( "BinaryLiterals", Opt_BinaryLiterals, nop ), ( "NegativeLiterals", Opt_NegativeLiterals, nop ), ( "EmptyCase", Opt_EmptyCase, nop ), ( "PatternSynonyms", Opt_PatternSynonyms, nop ) @@ -3029,6 +3061,9 @@ impliedFlags , (Opt_ImplicitParams, turnOn, Opt_FlexibleInstances) , (Opt_JavaScriptFFI, turnOn, Opt_InterruptibleFFI) + + , (Opt_DeriveTraversable, turnOn, Opt_DeriveFunctor) + , (Opt_DeriveTraversable, turnOn, Opt_DeriveFoldable) ] optLevelFlags :: [([Int], GeneralFlag)] @@ -3086,7 +3121,6 @@ standardWarnings = [ Opt_WarnOverlappingPatterns, Opt_WarnWarningsDeprecations, Opt_WarnDeprecatedFlags, - Opt_WarnAMP, Opt_WarnTypedHoles, Opt_WarnUnrecognisedPragmas, Opt_WarnPointlessPragmas, @@ -3257,16 +3291,9 @@ noArg fn = NoArg (upd fn) noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) noArgM fn = NoArg (updM fn) -noArgDF :: (DynFlags -> DynFlags) -> String -> OptKind (CmdLineP DynFlags) -noArgDF fn deprec = NoArg (upd fn >> deprecate deprec) - hasArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) hasArg fn = HasArg (upd . fn) -hasArgDF :: (String -> DynFlags -> DynFlags) -> String -> OptKind (CmdLineP DynFlags) -hasArgDF fn deprec = HasArg (\s -> do upd (fn s) - deprecate deprec) - sepArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) sepArg fn = SepArg (upd . fn) @@ -3400,11 +3427,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 = @@ -3416,10 +3471,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). @@ -3471,10 +3527,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 } @@ -3608,10 +3664,10 @@ picCCOpts dflags -- Don't generate "common" symbols - these are unwanted -- in dynamic libraries. - | gopt Opt_PIC dflags -> ["-fno-common", "-U __PIC__", "-D__PIC__"] + | gopt Opt_PIC dflags -> ["-fno-common", "-U__PIC__", "-D__PIC__"] | otherwise -> ["-mdynamic-no-pic"] OSMinGW32 -- no -fPIC for Windows - | gopt Opt_PIC dflags -> ["-U __PIC__", "-D__PIC__"] + | gopt Opt_PIC dflags -> ["-U__PIC__", "-D__PIC__"] | otherwise -> [] _ -- we need -fPIC for C files when we are compiling with -dynamic, @@ -3620,12 +3676,12 @@ picCCOpts dflags -- objects, but can't without -fPIC. See -- http://ghc.haskell.org/trac/ghc/wiki/Commentary/PositionIndependentCode | gopt Opt_PIC dflags || not (gopt Opt_Static dflags) -> - ["-fPIC", "-U __PIC__", "-D__PIC__"] + ["-fPIC", "-U__PIC__", "-D__PIC__"] | otherwise -> [] picPOpts :: DynFlags -> [String] picPOpts dflags - | gopt Opt_PIC dflags = ["-U __PIC__", "-D__PIC__"] + | gopt Opt_PIC dflags = ["-U__PIC__", "-D__PIC__"] | otherwise = [] -- ----------------------------------------------------------------------------- @@ -3661,6 +3717,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 @@ -3834,6 +3892,8 @@ data LinkerInfo data CompilerInfo = GCC | Clang + | AppleClang + | AppleClang51 | UnknownCC deriving Eq diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot index 04ec5a4e7d..5cf21669bd 100644 --- a/compiler/main/DynFlags.hs-boot +++ b/compiler/main/DynFlags.hs-boot @@ -9,4 +9,5 @@ targetPlatform :: DynFlags -> Platform pprUserLength :: DynFlags -> Int pprCols :: DynFlags -> Int unsafeGlobalDynFlags :: DynFlags -useUnicodeQuotes :: DynFlags -> Bool +useUnicode :: DynFlags -> Bool +useUnicodeSyntax :: DynFlags -> Bool diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs index ffafc78216..046d13cee5 100644 --- a/compiler/main/DynamicLoading.hs +++ b/compiler/main/DynamicLoading.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP, MagicHash #-} + -- | Dynamically lookup up values from modules and loading them. module DynamicLoading ( #ifdef GHCI diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 12b6bad68a..c43064e7f1 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -4,17 +4,21 @@ \section[ErrsUtils]{Utilities for error reporting} \begin{code} +{-# 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, @@ -45,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 @@ -55,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. @@ -73,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 60683b2289..f9c7e2eee0 100644 --- a/compiler/main/Finder.lhs +++ b/compiler/main/Finder.lhs @@ -4,6 +4,8 @@ \section[Finder]{Module Finder} \begin{code} +{-# LANGUAGE CPP #-} + module Finder ( flushFinderCaches, FindResult(..), @@ -41,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 @@ -78,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 () @@ -146,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 @@ -188,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 @@ -293,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. @@ -371,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 = [] }) @@ -432,8 +420,8 @@ mkHomeModLocation2 :: DynFlags mkHomeModLocation2 dflags mod src_basename ext = do let mod_basename = moduleNameSlashes mod - obj_fn <- mkObjPath dflags src_basename mod_basename - hi_fn <- mkHiPath dflags src_basename mod_basename + obj_fn = mkObjPath dflags src_basename mod_basename + hi_fn = mkHiPath dflags src_basename mod_basename return (ModLocation{ ml_hs_file = Just (src_basename <.> ext), ml_hi_file = hi_fn, @@ -443,7 +431,7 @@ mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String -> IO ModLocation mkHiOnlyModLocation dflags hisuf path basename = do let full_basename = path </> basename - obj_fn <- mkObjPath dflags full_basename basename + obj_fn = mkObjPath dflags full_basename basename return ModLocation{ ml_hs_file = Nothing, ml_hi_file = full_basename <.> hisuf, -- Remove the .hi-boot suffix from @@ -459,16 +447,15 @@ mkObjPath :: DynFlags -> FilePath -- the filename of the source file, minus the extension -> String -- the module name with dots replaced by slashes - -> IO FilePath -mkObjPath dflags basename mod_basename - = do let + -> FilePath +mkObjPath dflags basename mod_basename = obj_basename <.> osuf + where odir = objectDir dflags osuf = objectSuf dflags obj_basename | Just dir <- odir = dir </> mod_basename | otherwise = basename - return (obj_basename <.> osuf) -- | Constructs the filename of a .hi file for a given source file. -- Does /not/ check whether the .hi file exists @@ -476,16 +463,15 @@ mkHiPath :: DynFlags -> FilePath -- the filename of the source file, minus the extension -> String -- the module name with dots replaced by slashes - -> IO FilePath -mkHiPath dflags basename mod_basename - = do let + -> FilePath +mkHiPath dflags basename mod_basename = hi_basename <.> hisuf + where hidir = hiDir dflags hisuf = hiSuf dflags hi_basename | Just dir <- hidir = dir </> mod_basename | otherwise = basename - return (hi_basename <.> hisuf) -- ----------------------------------------------------------------------------- @@ -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 5fe384e9a6..9ab52ebf1d 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables #-} + -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow, 2005-2012 @@ -53,7 +55,6 @@ module GHC ( -- ** Compiling to Core CoreModule(..), compileToCoreModule, compileToCoreSimplified, - compileCoreToObj, -- * Inspecting the module structure of the program ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..), @@ -80,7 +81,7 @@ module GHC ( SafeHaskellMode(..), -- * Querying the environment - packageDbModules, + -- packageDbModules, -- * Printing PrintUnqualified, alwaysQualify, @@ -132,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 @@ -261,6 +262,7 @@ import InteractiveEval import TcRnDriver ( runTcInteractive ) #endif +import PprTyThing ( pprFamInst ) import HscMain import GhcMake import DriverPipeline ( compileOne' ) @@ -283,7 +285,7 @@ import DataCon import Name hiding ( varName ) import Avail import InstEnv -import FamInstEnv +import FamInstEnv ( FamInst ) import SrcLoc import CoreSyn import TidyPgm @@ -310,7 +312,7 @@ import FastString import qualified Parser import Lexer -import System.Directory ( doesFileExist, getCurrentDirectory ) +import System.Directory ( doesFileExist ) import Data.Maybe import Data.List ( find ) import Data.Time @@ -444,7 +446,7 @@ runGhcT mb_top_dir ghct = do -- reside. More precisely, this should be the output of @ghc --print-libdir@ -- of the version of GHC the module using this API is compiled with. For -- portability, you should use the @ghc-paths@ package, available at --- <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/ghc-paths>. +-- <http://hackage.haskell.org/package/ghc-paths>. initGhcMonad :: GhcMonad m => Maybe FilePath -> m () initGhcMonad mb_top_dir @@ -532,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' @@ -541,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' } @@ -925,43 +927,6 @@ compileToCoreModule = compileCore False -- as to return simplified and tidied Core. compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule compileToCoreSimplified = compileCore True --- | Takes a CoreModule and compiles the bindings therein --- to object code. The first argument is a bool flag indicating --- whether to run the simplifier. --- The resulting .o, .hi, and executable files, if any, are stored in the --- current directory, and named according to the module name. --- This has only so far been tested with a single self-contained module. -compileCoreToObj :: GhcMonad m - => Bool -> CoreModule -> FilePath -> FilePath -> m () -compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) - output_fn extCore_filename = do - dflags <- getSessionDynFlags - currentTime <- liftIO $ getCurrentTime - cwd <- liftIO $ getCurrentDirectory - modLocation <- liftIO $ mkHiOnlyModLocation dflags (hiSuf dflags) cwd - ((moduleNameSlashes . moduleName) mName) - - let modSum = ModSummary { ms_mod = mName, - ms_hsc_src = ExtCoreFile, - ms_location = modLocation, - -- By setting the object file timestamp to Nothing, - -- we always force recompilation, which is what we - -- want. (Thus it doesn't matter what the timestamp - -- for the (nonexistent) source file is.) - ms_hs_date = currentTime, - ms_obj_date = Nothing, - -- Only handling the single-module case for now, so no imports. - ms_srcimps = [], - ms_textual_imps = [], - -- No source file - ms_hspp_file = "", - ms_hspp_opts = dflags, - ms_hspp_buf = Nothing - } - - hsc_env <- getSession - liftIO $ hscCompileCore hsc_env simplify (cm_safe cm) modSum (cm_binds cm) output_fn extCore_filename - compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule compileCore simplify fn = do @@ -1202,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] @@ -1212,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 @@ -1336,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 @@ -1346,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 @@ -1358,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 @@ -1403,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 b7a1282f5c..0c63203d4c 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- NB: we specifically ignore deprecations. GHC 7.6 marks the .QSem module as -- deprecated, although it became un-deprecated later. As a result, using 7.6 @@ -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/GhcMonad.hs b/compiler/main/GhcMonad.hs index 68b4e2b2a2..5fa6452d58 100644 --- a/compiler/main/GhcMonad.hs +++ b/compiler/main/GhcMonad.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- ----------------------------------------------------------------------------- -- diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index a083f4fcd8..fcf235bd23 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- | Parsing the top of a Haskell source file to get its module name, @@ -185,8 +187,8 @@ lazyGetToks dflags filename handle = do -- large module names (#5981) nextbuf <- hGetStringBufferBlock handle new_size if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do - newbuf <- appendStringBuffers (buffer state) nextbuf - unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size + newbuf <- appendStringBuffers (buffer state) nextbuf + unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token] diff --git a/compiler/main/Hooks.lhs b/compiler/main/Hooks.lhs index 3bd9643dc6..63aaafa2a7 100644 --- a/compiler/main/Hooks.lhs +++ b/compiler/main/Hooks.lhs @@ -63,7 +63,7 @@ data Hooks = Hooks , tcForeignImportsHook :: Maybe ([LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt)) , tcForeignExportsHook :: Maybe ([LForeignDecl Name] -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt)) , hscFrontendHook :: Maybe (ModSummary -> Hsc TcGblEnv) - , hscCompileOneShotHook :: Maybe (HscEnv -> FilePath -> ModSummary -> SourceModified -> IO HscStatus) + , hscCompileOneShotHook :: Maybe (HscEnv -> ModSummary -> SourceModified -> IO HscStatus) , hscCompileCoreExprHook :: Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO HValue) , ghcPrimIfaceHook :: Maybe ModIface , runPhaseHook :: Maybe (PhasePlus -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath)) diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 748f7480ec..15d67fc882 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns, CPP, MagicHash, NondecreasingIndentation #-} + ------------------------------------------------------------------------------- -- -- | Main API for compiling plain Haskell source code. @@ -146,7 +148,6 @@ import ErrUtils import Outputable import HscStats ( ppSourceStats ) import HscTypes -import MkExternalCore ( emitExternalCore ) import FastString import UniqFM ( emptyUFM ) import UniqSupply @@ -406,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 @@ -516,8 +518,9 @@ genericHscCompileGetFrontendResult :: -> (Int,Int) -- (i,n) = module i of n (for msgs) -> IO (Either ModIface (TcGblEnv, Maybe Fingerprint)) -genericHscCompileGetFrontendResult always_do_basic_recompilation_check m_tc_result - mHscMessage hsc_env mod_summary source_modified mb_old_iface mod_index +genericHscCompileGetFrontendResult + always_do_basic_recompilation_check m_tc_result + mHscMessage hsc_env mod_summary source_modified mb_old_iface mod_index = do let msg what = case mHscMessage of @@ -553,16 +556,19 @@ genericHscCompileGetFrontendResult always_do_basic_recompilation_check m_tc_resu case mb_checked_iface of Just iface | not (recompileRequired recomp_reqd) -> - -- If the module used TH splices when it was last compiled, - -- then the recompilation check is not accurate enough (#481) - -- and we must ignore it. However, if the module is stable - -- (none of the modules it depends on, directly or indirectly, - -- changed), then we *can* skip recompilation. This is why - -- the SourceModified type contains SourceUnmodifiedAndStable, - -- and it's pretty important: otherwise ghc --make would - -- always recompile TH modules, even if nothing at all has - -- changed. Stability is just the same check that make is - -- doing for us in one-shot mode. + -- If the module used TH splices when it was last + -- compiled, then the recompilation check is not + -- accurate enough (#481) and we must ignore + -- it. However, if the module is stable (none of + -- the modules it depends on, directly or + -- indirectly, changed), then we *can* skip + -- recompilation. This is why the SourceModified + -- type contains SourceUnmodifiedAndStable, and + -- it's pretty important: otherwise ghc --make + -- would always recompile TH modules, even if + -- nothing at all has changed. Stability is just + -- the same check that make is doing for us in + -- one-shot mode. case m_tc_result of Nothing | mi_used_th iface && not stable -> @@ -580,31 +586,25 @@ genericHscFrontend mod_summary = getHooked hscFrontendHook genericHscFrontend' >>= ($ mod_summary) genericHscFrontend' :: ModSummary -> Hsc TcGblEnv -genericHscFrontend' mod_summary - | ExtCoreFile <- ms_hsc_src mod_summary = - panic "GHC does not currently support reading External Core files" - | otherwise = - hscFileFrontEnd mod_summary +genericHscFrontend' mod_summary = hscFileFrontEnd mod_summary -------------------------------------------------------------- -- Compilers -------------------------------------------------------------- hscCompileOneShot :: HscEnv - -> FilePath -> ModSummary -> SourceModified -> IO HscStatus hscCompileOneShot env = lookupHook hscCompileOneShotHook hscCompileOneShot' (hsc_dflags env) env --- Compile Haskell, boot and extCore in OneShot mode. +-- Compile Haskell/boot in OneShot mode. hscCompileOneShot' :: HscEnv - -> FilePath -> ModSummary -> SourceModified -> IO HscStatus -hscCompileOneShot' hsc_env extCore_filename mod_summary src_changed +hscCompileOneShot' hsc_env mod_summary src_changed = do -- One-shot mode needs a knot-tying mutable variable for interface -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var. @@ -624,7 +624,11 @@ hscCompileOneShot' hsc_env extCore_filename mod_summary src_changed guts0 <- hscDesugar' (ms_location mod_summary) tc_result dflags <- getDynFlags case hscTarget dflags of - HscNothing -> return HscNotGeneratingCode + HscNothing -> do + when (gopt Opt_WriteInterface dflags) $ liftIO $ do + (iface, changed, _details) <- hscSimpleIface hsc_env tc_result mb_old_hash + hscWriteIface dflags iface changed mod_summary + return HscNotGeneratingCode _ -> case ms_hsc_src mod_summary of HsBootFile -> @@ -633,7 +637,7 @@ hscCompileOneShot' hsc_env extCore_filename mod_summary src_changed return HscUpdateBoot _ -> do guts <- hscSimplify' guts0 - (iface, changed, _details, cgguts) <- hscNormalIface' extCore_filename guts mb_old_hash + (iface, changed, _details, cgguts) <- hscNormalIface' guts mb_old_hash liftIO $ hscWriteIface dflags iface changed mod_summary return $ HscRecomp cgguts mod_summary @@ -770,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' @@ -825,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! @@ -839,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) @@ -876,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 @@ -890,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 @@ -912,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 @@ -927,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." ] @@ -948,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 @@ -976,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 () @@ -988,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) @@ -1008,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 = [] } @@ -1018,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"] @@ -1070,18 +1079,16 @@ hscSimpleIface' tc_result mb_old_iface = do return (new_iface, no_change, details) hscNormalIface :: HscEnv - -> FilePath -> ModGuts -> Maybe Fingerprint -> IO (ModIface, Bool, ModDetails, CgGuts) -hscNormalIface hsc_env extCore_filename simpl_result mb_old_iface = - runHsc hsc_env $ hscNormalIface' extCore_filename simpl_result mb_old_iface +hscNormalIface hsc_env simpl_result mb_old_iface = + runHsc hsc_env $ hscNormalIface' simpl_result mb_old_iface -hscNormalIface' :: FilePath - -> ModGuts +hscNormalIface' :: ModGuts -> Maybe Fingerprint -> Hsc (ModIface, Bool, ModDetails, CgGuts) -hscNormalIface' extCore_filename simpl_result mb_old_iface = do +hscNormalIface' simpl_result mb_old_iface = do hsc_env <- getHscEnv (cg_guts, details) <- {-# SCC "CoreTidy" #-} liftIO $ tidyProgram hsc_env simpl_result @@ -1096,11 +1103,6 @@ hscNormalIface' extCore_filename simpl_result mb_old_iface = do ioMsgMaybe $ mkIface hsc_env mb_old_iface details simpl_result - -- Emit external core - -- This should definitely be here and not after CorePrep, - -- because CorePrep produces unqualified constructor wrapper declarations, - -- so its output isn't valid External Core (without some preprocessing). - liftIO $ emitExternalCore (hsc_dflags hsc_env) extCore_filename cg_guts liftIO $ dumpIfaceStats hsc_env -- Return the prepared code. @@ -1158,8 +1160,15 @@ hscGenHardCode hsc_env cgguts mod_summary output_filename = do ------------------ Code generation ------------------ - cmms <- {-# SCC "NewCodeGen" #-} - tryNewCodeGen hsc_env this_mod data_tycons + -- The back-end is streamed: each top-level function goes + -- from Stg all the way to asm before dealing with the next + -- top-level function, so showPass isn't very useful here. + -- Hence we have one showPass for the whole backend, the + -- next showPass after this will be "Assembler". + showPass dflags "CodeGen" + + cmms <- {-# SCC "StgCmm" #-} + doCodeGen hsc_env this_mod data_tycons cost_centre_info stg_binds hpc_info @@ -1236,15 +1245,15 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do -------------------- Stuff for new code gen --------------------- -tryNewCodeGen :: HscEnv -> Module -> [TyCon] - -> CollectedCCs - -> [StgBinding] - -> HpcInfo - -> IO (Stream IO CmmGroup ()) +doCodeGen :: HscEnv -> Module -> [TyCon] + -> CollectedCCs + -> [StgBinding] + -> HpcInfo + -> IO (Stream IO CmmGroup ()) -- Note we produce a 'Stream' of CmmGroups, so that the -- backend can be run incrementally. Otherwise it generates all -- the C-- up front, which has a significant space cost. -tryNewCodeGen hsc_env this_mod data_tycons +doCodeGen hsc_env this_mod data_tycons cost_centre_info stg_binds hpc_info = do let dflags = hsc_dflags hsc_env @@ -1365,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 @@ -1533,11 +1542,11 @@ hscParseThingWithLocation source linenumber parser str return thing hscCompileCore :: HscEnv -> Bool -> SafeHaskellMode -> ModSummary - -> CoreProgram -> FilePath -> FilePath -> IO () -hscCompileCore hsc_env simplify safe_mode mod_summary binds output_filename extCore_filename + -> CoreProgram -> FilePath -> IO () +hscCompileCore hsc_env simplify safe_mode mod_summary binds output_filename = runHsc hsc_env $ do guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) safe_mode binds) - (iface, changed, _details, cgguts) <- hscNormalIface' extCore_filename guts Nothing + (iface, changed, _details, cgguts) <- hscNormalIface' guts Nothing liftIO $ hscWriteIface (hsc_dflags hsc_env) iface changed mod_summary _ <- liftIO $ hscGenHardCode hsc_env cgguts mod_summary output_filename return () diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs index 715ee8130c..4f901b1849 100644 --- a/compiler/main/HscStats.hs +++ b/compiler/main/HscStats.hs @@ -132,7 +132,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) class_info decl@(ClassDecl {}) = (classops, addpr (sum3 (map count_bind methods))) where - methods = map (unLoc . snd) $ bagToList (tcdMeths decl) + methods = map unLoc $ bagToList (tcdMeths decl) (_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl)) class_info _ = (0,0) @@ -147,7 +147,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) (addpr (sum3 (map count_bind methods)), ss, is, length ats, length adts) where - methods = map (unLoc . snd) $ bagToList inst_meths + methods = map unLoc $ bagToList inst_meths -- TODO: use Sum monoid addpr :: (Int,Int,Int) -> Int diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 6fcf8e24a7..123b0777fc 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -4,6 +4,7 @@ \section[HscTypes]{Types for the per-module compiler} \begin{code} +{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} -- | Types for the per-module compiler module HscTypes ( @@ -53,6 +54,7 @@ module HscTypes ( setInteractivePrintName, icInteractiveModule, InteractiveImport(..), setInteractivePackage, mkPrintUnqualified, pprModulePrefix, + mkQualPackage, mkQualModule, pkgQual, -- * Interfaces ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache, @@ -71,7 +73,7 @@ module HscTypes ( TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv, typeEnvFromEntities, mkTypeEnvWithImplicits, extendTypeEnv, extendTypeEnvList, - extendTypeEnvWithIds, extendTypeEnvWithPatSyns, + extendTypeEnvWithIds, lookupTypeEnv, typeEnvElts, typeEnvTyCons, typeEnvIds, typeEnvPatSyns, typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses, @@ -442,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 @@ -633,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 @@ -951,7 +953,8 @@ data ModDetails -- The next two fields are created by the typechecker md_exports :: [AvailInfo], md_types :: !TypeEnv, -- ^ Local type environment for this particular module - md_insts :: ![ClsInst], -- ^ 'DFunId's for the instances in this module + -- Includes Ids, TyCons, PatSyns + md_insts :: ![ClsInst], -- ^ 'DFunId's for the instances in this module md_fam_insts :: ![FamInst], md_rules :: ![CoreRule], -- ^ Domain may include 'Id's from other modules md_anns :: ![Annotation], -- ^ Annotations present in this module: currently @@ -993,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 @@ -1065,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 @@ -1098,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: @@ -1136,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 @@ -1146,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] @@ -1339,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} @@ -1406,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 @@ -1443,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} @@ -1483,7 +1534,7 @@ Examples: IfaceClass decl happens to use IfaceDecl recursively for the associated types, but that's irrelevant here.) - * Dictionary function Ids are not implict. + * Dictionary function Ids are not implicit. * Axioms for newtypes are implicit (same as above), but axioms for data/type family instances are *not* implicit (like DFunIds). @@ -1504,15 +1555,17 @@ implicitTyThings :: TyThing -> [TyThing] implicitTyThings (AnId _) = [] implicitTyThings (ACoAxiom _cc) = [] implicitTyThings (ATyCon tc) = implicitTyConThings tc -implicitTyThings (AConLike cl) = case cl of - RealDataCon dc -> - -- For data cons add the worker and (possibly) wrapper - map AnId (dataConImplicitIds dc) - PatSynCon ps -> - -- For bidirectional pattern synonyms, add the wrapper - case patSynWrapper ps of - Nothing -> [] - Just id -> [AnId id] +implicitTyThings (AConLike cl) = implicitConLikeThings cl + +implicitConLikeThings :: ConLike -> [TyThing] +implicitConLikeThings (RealDataCon dc) + = map AnId (dataConImplicitIds dc) + -- For data cons add the worker and (possibly) wrapper + +implicitConLikeThings (PatSynCon {}) + = [] -- Pattern synonyms have no implicit Ids; the wrapper and matcher + -- are not "implicit"; they are simply new top-level bindings, + -- and they have their own declaration in an interface fiel implicitClassThings :: Class -> [TyThing] implicitClassThings cl @@ -1561,8 +1614,8 @@ implicitCoTyCon tc -- other declaration. isImplicitTyThing :: TyThing -> Bool isImplicitTyThing (AConLike cl) = case cl of - RealDataCon{} -> True - PatSynCon ps -> isImplicitId (patSynId ps) + RealDataCon {} -> True + PatSynCon {} -> False isImplicitTyThing (AnId id) = isImplicitId id isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax @@ -1678,17 +1731,6 @@ extendTypeEnvList env things = foldl extendTypeEnv env things extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv extendTypeEnvWithIds env ids = extendNameEnvList env [(getName id, AnId id) | id <- ids] - -extendTypeEnvWithPatSyns :: TypeEnv -> [PatSyn] -> TypeEnv -extendTypeEnvWithPatSyns env patsyns - = extendNameEnvList env $ concatMap pat_syn_things patsyns - where - pat_syn_things :: PatSyn -> [(Name, TyThing)] - pat_syn_things ps = (getName ps, AConLike (PatSynCon ps)): - case patSynWrapper ps of - Just wrap_id -> [(getName wrap_id, AnId wrap_id)] - Nothing -> [] - \end{code} \begin{code} @@ -1911,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 @@ -2207,37 +2249,50 @@ type ModuleGraph = [ModSummary] emptyMG :: ModuleGraph emptyMG = [] --- | A single node in a 'ModuleGraph. The nodes of the module graph are one of: +-- | A single node in a 'ModuleGraph'. The nodes of the module graph +-- are one of: -- -- * A regular Haskell source module --- -- * A hi-boot source module --- -- * An external-core source module +-- data ModSummary = ModSummary { - ms_mod :: Module, -- ^ Identity of the module - ms_hsc_src :: HscSource, -- ^ The module source either plain Haskell, hs-boot or external core - ms_location :: ModLocation, -- ^ Location of the various files belonging to the module - ms_hs_date :: UTCTime, -- ^ Timestamp of source file - ms_obj_date :: Maybe UTCTime, -- ^ Timestamp of object, if we have one - ms_srcimps :: [Located (ImportDecl RdrName)], -- ^ Source imports of the module - ms_textual_imps :: [Located (ImportDecl RdrName)], -- ^ Non-source imports of the module from the module *text* - ms_hspp_file :: FilePath, -- ^ Filename of preprocessed source file - ms_hspp_opts :: DynFlags, -- ^ Cached flags from @OPTIONS@, @INCLUDE@ - -- and @LANGUAGE@ pragmas in the modules source code - ms_hspp_buf :: Maybe StringBuffer -- ^ The actual preprocessed source, if we have it + ms_mod :: Module, + -- ^ Identity of the module + ms_hsc_src :: HscSource, + -- ^ The module source either plain Haskell, hs-boot or external core + ms_location :: ModLocation, + -- ^ Location of the various files belonging to the module + ms_hs_date :: UTCTime, + -- ^ Timestamp of source file + ms_obj_date :: Maybe UTCTime, + -- ^ Timestamp of object, if we have one + ms_srcimps :: [Located (ImportDecl RdrName)], + -- ^ Source imports of the module + ms_textual_imps :: [Located (ImportDecl RdrName)], + -- ^ Non-source imports of the module from the module *text* + ms_hspp_file :: FilePath, + -- ^ Filename of preprocessed source file + ms_hspp_opts :: DynFlags, + -- ^ Cached flags from @OPTIONS@, @INCLUDE@ and @LANGUAGE@ + -- pragmas in the modules source code + ms_hspp_buf :: Maybe StringBuffer + -- ^ The actual preprocessed source, if we have it } ms_mod_name :: ModSummary -> ModuleName ms_mod_name = moduleName . ms_mod ms_imps :: ModSummary -> [Located (ImportDecl RdrName)] -ms_imps ms = ms_textual_imps ms ++ map mk_additional_import (dynFlagDependencies (ms_hspp_opts ms)) +ms_imps ms = + ms_textual_imps ms ++ + map mk_additional_import (dynFlagDependencies (ms_hspp_opts ms)) where - -- This is a not-entirely-satisfactory means of creating an import that corresponds to an - -- import that did not occur in the program text, such as those induced by the use of - -- plugins (the -plgFoo flag) + -- This is a not-entirely-satisfactory means of creating an import + -- that corresponds to an import that did not occur in the program + -- text, such as those induced by the use of plugins (the -plgFoo + -- flag) mk_additional_import mod_nm = noLoc $ ImportDecl { ideclName = noLoc mod_nm, ideclPkgQual = Nothing, @@ -2487,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 @@ -2502,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 ede519982a..d60cf56eba 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, UnboxedTuples #-} + -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow, 2005-2007 @@ -877,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/InteractiveEvalTypes.hs b/compiler/main/InteractiveEvalTypes.hs index e3324a39a1..6ea1a25648 100644 --- a/compiler/main/InteractiveEvalTypes.hs +++ b/compiler/main/InteractiveEvalTypes.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow, 2005-2007 diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs index d34d9e1f5c..864980be9d 100644 --- a/compiler/main/PackageConfig.hs +++ b/compiler/main/PackageConfig.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- | -- Package configuration information: essentially the interface to Cabal, with -- some utilities @@ -7,8 +9,8 @@ module PackageConfig ( -- $package_naming - -- * PackageId - mkPackageId, packageConfigId, + -- * PackageKey + mkPackageKey, packageConfigId, -- * The PackageConfig type: information about a package PackageConfig, @@ -24,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 @@ -41,36 +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 'PackageName's, which don't --- have the version suffix. This is so that we don't need to know the --- version for the @-package-name@ flag, or know the versions of --- wired-in packages like @base@ & @rts@. Versions are confined to the --- package sub-system. --- --- This means that in theory you could have multiple base packages installed --- (for example), and switch between them using @-package@\/@-hide-package@. --- --- A 'PackageId' is a string of the form @<pkg>-<version>@. +-- 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 @@ -80,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 a13b3599b8..78c8059046 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -2,19 +2,29 @@ % (c) The University of Glasgow, 2006 % \begin{code} +{-# LANGUAGE CPP, ScopedTypeVariables #-} + -- | Package manipulation module Packages ( module PackageConfig, - -- * The PackageConfigMap - PackageConfigMap, emptyPackageConfigMap, lookupPackage, - extendPackageConfigMap, dumpPackages, - -- * 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, @@ -27,8 +37,12 @@ module Packages ( collectIncludeDirs, collectLibraryPaths, collectLinkOpts, packageHsLibs, + ModuleExport(..), -- * Utils + packageKeyPackageIdString, + pprFlag, + pprModuleMap, isDllName ) where @@ -49,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 @@ -61,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 @@ -73,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. @@ -107,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 @@ -148,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 @@ -167,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 @@ -249,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 @@ -316,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. @@ -396,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))) @@ -409,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\"." @@ -417,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 @@ -472,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 @@ -491,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) @@ -540,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 @@ -553,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 @@ -569,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") <+> @@ -589,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) @@ -618,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 -- ----------------------------------------------------------------------------- @@ -639,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 @@ -667,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 @@ -682,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 @@ -735,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 @@ -767,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 @@ -794,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 @@ -806,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)) @@ -852,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 @@ -860,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 @@ -869,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 @@ -917,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) @@ -937,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 @@ -981,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) @@ -1000,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 @@ -1035,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 @@ -1078,12 +1429,39 @@ isDllName dflags _this_pkg this_mod name -- ----------------------------------------------------------------------------- -- Displaying packages --- | Show package info on console, if verbosity is >= 3 +-- | Show (very verbose) package info on console, if verbosity is >= 5 dumpPackages :: DynFlags -> IO () -dumpPackages dflags - = do let pkg_map = pkgIdMap (pkgState dflags) - putMsg dflags $ - vcat (map (text . showInstalledPackageInfo +dumpPackages = dumpPackages' showInstalledPackageInfo + +dumpPackages' :: (InstalledPackageInfo -> String) -> DynFlags -> IO () +dumpPackages' showIPI 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 +-- be different from the package databases (exposure, trust) +simpleDumpPackages :: DynFlags -> IO () +simpleDumpPackages = dumpPackages' showIPI + where showIPI ipi = let InstalledPackageId i = installedPackageId ipi + e = if exposed ipi then "E" else " " + 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/PlatformConstants.hs b/compiler/main/PlatformConstants.hs index 03e146ca7c..b2ca32be68 100644 --- a/compiler/main/PlatformConstants.hs +++ b/compiler/main/PlatformConstants.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ------------------------------------------------------------------------------- -- -- | Platform constants diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index 1fd5d0cbcf..eed4671b67 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -6,64 +6,90 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - +{-# LANGUAGE CPP #-} module PprTyThing ( - pprTyThing, - pprTyThingInContext, - pprTyThingLoc, - pprTyThingInContextLoc, - pprTyThingHdr, - pprTypeForUser + pprTyThing, + pprTyThingInContext, + pprTyThingLoc, + pprTyThingInContextLoc, + pprTyThingHdr, + pprTypeForUser, + pprFamInst ) where +#include "HsVersions.h" + import TypeRep ( TyThing(..) ) -import DataCon -import Id -import TyCon -import Class -import Coercion( pprCoAxBranch ) -import CoAxiom( CoAxiom(..), brListMap ) +import CoAxiom ( coAxiomTyCon ) import HscTypes( tyThingParent_maybe ) -import Type( tidyTopType, tidyOpenType, splitForAllTys, funResultTy ) -import Kind( synTyConResKind ) -import TypeRep( pprTvBndrs, pprForAll, suppressKinds ) -import TysPrim( alphaTyVars ) import MkIface ( tyThingToIfaceDecl ) +import Type ( tidyOpenType ) +import IfaceSyn ( pprIfaceDecl, ShowSub(..), ShowHowMuch(..) ) +import FamInstEnv( FamInst( .. ), FamFlavor(..) ) import TcType import Name import VarEnv( emptyTidyEnv ) -import StaticFlags( opt_PprStyle_Debug ) -import DynFlags import Outputable import FastString -- ----------------------------------------------------------------------------- -- Pretty-printing entities that we get from the GHC API --- This should be a good source of sample code for using the GHC API to --- inspect source code entities. - -type ShowSub = [Name] --- [] <=> print all sub-components of the current thing --- (n:ns) <=> print sub-component 'n' with ShowSub=ns --- elide other sub-components to "..." -showAll :: ShowSub -showAll = [] +{- Note [Pretty-printing TyThings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We pretty-print a TyThing by converting it to an IfaceDecl, +and pretty-printing that (see ppr_ty_thing below). +Here is why: + +* When pretty-printing (a type, say), the idiomatic solution is not to + "rename type variables on the fly", but rather to "tidy" the type + (which gives each variable a distinct print-name), and then + pretty-print it (without renaming). Separate the two + concerns. Functions like tidyType do this. + +* Alas, for type constructors, TyCon, tidying does not work well, + because a TyCon includes DataCons which include Types, which mention + TyCons. And tidying can't tidy a mutually recursive data structure + graph, only trees. + +* One alternative would be to ensure that TyCons get type variables + with distinct print-names. That's ok for type variables but less + easy for kind variables. Processing data type declarations is + already so complicated that I don't think it's sensible to add the + extra requirement that it generates only "pretty" types and kinds. + +* One place the non-pretty names can show up is in GHCi. But another + is in interface files. Look at MkIface.tyThingToIfaceDecl which + converts a TyThing (i.e. TyCon, Class etc) to an IfaceDecl. And it + already does tidying as part of that conversion! Why? Because + interface files contains fast-strings, not uniques, so the names + must at least be distinct. + +So if we convert to IfaceDecl, we get a nice tidy IfaceDecl, and can +print that. Of course, that means that pretty-printing IfaceDecls +must be careful to display nice user-friendly results, but that's ok. + +See #7730, #8776 for details -} + +-------------------- +-- | Pretty-prints a 'FamInst' (type/data family instance) with its defining location. +pprFamInst :: FamInst -> SDoc +-- * For data instances we go via pprTyThing of the represntational TyCon, +-- because there is already much cleverness associated with printing +-- data type declarations that I don't want to duplicate +-- * For type instances we print directly here; there is no TyCon +-- to give to pprTyThing +-- +-- FamInstEnv.pprFamInst does a more quick-and-dirty job for internal purposes -showSub :: NamedThing n => ShowSub -> n -> Bool -showSub [] _ = True -showSub (n:_) thing = n == getName thing +pprFamInst (FamInst { fi_flavor = DataFamilyInst rep_tc }) + = pprTyThingInContextLoc (ATyCon rep_tc) -showSub_maybe :: NamedThing n => ShowSub -> n -> Maybe ShowSub -showSub_maybe [] _ = Just [] -showSub_maybe (n:ns) thing = if n == getName thing then Just ns - else Nothing +pprFamInst (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom + , fi_tys = lhs_tys, fi_rhs = rhs }) + = showWithLoc (pprDefinedAt (getName axiom)) $ + hang (ptext (sLit "type instance") <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys) + 2 (equals <+> ppr rhs) ---------------------------- -- | Pretty-prints a 'TyThing' with its defining location. @@ -73,7 +99,13 @@ pprTyThingLoc tyThing -- | Pretty-prints a 'TyThing'. pprTyThing :: TyThing -> SDoc -pprTyThing thing = ppr_ty_thing (Just showAll) thing +pprTyThing = ppr_ty_thing False [] + +-- | Pretty-prints the 'TyThing' header. For functions and data constructors +-- the function is equivalent to 'pprTyThing' but for type constructors +-- and classes it prints only the header part of the declaration. +pprTyThingHdr :: TyThing -> SDoc +pprTyThingHdr = ppr_ty_thing True [] -- | Pretty-prints a 'TyThing' in context: that is, if the entity -- is a data constructor, record selector, or class method, then @@ -84,8 +116,8 @@ pprTyThingInContext thing = go [] thing where go ss thing = case tyThingParent_maybe thing of - Just parent -> go (getName thing : ss) parent - Nothing -> ppr_ty_thing (Just ss) thing + Just parent -> go (getOccName thing : ss) parent + Nothing -> ppr_ty_thing False ss thing -- | Like 'pprTyThingInContext', but adds the defining location. pprTyThingInContextLoc :: TyThing -> SDoc @@ -93,256 +125,49 @@ pprTyThingInContextLoc tyThing = showWithLoc (pprDefinedAt (getName tyThing)) (pprTyThingInContext tyThing) --- | Pretty-prints the 'TyThing' header. For functions and data constructors --- the function is equivalent to 'pprTyThing' but for type constructors --- and classes it prints only the header part of the declaration. -pprTyThingHdr :: TyThing -> SDoc -pprTyThingHdr = ppr_ty_thing Nothing - ------------------------ --- NOTE: We pretty-print 'TyThing' via 'IfaceDecl' so that we can reuse the --- 'TyCon' tidying happening in 'tyThingToIfaceDecl'. See #8776 for details. -ppr_ty_thing :: Maybe ShowSub -> TyThing -> SDoc -ppr_ty_thing mss tyThing = case tyThing of - AnId id -> pprId id - ATyCon tyCon -> case mss of - Nothing -> pprTyConHdr tyCon - Just ss -> pprTyCon ss tyCon - _ -> ppr $ tyThingToIfaceDecl tyThing - -pprTyConHdr :: TyCon -> SDoc -pprTyConHdr tyCon - | Just (fam_tc, tys) <- tyConFamInst_maybe tyCon - = ptext keyword <+> ptext (sLit "instance") <+> pprTypeApp fam_tc tys - | Just cls <- tyConClass_maybe tyCon - = pprClassHdr cls - | otherwise - = sdocWithDynFlags $ \dflags -> - ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon - <+> pprTvBndrs (suppressKinds dflags (tyConKind tyCon) vars) - where - vars | isPrimTyCon tyCon || - isFunTyCon tyCon = take (tyConArity tyCon) alphaTyVars - | otherwise = tyConTyVars tyCon - - keyword | isSynTyCon tyCon = sLit "type" - | isNewTyCon tyCon = sLit "newtype" - | otherwise = sLit "data" - - opt_family - | isFamilyTyCon tyCon = ptext (sLit "family") - | otherwise = empty - - opt_stupid -- The "stupid theta" part of the declaration - | isAlgTyCon tyCon = pprThetaArrowTy (tyConStupidTheta tyCon) - | otherwise = empty -- Returns 'empty' if null theta - -pprClassHdr :: Class -> SDoc -pprClassHdr cls - = sdocWithDynFlags $ \dflags -> - ptext (sLit "class") <+> - sep [ pprThetaArrowTy (classSCTheta cls) - , ppr_bndr cls - <+> pprTvBndrs (suppressKinds dflags (tyConKind (classTyCon cls)) tvs) - , pprFundeps funDeps ] +ppr_ty_thing :: Bool -> [OccName] -> TyThing -> SDoc +-- We pretty-print 'TyThing' via 'IfaceDecl' +-- See Note [Pretty-pringint TyThings] +ppr_ty_thing hdr_only path ty_thing + = pprIfaceDecl ss (tyThingToIfaceDecl ty_thing) where - (tvs, funDeps) = classTvsFds cls - -pprId :: Var -> SDoc -pprId ident - = hang (ppr_bndr ident <+> dcolon) - 2 (pprTypeForUser (idType ident)) + ss = ShowSub { ss_how_much = how_much, ss_ppr_bndr = ppr_bndr } + how_much | hdr_only = ShowHeader + | otherwise = ShowSome path + name = getName ty_thing + ppr_bndr :: OccName -> SDoc + ppr_bndr | isBuiltInSyntax name + = ppr + | otherwise + = case nameModule_maybe name of + Just mod -> \ occ -> getPprStyle $ \sty -> + pprModulePrefix sty mod occ <> ppr occ + Nothing -> WARN( True, ppr name ) ppr + -- Nothing is unexpected here; TyThings have External names pprTypeForUser :: Type -> SDoc -- We do two things here. -- a) We tidy the type, regardless --- b) If Opt_PrintExplicitForAlls is True, we discard the foralls --- but we do so `deeply' +-- 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 - = sdocWithDynFlags $ \ dflags -> - if gopt Opt_PrintExplicitForalls dflags - then ppr tidy_ty - else ppr (mkPhiTy ctxt ty') + = pprSigmaType (mkSigmaTy tvs ctxt tau) where - (_, ctxt, ty') = tcSplitSigmaTy tidy_ty - (_, tidy_ty) = tidyOpenType emptyTidyEnv ty + (tvs, ctxt, tau) = tcSplitSigmaTy tidy_ty + (_, tidy_ty) = tidyOpenType emptyTidyEnv ty -- Often the types/kinds we print in ghci are fully generalised -- and have no free variables, but it turns out that we sometimes -- print un-generalised kinds (eg when doing :k T), so it's -- better to use tidyOpenType here -pprTyCon :: ShowSub -> TyCon -> SDoc -pprTyCon ss tyCon - | Just syn_rhs <- synTyConRhs_maybe tyCon - = case syn_rhs of - OpenSynFamilyTyCon -> pp_tc_with_kind - BuiltInSynFamTyCon {} -> pp_tc_with_kind - - ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) - -> hang closed_family_header - 2 (vcat (brListMap (pprCoAxBranch tyCon) branches)) - - AbstractClosedSynFamilyTyCon - -> closed_family_header <+> ptext (sLit "..") - - SynonymTyCon rhs_ty - -> hang (pprTyConHdr tyCon <+> equals) - 2 (ppr rhs_ty) -- Don't suppress foralls on RHS type! - - -- e.g. type T = forall a. a->a - | Just cls <- tyConClass_maybe tyCon - = (pp_roles (== Nominal)) $$ pprClass ss cls - - | otherwise - = (pp_roles (== Representational)) $$ pprAlgTyCon ss tyCon - - where - -- if, for each role, suppress_if role is True, then suppress the role - -- output - pp_roles :: (Role -> Bool) -> SDoc - pp_roles suppress_if - = sdocWithDynFlags $ \dflags -> - let roles = suppressKinds dflags (tyConKind tyCon) (tyConRoles tyCon) - in ppUnless (isFamInstTyCon tyCon || all suppress_if roles) $ - -- Don't display roles for data family instances (yet) - -- See discussion on Trac #8672. - ptext (sLit "type role") <+> ppr tyCon <+> hsep (map ppr roles) - - pp_tc_with_kind = vcat [ pp_roles (const True) - , pprTyConHdr tyCon <+> dcolon - <+> pprTypeForUser (synTyConResKind tyCon) ] - closed_family_header - = pp_tc_with_kind <+> ptext (sLit "where") - -pprAlgTyCon :: ShowSub -> TyCon -> SDoc -pprAlgTyCon ss tyCon - | gadt = pprTyConHdr tyCon <+> ptext (sLit "where") $$ - nest 2 (vcat (ppr_trim (map show_con datacons))) - | otherwise = hang (pprTyConHdr tyCon) - 2 (add_bars (ppr_trim (map show_con datacons))) - where - datacons = tyConDataCons tyCon - gadt = any (not . isVanillaDataCon) datacons - - ok_con dc = showSub ss dc || any (showSub ss) (dataConFieldLabels dc) - show_con dc - | ok_con dc = Just (pprDataConDecl ss gadt dc) - | otherwise = Nothing - -pprDataConDecl :: ShowSub -> Bool -> DataCon -> SDoc -pprDataConDecl ss gadt_style dataCon - | not gadt_style = ppr_fields tys_w_strs - | otherwise = ppr_bndr dataCon <+> dcolon <+> - sep [ pp_foralls, pprThetaArrowTy theta, pp_tau ] - -- Printing out the dataCon as a type signature, in GADT style - where - (forall_tvs, theta, tau) = tcSplitSigmaTy (dataConUserType dataCon) - (arg_tys, res_ty) = tcSplitFunTys tau - labels = dataConFieldLabels dataCon - stricts = dataConStrictMarks dataCon - tys_w_strs = zip (map user_ify stricts) arg_tys - pp_foralls = sdocWithDynFlags $ \dflags -> - ppWhen (gopt Opt_PrintExplicitForalls dflags) - (pprForAll forall_tvs) - - pp_tau = foldr add (ppr res_ty) tys_w_strs - add str_ty pp_ty = pprParendBangTy str_ty <+> arrow <+> pp_ty - - pprParendBangTy (bang,ty) = ppr bang <> pprParendType ty - pprBangTy (bang,ty) = ppr bang <> ppr ty - - -- See Note [Printing bangs on data constructors] - user_ify :: HsBang -> HsBang - user_ify bang | opt_PprStyle_Debug = bang - user_ify HsStrict = HsUserBang Nothing True - user_ify (HsUnpack {}) = HsUserBang (Just True) True - user_ify bang = bang - - maybe_show_label (lbl,bty) - | showSub ss lbl = Just (ppr_bndr lbl <+> dcolon <+> pprBangTy bty) - | otherwise = Nothing - - ppr_fields [ty1, ty2] - | dataConIsInfix dataCon && null labels - = sep [pprParendBangTy ty1, pprInfixName dataCon, pprParendBangTy ty2] - ppr_fields fields - | null labels - = ppr_bndr dataCon <+> sep (map pprParendBangTy fields) - | otherwise - = ppr_bndr dataCon - <+> (braces $ sep $ punctuate comma $ ppr_trim $ - map maybe_show_label (zip labels fields)) - -pprClass :: ShowSub -> Class -> SDoc -pprClass ss cls - | null methods && null assoc_ts - = pprClassHdr cls - | otherwise - = vcat [ pprClassHdr cls <+> ptext (sLit "where") - , nest 2 (vcat $ ppr_trim $ - map show_at assoc_ts ++ map show_meth methods)] - where - methods = classMethods cls - assoc_ts = classATs cls - show_meth id | showSub ss id = Just (pprClassMethod id) - | otherwise = Nothing - show_at tc = case showSub_maybe ss tc of - Just ss' -> Just (pprTyCon ss' tc) - Nothing -> Nothing - -pprClassMethod :: Id -> SDoc -pprClassMethod id - = hang (ppr_bndr id <+> dcolon) 2 (pprTypeForUser op_ty) - where - -- Here's the magic incantation to strip off the dictionary - -- from the class op type. Stolen from IfaceSyn.tyThingToIfaceDecl. - -- - -- It's important to tidy it *before* splitting it up, so that if - -- we have class C a b where - -- op :: forall a. a -> b - -- then the inner forall on op gets renamed to a1, and we print - -- (when dropping foralls) - -- class C a b where - -- op :: a1 -> b - - tidy_sel_ty = tidyTopType (idType id) - (_sel_tyvars, rho_ty) = splitForAllTys tidy_sel_ty - op_ty = funResultTy rho_ty - -ppr_trim :: [Maybe SDoc] -> [SDoc] --- Collapse a group of Nothings to a single "..." -ppr_trim xs - = snd (foldr go (False, []) xs) - where - go (Just doc) (_, so_far) = (False, doc : so_far) - go Nothing (True, so_far) = (True, so_far) - go Nothing (False, so_far) = (True, ptext (sLit "...") : so_far) - -add_bars :: [SDoc] -> SDoc -add_bars [] = empty -add_bars [c] = equals <+> c -add_bars (c:cs) = sep ((equals <+> c) : map (char '|' <+>) cs) - --- Wrap operators in () -ppr_bndr :: NamedThing a => a -> SDoc -ppr_bndr a = parenSymOcc (getOccName a) (ppr (getName a)) - 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 "--") - -{- -Note [Printing bangs on data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For imported data constructors the dataConStrictMarks are the -representation choices (see Note [Bangs on data constructor arguments] -in DataCon.lhs). So we have to fiddle a little bit here to turn them -back into user-printable form. --} diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index 01dc3b7275..eb7ede00c6 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -1,4 +1,5 @@ -{-# OPTIONS -fno-cse #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-cse #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly ----------------------------------------------------------------------------- diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index ad059d7fe6..72fa19b3cc 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -7,6 +7,8 @@ ----------------------------------------------------------------------------- \begin{code} +{-# LANGUAGE CPP, ScopedTypeVariables #-} + module SysTools ( -- Initialisation initSysTools, @@ -233,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 [] @@ -241,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) @@ -283,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" @@ -602,6 +604,42 @@ figureLlvmVersion dflags = do return Nothing) return ver +{- Note [Windows stack usage] + +See: Trac #8870 (and #8834 for related info) + +On Windows, occasionally we need to grow the stack. In order to do +this, we would normally just bump the stack pointer - but there's a +catch on Windows. + +If the stack pointer is bumped by more than a single page, then the +pages between the initial pointer and the resulting location must be +properly committed by the Windows virtual memory subsystem. This is +only needed in the event we bump by more than one page (i.e 4097 bytes +or more). + +Windows compilers solve this by emitting a call to a special function +called _chkstk, which does this committing of the pages for you. + +The reason this was causing a segfault was because due to the fact the +new code generator tends to generate larger functions, we needed more +stack space in GHC itself. In the x86 codegen, we needed approximately +~12kb of stack space in one go, which caused the process to segfault, +as the intervening pages were not committed. + +In the future, we should do the same thing, to make the problem +completely go away. In the mean time, we're using a workaround: we +instruct the linker to specify the generated PE as having an initial +reserved stack size of 8mb, as well as a initial *committed* stack +size of 8mb. The default committed size was previously only 4k. + +Theoretically it's possible to still hit this problem if you request a +stack bump of more than 8mb in one go. But the amount of code +necessary is quite large, and 8mb "should be more than enough for +anyone" right now (he said, before millions of lines of code cried out +in terror). + +-} {- Note [Run-time linker info] @@ -691,15 +729,20 @@ getLinkerInfo' dflags = do -- that doesn't support --version. We can just assume that's -- what we're using. return $ DarwinLD [] - OSiOS -> + OSiOS -> -- Ditto for iOS return $ DarwinLD [] OSMinGW32 -> -- GHC doesn't support anything but GNU ld on Windows anyway. -- Process creation is also fairly expensive on win32, so -- we short-circuit here. - return $ GnuLD $ map Option ["-Wl,--hash-size=31", - "-Wl,--reduce-memory-overheads"] + return $ GnuLD $ map Option + [ -- Reduce ld memory usage + "-Wl,--hash-size=31" + , "-Wl,--reduce-memory-overheads" + -- Increase default stack, see + -- Note [Windows stack usage] + , "-Xlinker", "--stack=0x800000,0x800000" ] _ -> do -- In practice, we use the compiler as the linker here. Pass -- -Wl,--version to get linker version info. @@ -745,12 +788,15 @@ getCompilerInfo' dflags = do -- Regular clang | any ("clang version" `isPrefixOf`) stde = return Clang + -- XCode 5.1 clang + | any ("Apple LLVM version 5.1" `isPrefixOf`) stde = + return AppleClang51 -- XCode 5 clang | any ("Apple LLVM version" `isPrefixOf`) stde = - return Clang + return AppleClang -- XCode 4.1 clang | any ("Apple clang version" `isPrefixOf`) stde = - return Clang + return AppleClang -- Unknown linker. | otherwise = fail "invalid -v output, or compiler is unsupported" @@ -763,10 +809,10 @@ getCompilerInfo' dflags = do ) (\err -> do debugTraceMsg dflags 2 - (text "Error (figuring out compiler information):" <+> + (text "Error (figuring out C compiler information):" <+> text (show err)) errorMsg dflags $ hang (text "Warning:") 9 $ - text "Couldn't figure out linker information!" $$ + text "Couldn't figure out C compiler information!" $$ text "Make sure you're using GNU gcc, or clang" return UnknownCC) return info @@ -779,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 @@ -1270,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 @@ -1316,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 @@ -1418,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 97ad1719cb..087139984a 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -4,6 +4,8 @@ \section{Tidying up Core} \begin{code} +{-# LANGUAGE CPP #-} + module TidyPgm ( mkBootModDetailsTc, tidyProgram, globaliseAndTidyId, addExternal @@ -22,11 +24,14 @@ import CorePrep import CoreUtils import Literal import Rules +import PatSyn +import ConLike import CoreArity ( exprArity, exprBotStrictness_maybe ) import VarEnv import VarSet import Var import Id +import MkId ( mkDictSelRhs ) import IdInfo import InstEnv import FamInstEnv @@ -130,18 +135,20 @@ mkBootModDetailsTc hsc_env TcGblEnv{ tcg_exports = exports, tcg_type_env = type_env, -- just for the Ids tcg_tcs = tcs, + tcg_patsyns = pat_syns, tcg_insts = insts, tcg_fam_insts = fam_insts } = do { let dflags = hsc_dflags hsc_env ; showPass dflags CoreTidy - ; let { insts' = map (tidyClsInstDFun globaliseAndTidyId) insts - ; dfun_ids = map instanceDFunId insts' + ; let { insts' = map (tidyClsInstDFun globaliseAndTidyId) insts + ; pat_syns' = map (tidyPatSynIds globaliseAndTidyId) pat_syns + ; dfun_ids = map instanceDFunId insts' + ; pat_syn_ids = concatMap patSynIds pat_syns' ; type_env1 = mkBootTypeEnv (availsToNameSet exports) - (typeEnvIds type_env) tcs fam_insts - ; type_env2 = extendTypeEnvWithPatSyns type_env1 (typeEnvPatSyns type_env) - ; type_env' = extendTypeEnvWithIds type_env2 dfun_ids + (typeEnvIds type_env) tcs fam_insts + ; type_env' = extendTypeEnvWithIds type_env1 (pat_syn_ids ++ dfun_ids) } ; return (ModDetails { md_types = type_env' , md_insts = insts' @@ -334,19 +341,13 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ; let { final_ids = [ id | id <- bindersOfBinds tidy_binds, isExternalName (idName id)] - ; final_patsyns = filter (isExternalName . getName) patsyns - - ; type_env' = extendTypeEnvWithIds type_env final_ids - ; type_env'' = extendTypeEnvWithPatSyns type_env' final_patsyns - - ; tidy_type_env = tidyTypeEnv omit_prags type_env'' + ; type_env1 = extendTypeEnvWithIds type_env final_ids - ; tidy_insts = map (tidyClsInstDFun (lookup_dfun tidy_type_env)) insts - -- A DFunId will have a binding in tidy_binds, and so - -- will now be in final_env, replete with IdInfo - -- Its name will be unchanged since it was born, but - -- we want Global, IdInfo-rich (or not) DFunId in the - -- tidy_insts + ; tidy_insts = map (tidyClsInstDFun (lookup_aux_id tidy_type_env)) insts + -- A DFunId will have a binding in tidy_binds, and so will now be in + -- tidy_type_env, replete with IdInfo. Its name will be unchanged since + -- it was born, but we want Global, IdInfo-rich (or not) DFunId in the + -- tidy_insts. Similarly the Ids inside a PatSyn. ; tidy_rules = tidyRules tidy_env ext_rules -- You might worry that the tidy_env contains IdInfo-rich stuff @@ -355,6 +356,16 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ; tidy_vect_info = tidyVectInfo tidy_env vect_info + -- Tidy the Ids inside each PatSyn, very similarly to DFunIds + -- and then override the PatSyns in the type_env with the new tidy ones + -- This is really the only reason we keep mg_patsyns at all; otherwise + -- they could just stay in type_env + ; tidy_patsyns = map (tidyPatSynIds (lookup_aux_id tidy_type_env)) patsyns + ; type_env2 = extendTypeEnvList type_env1 + [AConLike (PatSynCon ps) | ps <- tidy_patsyns ] + + ; tidy_type_env = tidyTypeEnv omit_prags type_env2 + -- See Note [Injecting implicit bindings] ; all_tidy_binds = implicit_binds ++ tidy_binds @@ -406,11 +417,11 @@ tidyProgram hsc_env (ModGuts { mg_module = mod }) } -lookup_dfun :: TypeEnv -> Var -> Id -lookup_dfun type_env dfun_id - = case lookupTypeEnv type_env (idName dfun_id) of - Just (AnId dfun_id') -> dfun_id' - _other -> pprPanic "lookup_dfun" (ppr dfun_id) +lookup_aux_id :: TypeEnv -> Var -> Id +lookup_aux_id type_env id + = case lookupTypeEnv type_env (idName id) of + Just (AnId id') -> id' + _other -> pprPanic "lookup_axu_id" (ppr id) -------------------------- tidyTypeEnv :: Bool -- Compiling without -O, so omit prags @@ -518,7 +529,7 @@ of exceptions, and finally I gave up the battle: Note [Injecting implicit bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We inject the implict bindings right at the end, in CoreTidy. +We inject the implicit bindings right at the end, in CoreTidy. Some of these bindings, notably record selectors, are not constructed in an optimised form. E.g. record selector for data T = MkT { x :: {-# UNPACK #-} !Int } @@ -560,14 +571,16 @@ Oh: two other reasons for injecting them late: There is one sort of implicit binding that is injected still later, namely those for data constructor workers. Reason (I think): it's really just a code generation trick.... binding itself makes no sense. -See CorePrep Note [Data constructor workers]. +See Note [Data constructor workers] in CorePrep. \begin{code} getTyConImplicitBinds :: TyCon -> [CoreBind] getTyConImplicitBinds tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc)) getClassImplicitBinds :: Class -> [CoreBind] -getClassImplicitBinds cls = map get_defn (classAllSelIds cls) +getClassImplicitBinds cls + = [ NonRec op (mkDictSelRhs cls val_index) + | (op, val_index) <- classAllSelIds cls `zip` [0..] ] get_defn :: Id -> CoreBind get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id)) @@ -1007,7 +1020,7 @@ tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds ------------------------ tidyTopBind :: DynFlags - -> PackageId + -> PackageKey -> Module -> Id -> UnfoldEnv @@ -1177,7 +1190,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 caae4b1409..3c4a551df3 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -7,7 +7,8 @@ -- ----------------------------------------------------------------------------- \begin{code} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, UnboxedTuples #-} + module AsmCodeGen ( nativeCodeGen ) where #include "HsVersions.h" @@ -166,6 +167,7 @@ nativeCodeGen dflags this_mod h us cmms ArchPPC -> nCG' (ppcNcgImpl dflags) ArchSPARC -> nCG' (sparcNcgImpl dflags) ArchARM {} -> panic "nativeCodeGen: No NCG for ARM" + ArchARM64 -> panic "nativeCodeGen: No NCG for ARM64" ArchPPC_64 -> panic "nativeCodeGen: No NCG for PPC 64" ArchAlpha -> panic "nativeCodeGen: No NCG for Alpha" ArchMipseb -> panic "nativeCodeGen: No NCG for mipseb" @@ -604,7 +606,7 @@ makeImportsDoc dflags imports then text ".section .note.GNU-stack,\"\",@progbits" else empty) $$ - -- And just because every other compiler does, lets stick in + -- And just because every other compiler does, let's stick in -- an identifier directive: .ident "GHC x.y.z" (if platformHasIdentDirective platform then let compilerIdent = text "GHC" <+> text cProjectVersion @@ -1023,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..c52fe10b13 100644 --- a/compiler/nativeGen/CPrim.hs +++ b/compiler/nativeGen/CPrim.hs @@ -1,11 +1,18 @@ -- | Generating C symbol names emitted by the compiler. module CPrim - ( popCntLabel + ( atomicReadLabel + , atomicWriteLabel + , atomicRMWLabel + , cmpxchgLabel + , popCntLabel , bSwapLabel + , clzLabel + , ctzLabel , word2FloatLabel ) where import CmmType +import CmmMachOp import Outputable popCntLabel :: Width -> String @@ -25,9 +32,70 @@ bSwapLabel w = "hs_bswap" ++ pprWidth w pprWidth W64 = "64" pprWidth w = pprPanic "bSwapLabel: Unsupported word width " (ppr w) +clzLabel :: Width -> String +clzLabel w = "hs_clz" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "clzLabel: Unsupported word width " (ppr w) + +ctzLabel :: Width -> String +ctzLabel w = "hs_ctz" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "ctzLabel: Unsupported word width " (ppr w) + word2FloatLabel :: Width -> String word2FloatLabel w = "hs_word2float" ++ pprWidth w where 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/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs index 3ee3af2ea9..a4c9f74df7 100644 --- a/compiler/nativeGen/NCGMonad.hs +++ b/compiler/nativeGen/NCGMonad.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 1993-2004 diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 3f0e7632f8..3d3dff2e73 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP, GADTs #-} ----------------------------------------------------------------------------- -- @@ -12,7 +13,6 @@ -- (c) the #if blah_TARGET_ARCH} things, the -- structure should not be too overwhelming. -{-# LANGUAGE GADTs #-} module PPC.CodeGen ( cmmTopCodeGen, generateJumpTableForInstr, @@ -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,12 @@ genCCall' dflags gcp target dest_regs args0 MO_BSwap w -> (fsLit $ bSwapLabel w, False) MO_PopCnt w -> (fsLit $ popCntLabel w, False) + MO_Clz w -> (fsLit $ clzLabel w, False) + MO_Ctz w -> (fsLit $ ctzLabel 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 b8c5208c66..0e4b1fd701 100644 --- a/compiler/nativeGen/PPC/Cond.hs +++ b/compiler/nativeGen/PPC/Cond.hs @@ -1,17 +1,9 @@ - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://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/Instr.hs b/compiler/nativeGen/PPC/Instr.hs index ddb9c51c7b..3756c649bb 100644 --- a/compiler/nativeGen/PPC/Instr.hs +++ b/compiler/nativeGen/PPC/Instr.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Machine-dependent assembly language diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs index 8b35d87573..c4724d4193 100644 --- a/compiler/nativeGen/PPC/RegInfo.hs +++ b/compiler/nativeGen/PPC/RegInfo.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Machine-specific parts of the register allocator @@ -5,20 +7,12 @@ -- (c) The University of Glasgow 1996-2004 -- ----------------------------------------------------------------------------- - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module PPC.RegInfo ( JumpDest( DestBlockId ), getJumpDestBlockId, - canShortcut, - shortcutJump, + canShortcut, + shortcutJump, - shortcutStatics + shortcutStatics ) where @@ -68,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/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs index f92351bd22..0f636bf64c 100644 --- a/compiler/nativeGen/PPC/Regs.hs +++ b/compiler/nativeGen/PPC/Regs.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 1994-2004 diff --git a/compiler/nativeGen/Reg.hs b/compiler/nativeGen/Reg.hs index fee74be355..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 -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/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs index dbaf5098ce..05db68dd46 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Main.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables #-} + -- | Graph coloring register allocator. module RegAlloc.Graph.Main ( regAlloc diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs index 7bc842d1c9..8fada96ee2 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns, CPP #-} -- | Carries interesting info for debugging / profiling of the -- graph coloring register allocator. diff --git a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs index b5006ecfba..eba2e43149 100644 --- a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs +++ b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, CPP #-} module RegAlloc.Graph.TrivColorable ( trivColorable, @@ -113,6 +113,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts excl ArchSPARC -> 14 ArchPPC_64 -> panic "trivColorable ArchPPC_64" ArchARM _ _ _ -> panic "trivColorable ArchARM" + ArchARM64 -> panic "trivColorable ArchARM64" ArchAlpha -> panic "trivColorable ArchAlpha" ArchMipseb -> panic "trivColorable ArchMipseb" ArchMipsel -> panic "trivColorable ArchMipsel" @@ -137,6 +138,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclus ArchSPARC -> 22 ArchPPC_64 -> panic "trivColorable ArchPPC_64" ArchARM _ _ _ -> panic "trivColorable ArchARM" + ArchARM64 -> panic "trivColorable ArchARM64" ArchAlpha -> panic "trivColorable ArchAlpha" ArchMipseb -> panic "trivColorable ArchMipseb" ArchMipsel -> panic "trivColorable ArchMipsel" @@ -161,6 +163,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclu ArchSPARC -> 11 ArchPPC_64 -> panic "trivColorable ArchPPC_64" ArchARM _ _ _ -> panic "trivColorable ArchARM" + ArchARM64 -> panic "trivColorable ArchARM64" ArchAlpha -> panic "trivColorable ArchAlpha" ArchMipseb -> panic "trivColorable ArchMipseb" ArchMipsel -> panic "trivColorable ArchMipsel" @@ -185,6 +188,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts ex ArchSPARC -> 0 ArchPPC_64 -> panic "trivColorable ArchPPC_64" ArchARM _ _ _ -> panic "trivColorable ArchARM" + ArchARM64 -> panic "trivColorable ArchARM64" ArchAlpha -> panic "trivColorable ArchAlpha" ArchMipseb -> panic "trivColorable ArchMipseb" ArchMipsel -> panic "trivColorable ArchMipsel" diff --git a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs index 557d713fe3..a1a00ba582 100644 --- a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module RegAlloc.Linear.FreeRegs ( FR(..), @@ -74,6 +75,7 @@ maxSpillSlots dflags ArchPPC -> PPC.Instr.maxSpillSlots dflags ArchSPARC -> SPARC.Instr.maxSpillSlots dflags ArchARM _ _ _ -> panic "maxSpillSlots ArchARM" + ArchARM64 -> panic "maxSpillSlots ArchARM64" ArchPPC_64 -> panic "maxSpillSlots ArchPPC_64" ArchAlpha -> panic "maxSpillSlots ArchAlpha" ArchMipseb -> panic "maxSpillSlots ArchMipseb" diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 6ac19dad40..fa47a17ac0 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP, ScopedTypeVariables #-} + ----------------------------------------------------------------------------- -- -- The register allocator @@ -156,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 @@ -194,45 +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" - 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)] @@ -241,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 @@ -267,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)] @@ -278,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. @@ -288,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/Linear/PPC/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs index 0bdb49fb2e..b76fe79d7d 100644 --- a/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs @@ -1,4 +1,3 @@ - -- | Free regs map for PowerPC module RegAlloc.Linear.PPC.FreeRegs where diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs index dc499c9c1f..39b5777ef3 100644 --- a/compiler/nativeGen/RegAlloc/Linear/State.hs +++ b/compiler/nativeGen/RegAlloc/Linear/State.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE UnboxedTuples #-} + -- | State monad for the linear register allocator. -- Here we keep all the state that the register allocator keeps track diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index 6dd4cec0de..d7fd8bdcb4 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + ----------------------------------------------------------------------------- -- -- The register liveness determinator @@ -5,6 +10,7 @@ -- (c) The University of Glasgow 2004-2013 -- ----------------------------------------------------------------------------- + module RegAlloc.Liveness ( RegSet, RegMap, emptyRegMap, @@ -163,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. @@ -217,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) @@ -474,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 @@ -487,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. @@ -635,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 -- @@ -665,14 +675,20 @@ sccBlocks sccBlocks blocks entries = map (fmap get_node) sccs where - sccs = stronglyConnCompFromG graph roots - - graph = graphFromEdgedVertices nodes - -- nodes :: [(NatBasicBlock instr, Unique, [Unique])] nodes = [ (block, id, getOutEdges instrs) | block@(BasicBlock id instrs) <- blocks ] + g1 = graphFromEdgedVertices nodes + + reachable :: BlockSet + reachable = setFromList [ id | (_,id,_) <- reachablesG g1 roots ] + + g2 = graphFromEdgedVertices [ node | node@(_,id,_) <- nodes + , id `setMember` reachable ] + + sccs = stronglyConnCompG g2 + get_node (n, _, _) = n getOutEdges :: Instruction instr => [instr] -> [BlockId] diff --git a/compiler/nativeGen/RegClass.hs b/compiler/nativeGen/RegClass.hs index 7ccc0c1bec..0c793173cb 100644 --- a/compiler/nativeGen/RegClass.hs +++ b/compiler/nativeGen/RegClass.hs @@ -1,41 +1,33 @@ -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://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 5d65b427e1..c192b8bda6 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Generating machine code (instruction selection) @@ -652,6 +654,12 @@ outOfLineMachOp_table mop MO_BSwap w -> fsLit $ bSwapLabel w MO_PopCnt w -> fsLit $ popCntLabel w + MO_Clz w -> fsLit $ clzLabel w + MO_Ctz w -> fsLit $ ctzLabel 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 324eda94e7..8d9a303f2f 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Amode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Amode.hs @@ -1,13 +1,5 @@ - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://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 03b31e016a..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 -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 375a9e1b33..cb10830f46 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs @@ -1,15 +1,7 @@ - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://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 03f571c20b..1d4d1379a5 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Expand.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs @@ -1,14 +1,6 @@ - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://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 df876b4622..90fb41870d 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs @@ -1,15 +1,7 @@ - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://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 d4cdaf2b16..81641326f2 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs @@ -1,22 +1,13 @@ - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://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 b8919a72a2..da41457950 100644 --- a/compiler/nativeGen/SPARC/Cond.hs +++ b/compiler/nativeGen/SPARC/Cond.hs @@ -1,39 +1,31 @@ - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://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 4c2bb5a481..cb53ba411c 100644 --- a/compiler/nativeGen/SPARC/Imm.hs +++ b/compiler/nativeGen/SPARC/Imm.hs @@ -1,16 +1,8 @@ - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://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 601e04787a..fb8cc0cadc 100644 --- a/compiler/nativeGen/SPARC/Instr.hs +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Machine-dependent assembly language @@ -5,28 +7,20 @@ -- (c) The University of Glasgow 1993-2004 -- ----------------------------------------------------------------------------- - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://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 @@ -55,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 @@ -86,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 @@ -385,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)) @@ -405,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 @@ -418,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 @@ -452,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/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index 601b5288a0..654179e077 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Pretty-printing assembly language diff --git a/compiler/nativeGen/SPARC/Regs.hs b/compiler/nativeGen/SPARC/Regs.hs index 55b6ac9156..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 -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 7f978c17c5..123a345130 100644 --- a/compiler/nativeGen/SPARC/ShortcutJump.hs +++ b/compiler/nativeGen/SPARC/ShortcutJump.hs @@ -1,17 +1,9 @@ - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://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 4a6f4c1335..629b18789f 100644 --- a/compiler/nativeGen/SPARC/Stack.hs +++ b/compiler/nativeGen/SPARC/Stack.hs @@ -1,16 +1,8 @@ - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://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 45a39645cc..8fe590f1e9 100644 --- a/compiler/nativeGen/Size.hs +++ b/compiler/nativeGen/Size.hs @@ -1,22 +1,15 @@ -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://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 09c774f4d5..96c1777795 100644 --- a/compiler/nativeGen/TargetReg.hs +++ b/compiler/nativeGen/TargetReg.hs @@ -1,28 +1,20 @@ - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - +{-# LANGUAGE CPP #-} -- | 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 @@ -54,6 +46,7 @@ targetVirtualRegSqueeze platform ArchSPARC -> SPARC.virtualRegSqueeze ArchPPC_64 -> panic "targetVirtualRegSqueeze ArchPPC_64" ArchARM _ _ _ -> panic "targetVirtualRegSqueeze ArchARM" + ArchARM64 -> panic "targetVirtualRegSqueeze ArchARM64" ArchAlpha -> panic "targetVirtualRegSqueeze ArchAlpha" ArchMipseb -> panic "targetVirtualRegSqueeze ArchMipseb" ArchMipsel -> panic "targetVirtualRegSqueeze ArchMipsel" @@ -70,6 +63,7 @@ targetRealRegSqueeze platform ArchSPARC -> SPARC.realRegSqueeze ArchPPC_64 -> panic "targetRealRegSqueeze ArchPPC_64" ArchARM _ _ _ -> panic "targetRealRegSqueeze ArchARM" + ArchARM64 -> panic "targetRealRegSqueeze ArchARM64" ArchAlpha -> panic "targetRealRegSqueeze ArchAlpha" ArchMipseb -> panic "targetRealRegSqueeze ArchMipseb" ArchMipsel -> panic "targetRealRegSqueeze ArchMipsel" @@ -85,6 +79,7 @@ targetClassOfRealReg platform ArchSPARC -> SPARC.classOfRealReg ArchPPC_64 -> panic "targetClassOfRealReg ArchPPC_64" ArchARM _ _ _ -> panic "targetClassOfRealReg ArchARM" + ArchARM64 -> panic "targetClassOfRealReg ArchARM64" ArchAlpha -> panic "targetClassOfRealReg ArchAlpha" ArchMipseb -> panic "targetClassOfRealReg ArchMipseb" ArchMipsel -> panic "targetClassOfRealReg ArchMipsel" @@ -100,6 +95,7 @@ targetMkVirtualReg platform ArchSPARC -> SPARC.mkVirtualReg ArchPPC_64 -> panic "targetMkVirtualReg ArchPPC_64" ArchARM _ _ _ -> panic "targetMkVirtualReg ArchARM" + ArchARM64 -> panic "targetMkVirtualReg ArchARM64" ArchAlpha -> panic "targetMkVirtualReg ArchAlpha" ArchMipseb -> panic "targetMkVirtualReg ArchMipseb" ArchMipsel -> panic "targetMkVirtualReg ArchMipsel" @@ -115,6 +111,7 @@ targetRegDotColor platform ArchSPARC -> SPARC.regDotColor ArchPPC_64 -> panic "targetRegDotColor ArchPPC_64" ArchARM _ _ _ -> panic "targetRegDotColor ArchARM" + ArchARM64 -> panic "targetRegDotColor ArchARM64" ArchAlpha -> panic "targetRegDotColor ArchAlpha" ArchMipseb -> panic "targetRegDotColor ArchMipseb" ArchMipsel -> panic "targetRegDotColor ArchMipsel" @@ -127,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 e659488fe0..bc79e5e264 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP, GADTs, NondecreasingIndentation #-} + ----------------------------------------------------------------------------- -- -- Generating machine code (instruction selection) @@ -10,7 +12,6 @@ -- (a) the sectioning, and (b) the type signatures, the -- structure should not be too overwhelming. -{-# LANGUAGE GADTs #-} module X86.CodeGen ( cmmTopCodeGen, generateJumpTableForInstr, @@ -40,7 +41,7 @@ import Platform -- Our intermediate code: import BasicTypes import BlockId -import Module ( primPackageId ) +import Module ( primPackageKey ) import PprCmm () import CmmUtils import Cmm @@ -804,6 +805,8 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps | is32BitInteger y = add_int rep x y add_code rep x y = trivialCode rep (ADD size) (Just (ADD size)) x y where size = intSize rep + -- TODO: There are other interesting patterns we want to replace + -- with a LEA, e.g. `(x + offset) + (y << shift)`. -------------------- sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register @@ -1024,6 +1027,13 @@ getAmode' is32Bit (CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _), b@(CmmLit _)]) = getAmode' is32Bit (CmmMachOp (MO_Add rep) [b,a]) +-- Matches: (x + offset) + (y << shift) +getAmode' _ (CmmMachOp (MO_Add _) [CmmRegOff x offset, + CmmMachOp (MO_Shl _) + [y, CmmLit (CmmInt shift _)]]) + | shift == 0 || shift == 1 || shift == 2 || shift == 3 + = x86_complex_amode (CmmReg x) y shift (fromIntegral offset) + getAmode' _ (CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]]) | shift == 0 || shift == 1 || shift == 2 || shift == 3 @@ -1047,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 @@ -1721,15 +1743,19 @@ genCCall dflags is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst] if sse4_2 then do code_src <- getAnyReg src src_r <- getNewRegNat size + let dst_r = getRegisterReg platform False (CmmLocal dst) return $ code_src src_r `appOL` (if width == W8 then -- The POPCNT instruction doesn't take a r/m8 unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL` - unitOL (POPCNT II16 (OpReg src_r) - (getRegisterReg platform False (CmmLocal dst))) + unitOL (POPCNT II16 (OpReg src_r) dst_r) else - unitOL (POPCNT size (OpReg src_r) - (getRegisterReg platform False (CmmLocal dst)))) + unitOL (POPCNT size (OpReg src_r) dst_r)) `appOL` + (if width == W8 || width == W16 then + -- We used a 16-bit destination register above, + -- so zero-extend + unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r)) + else nilOL) else do targetExpr <- cmmMakeDynamicReference dflags CallReference lbl @@ -1739,7 +1765,70 @@ 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_Clz width)) dest_regs@[dst] args@[src] + | is32Bit && width == W64 = do + -- Fallback to `hs_clz64` on i386 + targetExpr <- cmmMakeDynamicReference dflags CallReference lbl + let target = ForeignTarget targetExpr (ForeignConvention CCallConv + [NoHint] [NoHint] + CmmMayReturn) + genCCall dflags is32Bit target dest_regs args + + | otherwise = do + code_src <- getAnyReg src + src_r <- getNewRegNat size + tmp_r <- getNewRegNat size + let dst_r = getRegisterReg platform False (CmmLocal dst) + + -- The following insn sequence makes sure 'clz 0' has a defined value. + -- starting with Haswell, one could use the LZCNT insn instead. + return $ code_src src_r `appOL` toOL + ([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] ++ + [ BSR size (OpReg src_r) tmp_r + , MOV II32 (OpImm (ImmInt (2*bw-1))) (OpReg dst_r) + , CMOV NE size (OpReg tmp_r) dst_r + , XOR size (OpImm (ImmInt (bw-1))) (OpReg dst_r) + ]) -- NB: We don't need to zero-extend the result for the + -- W8/W16 cases because the 'MOV' insn already + -- took care of implicitly clearing the upper bits + where + bw = widthInBits width + platform = targetPlatform dflags + size = if width == W8 then II16 else intSize width + lbl = mkCmmCodeLabel primPackageKey (fsLit (clzLabel width)) + +genCCall dflags is32Bit (PrimTarget (MO_Ctz width)) dest_regs@[dst] args@[src] + | is32Bit, width == W64 = do + -- Fallback to `hs_ctz64` on i386 + targetExpr <- cmmMakeDynamicReference dflags CallReference lbl + let target = ForeignTarget targetExpr (ForeignConvention CCallConv + [NoHint] [NoHint] + CmmMayReturn) + genCCall dflags is32Bit target dest_regs args + + | otherwise = do + code_src <- getAnyReg src + src_r <- getNewRegNat size + tmp_r <- getNewRegNat size + let dst_r = getRegisterReg platform False (CmmLocal dst) + + -- The following insn sequence makes sure 'ctz 0' has a defined value. + -- starting with Haswell, one could use the TZCNT insn instead. + return $ code_src src_r `appOL` toOL + ([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] ++ + [ BSF size (OpReg src_r) tmp_r + , MOV II32 (OpImm (ImmInt bw)) (OpReg dst_r) + , CMOV NE size (OpReg tmp_r) dst_r + ]) -- NB: We don't need to zero-extend the result for the + -- W8/W16 cases because the 'MOV' insn already + -- took care of implicitly clearing the upper bits + where + bw = widthInBits width + platform = targetPlatform dflags + size = if width == W8 then II16 else intSize width + lbl = mkCmmCodeLabel primPackageKey (fsLit (ctzLabel width)) genCCall dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args = do targetExpr <- cmmMakeDynamicReference dflags @@ -1749,17 +1838,99 @@ 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 + ] -genCCall _ is32Bit target dest_regs args - | is32Bit = genCCall32 target dest_regs args - | otherwise = genCCall64 target dest_regs args + size = intSize width -genCCall32 :: ForeignTarget -- function to call - -> [CmmFormal] -- where to put the result - -> [CmmActual] -- arguments (of mixed type) - -> NatM InstrBlock -genCCall32 target dest_regs args = do +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 = do dflags <- getDynFlags let platform = targetPlatform dflags case (target, dest_regs) of @@ -1767,7 +1938,9 @@ genCCall32 target dest_regs args = do (PrimTarget op, []) -> outOfLineCmmOp op Nothing args -- we only cope with a single result for foreign calls - (PrimTarget op, [r]) -> do + (PrimTarget op, [r]) + | not is32Bit -> outOfLineCmmOp op (Just r) args + | otherwise -> do l1 <- getNewLabelNat l2 <- getNewLabelNat sse2 <- sse2Enabled @@ -1796,7 +1969,7 @@ genCCall32 target dest_regs args = do return (any (getRegisterReg platform False (CmmLocal r))) actuallyInlineFloatOp _ _ args - = panic $ "genCCall32.actuallyInlineFloatOp: bad number of arguments! (" + = panic $ "genCCall.actuallyInlineFloatOp: bad number of arguments! (" ++ show (length args) ++ ")" (PrimTarget (MO_S_QuotRem width), _) -> divOp1 platform True width dest_regs args @@ -1806,15 +1979,16 @@ genCCall32 target dest_regs args = do case args of [arg_x, arg_y] -> do hCode <- getAnyReg (CmmLit (CmmInt 0 width)) - lCode <- getAnyReg (CmmMachOp (MO_Add width) [arg_x, arg_y]) let size = intSize width - reg_l = getRegisterReg platform True (CmmLocal res_l) + lCode <- anyReg =<< trivialCode width (ADD_CC size) + (Just (ADD_CC size)) arg_x arg_y + let reg_l = getRegisterReg platform True (CmmLocal res_l) reg_h = getRegisterReg platform True (CmmLocal res_h) code = hCode reg_h `appOL` lCode reg_l `snocOL` ADC size (OpImm (ImmInteger 0)) (OpReg reg_h) return code - _ -> panic "genCCall32: Wrong number of arguments/results for add2" + _ -> panic "genCCall: Wrong number of arguments/results for add2" (PrimTarget (MO_U_Mul2 width), [res_h, res_l]) -> case args of [arg_x, arg_y] -> @@ -1829,18 +2003,20 @@ genCCall32 target dest_regs args = do MOV size (OpReg rdx) (OpReg reg_h), MOV size (OpReg rax) (OpReg reg_l)] return code - _ -> panic "genCCall32: Wrong number of arguments/results for add2" + _ -> panic "genCCall: Wrong number of arguments/results for add2" - _ -> genCCall32' dflags target dest_regs args + _ -> if is32Bit + then genCCall32' dflags target dest_regs args + else genCCall64' dflags target dest_regs args where divOp1 platform signed width results [arg_x, arg_y] = divOp platform signed width results Nothing arg_x arg_y divOp1 _ _ _ _ _ - = panic "genCCall32: Wrong number of arguments for divOp1" + = panic "genCCall: Wrong number of arguments for divOp1" divOp2 platform signed width results [arg_x_high, arg_x_low, arg_y] = divOp platform signed width results (Just arg_x_high) arg_x_low arg_y divOp2 _ _ _ _ _ - = panic "genCCall64: Wrong number of arguments for divOp2" + = panic "genCCall: Wrong number of arguments for divOp2" divOp platform signed width [res_q, res_r] m_arg_x_high arg_x_low arg_y = do let size = intSize width @@ -1864,7 +2040,7 @@ genCCall32 target dest_regs args = do MOV size (OpReg rax) (OpReg reg_q), MOV size (OpReg rdx) (OpReg reg_r)] divOp _ _ _ _ _ _ _ - = panic "genCCall32: Wrong number of results for divOp" + = panic "genCCall: Wrong number of results for divOp" genCCall32' :: DynFlags -> ForeignTarget -- function to call @@ -2019,90 +2195,6 @@ genCCall32' dflags target dest_regs args = do arg_ty = cmmExprType dflags arg size = arg_size arg_ty -- Byte size -genCCall64 :: ForeignTarget -- function to call - -> [CmmFormal] -- where to put the result - -> [CmmActual] -- arguments (of mixed type) - -> NatM InstrBlock -genCCall64 target dest_regs args = do - dflags <- getDynFlags - let platform = targetPlatform dflags - case (target, dest_regs) of - - (PrimTarget op, []) -> - -- void return type prim op - outOfLineCmmOp op Nothing args - - (PrimTarget op, [res]) -> - -- we only cope with a single result for foreign calls - outOfLineCmmOp op (Just res) args - - (PrimTarget (MO_S_QuotRem width), _) -> divOp1 platform True width dest_regs args - (PrimTarget (MO_U_QuotRem width), _) -> divOp1 platform False width dest_regs args - (PrimTarget (MO_U_QuotRem2 width), _) -> divOp2 platform False width dest_regs args - (PrimTarget (MO_Add2 width), [res_h, res_l]) -> - case args of - [arg_x, arg_y] -> - do hCode <- getAnyReg (CmmLit (CmmInt 0 width)) - lCode <- getAnyReg (CmmMachOp (MO_Add width) [arg_x, arg_y]) - let size = intSize width - reg_l = getRegisterReg platform True (CmmLocal res_l) - reg_h = getRegisterReg platform True (CmmLocal res_h) - code = hCode reg_h `appOL` - lCode reg_l `snocOL` - ADC size (OpImm (ImmInteger 0)) (OpReg reg_h) - return code - _ -> panic "genCCall64: Wrong number of arguments/results for add2" - (PrimTarget (MO_U_Mul2 width), [res_h, res_l]) -> - case args of - [arg_x, arg_y] -> - do (y_reg, y_code) <- getRegOrMem arg_y - x_code <- getAnyReg arg_x - let size = intSize width - reg_h = getRegisterReg platform True (CmmLocal res_h) - reg_l = getRegisterReg platform True (CmmLocal res_l) - code = y_code `appOL` - x_code rax `appOL` - toOL [MUL2 size y_reg, - MOV size (OpReg rdx) (OpReg reg_h), - MOV size (OpReg rax) (OpReg reg_l)] - return code - _ -> panic "genCCall64: Wrong number of arguments/results for add2" - - _ -> - do dflags <- getDynFlags - genCCall64' dflags target dest_regs args - - where divOp1 platform signed width results [arg_x, arg_y] - = divOp platform signed width results Nothing arg_x arg_y - divOp1 _ _ _ _ _ - = panic "genCCall64: Wrong number of arguments for divOp1" - divOp2 platform signed width results [arg_x_high, arg_x_low, arg_y] - = divOp platform signed width results (Just arg_x_high) arg_x_low arg_y - divOp2 _ _ _ _ _ - = panic "genCCall64: Wrong number of arguments for divOp2" - divOp platform signed width [res_q, res_r] - m_arg_x_high arg_x_low arg_y - = do let size = intSize width - reg_q = getRegisterReg platform True (CmmLocal res_q) - reg_r = getRegisterReg platform True (CmmLocal res_r) - widen | signed = CLTD size - | otherwise = XOR size (OpReg rdx) (OpReg rdx) - instr | signed = IDIV - | otherwise = DIV - (y_reg, y_code) <- getRegOrMem arg_y - x_low_code <- getAnyReg arg_x_low - x_high_code <- case m_arg_x_high of - Just arg_x_high -> getAnyReg arg_x_high - Nothing -> return $ const $ unitOL widen - return $ y_code `appOL` - x_low_code rax `appOL` - x_high_code rdx `appOL` - toOL [instr size y_reg, - MOV size (OpReg rax) (OpReg reg_q), - MOV size (OpReg rdx) (OpReg reg_r)] - divOp _ _ _ _ _ _ _ - = panic "genCCall64: Wrong number of results for divOp" - genCCall64' :: DynFlags -> ForeignTarget -- function to call -> [CmmFormal] -- where to put the result @@ -2374,6 +2466,13 @@ outOfLineCmmOp mop res args MO_PopCnt _ -> fsLit "popcnt" MO_BSwap _ -> fsLit "bswap" + MO_Clz w -> fsLit $ clzLabel w + MO_Ctz w -> fsLit $ ctzLabel w + + MO_AtomicRMW _ _ -> fsLit "atomicrmw" + MO_AtomicRead _ -> fsLit "atomicread" + MO_AtomicWrite _ -> fsLit "atomicwrite" + MO_Cmpxchg _ -> fsLit "cmpxchg" MO_UF_Conv _ -> unsupported diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index 8284270be1..ef0ceeabf3 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP, TypeFamilies #-} + ----------------------------------------------------------------------------- -- -- Machine-dependent assembly language @@ -6,15 +8,15 @@ -- ----------------------------------------------------------------------------- -#include "HsVersions.h" -#include "nativeGen/NCG.h" - module X86.Instr (Instr(..), Operand(..), PrefetchVariant(..), JumpDest, getJumpDestBlockId, canShortcut, shortcutStatics, shortcutJump, i386_insert_ffrees, allocMoreStack, maxSpillSlots, archWordSize) where +#include "HsVersions.h" +#include "nativeGen/NCG.h" + import X86.Cond import X86.Regs import Instruction @@ -180,6 +182,7 @@ data Instr -- Moves. | MOV Size Operand Operand + | CMOV Cond Size Operand Reg | MOVZxL Size Operand Operand -- size is the size of operand 1 | MOVSxL Size Operand Operand -- size is the size of operand 1 -- x86_64 note: plain mov into a 32-bit register always zero-extends @@ -202,6 +205,12 @@ data Instr | DIV Size Operand -- eax := eax:edx/op, edx := eax:edx%op | IDIV Size Operand -- ditto, but signed + -- Int Arithmetic, where the effects on the condition register + -- are important. Used in specialized sequences such as MO_Add2. + -- Do not rewrite these instructions to "equivalent" ones that + -- have different effect on the condition register! (See #9013.) + | ADD_CC Size Operand Operand + -- Simple bit-twiddling. | AND Size Operand Operand | OR Size Operand Operand @@ -318,13 +327,20 @@ data Instr -- call 1f -- 1: popl %reg - -- SSE4.2 - | POPCNT Size Operand Reg -- src, dst + -- bit counting instructions + | POPCNT Size Operand Reg -- [SSE4.2] count number of bits set to 1 + | BSF Size Operand Reg -- bit scan forward + | BSR Size Operand Reg -- bit scan reverse -- prefetch | 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 @@ -335,10 +351,13 @@ 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 MOV _ src dst -> usageRW src dst + CMOV _ _ src dst -> mkRU (use_R src [dst]) [dst] MOVZxL _ src dst -> usageRW src dst MOVSxL _ src dst -> usageRW src dst LEA _ src dst -> usageRW src dst @@ -351,6 +370,7 @@ x86_regUsageOfInstr platform instr MUL2 _ src -> mkRU (eax:use_R src []) [eax,edx] DIV _ op -> mkRU (eax:edx:use_R op []) [eax,edx] IDIV _ op -> mkRU (eax:edx:use_R op []) [eax,edx] + ADD_CC _ src dst -> usageRM src dst AND _ src dst -> usageRM src dst OR _ src dst -> usageRM src dst @@ -423,13 +443,27 @@ x86_regUsageOfInstr platform instr DELTA _ -> noUsage POPCNT _ src dst -> mkRU (use_R src []) [dst] + BSF _ src dst -> mkRU (use_R src []) [dst] + BSR _ src dst -> mkRU (use_R src []) [dst] -- 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] @@ -442,6 +476,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] @@ -474,6 +520,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) @@ -481,10 +528,13 @@ 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 MOV sz src dst -> patch2 (MOV sz) src dst + CMOV cc sz src dst -> CMOV cc sz (patchOp src) (env dst) MOVZxL sz src dst -> patch2 (MOVZxL sz) src dst MOVSxL sz src dst -> patch2 (MOVSxL sz) src dst LEA sz src dst -> patch2 (LEA sz) src dst @@ -497,6 +547,7 @@ x86_patchRegsOfInstr instr env MUL2 sz src -> patch1 (MUL2 sz) src IDIV sz op -> patch1 (IDIV sz) op DIV sz op -> patch1 (DIV sz) op + ADD_CC sz src dst -> patch2 (ADD_CC sz) src dst AND sz src dst -> patch2 (AND sz) src dst OR sz src dst -> patch2 (OR sz) src dst XOR sz src dst -> patch2 (XOR sz) src dst @@ -566,9 +617,16 @@ x86_patchRegsOfInstr instr env CLTD _ -> instr POPCNT sz src dst -> POPCNT sz (patchOp src) (env dst) + BSF sz src dst -> BSF sz (patchOp src) (env dst) + BSR sz src dst -> BSR sz (patchOp src) (env dst) 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 f38a04d069..89bb0b01fc 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Pretty-printing assembly language @@ -519,6 +521,9 @@ pprInstr (RELOAD slot reg) pprInstr (MOV size src dst) = pprSizeOpOp (sLit "mov") size src dst +pprInstr (CMOV cc size src dst) + = pprCondOpReg (sLit "cmov") size cc src dst + pprInstr (MOVZxL II32 src dst) = pprSizeOpOp (sLit "mov") II32 src dst -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple -- movl. But we represent it as a MOVZxL instruction, because @@ -561,6 +566,9 @@ pprInstr (ADC size src dst) pprInstr (SUB size src dst) = pprSizeOpOp (sLit "sub") size src dst pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2 +pprInstr (ADD_CC size src dst) + = pprSizeOpOp (sLit "add") size src dst + {- A hack. The Intel documentation says that "The two and three operand forms [of IMUL] may also be used with unsigned operands because the lower half of the product is the same regardless if @@ -576,6 +584,8 @@ pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst pprInstr (XOR size src dst) = pprSizeOpOp (sLit "xor") size src dst pprInstr (POPCNT size src dst) = pprOpOp (sLit "popcnt") size src (OpReg dst) +pprInstr (BSF size src dst) = pprOpOp (sLit "bsf") size src (OpReg dst) +pprInstr (BSR size src dst) = pprOpOp (sLit "bsr") size src (OpReg dst) pprInstr (PREFETCH NTA size src ) = pprSizeOp_ (sLit "prefetchnta") size src pprInstr (PREFETCH Lvl0 size src) = pprSizeOp_ (sLit "prefetcht0") size src @@ -884,6 +894,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" @@ -1104,6 +1124,18 @@ pprSizeOpReg name size op1 reg2 pprReg (archWordSize (target32Bit platform)) reg2 ] +pprCondOpReg :: LitString -> Size -> Cond -> Operand -> Reg -> SDoc +pprCondOpReg name size cond op1 reg2 + = hcat [ + char '\t', + ptext name, + pprCond cond, + space, + pprOperand size op1, + comma, + pprReg size reg2 + ] + pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> SDoc pprCondRegReg name size cond reg1 reg2 = hcat [ diff --git a/compiler/nativeGen/X86/RegInfo.hs b/compiler/nativeGen/X86/RegInfo.hs index 8c63933c5b..39535634d7 100644 --- a/compiler/nativeGen/X86/RegInfo.hs +++ b/compiler/nativeGen/X86/RegInfo.hs @@ -1,14 +1,7 @@ - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - +{-# LANGUAGE CPP #-} 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/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs index 127a811831..4162e2b703 100644 --- a/compiler/nativeGen/X86/Regs.hs +++ b/compiler/nativeGen/X86/Regs.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module X86.Regs ( -- squeese functions for the graph allocator virtualRegSqueeze, diff --git a/compiler/parser/Ctype.lhs b/compiler/parser/Ctype.lhs index b5173b2612..7233f50e7f 100644 --- a/compiler/parser/Ctype.lhs +++ b/compiler/parser/Ctype.lhs @@ -1,32 +1,26 @@ Character classification \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - +{-# LANGUAGE CPP #-} 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 - , 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} @@ -75,17 +69,20 @@ 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' +is_bindigit :: Char -> Bool +is_bindigit c = c == '0' || c == '1' + to_lower :: Char -> Char to_lower c | c >= 'A' && c <= 'Z' = chr (ord c - (ord 'A' - ord 'a')) @@ -108,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/LexCore.hs b/compiler/parser/LexCore.hs deleted file mode 100644 index 861fffb7f6..0000000000 --- a/compiler/parser/LexCore.hs +++ /dev/null @@ -1,115 +0,0 @@ -module LexCore where - -import ParserCoreUtils -import Panic -import Data.Char -import Numeric - -isNameChar :: Char -> Bool -isNameChar c = isAlpha c || isDigit c || (c == '_') || (c == '\'') - || (c == '$') || (c == '-') || (c == '.') - -isKeywordChar :: Char -> Bool -isKeywordChar c = isAlpha c || (c == '_') - -lexer :: (Token -> P a) -> P a -lexer cont [] = cont TKEOF [] -lexer cont ('\n':cs) = \line -> lexer cont cs (line+1) -lexer cont ('-':'>':cs) = cont TKrarrow cs - -lexer cont (c:cs) - | isSpace c = lexer cont cs - | isLower c || (c == '_') = lexName cont TKname (c:cs) - | isUpper c = lexName cont TKcname (c:cs) - | isDigit c || (c == '-') = lexNum cont (c:cs) - -lexer cont ('%':cs) = lexKeyword cont cs -lexer cont ('\'':cs) = lexChar cont cs -lexer cont ('\"':cs) = lexString [] cont cs -lexer cont ('#':cs) = cont TKhash cs -lexer cont ('(':cs) = cont TKoparen cs -lexer cont (')':cs) = cont TKcparen cs -lexer cont ('{':cs) = cont TKobrace cs -lexer cont ('}':cs) = cont TKcbrace cs -lexer cont ('=':cs) = cont TKeq cs -lexer cont (':':'=':':':cs) = cont TKcoloneqcolon cs -lexer cont (':':':':cs) = cont TKcoloncolon cs -lexer cont ('*':cs) = cont TKstar cs -lexer cont ('.':cs) = cont TKdot cs -lexer cont ('\\':cs) = cont TKlambda cs -lexer cont ('@':cs) = cont TKat cs -lexer cont ('?':cs) = cont TKquestion cs -lexer cont (';':cs) = cont TKsemicolon cs --- 20060420 GHC spits out constructors with colon in them nowadays. jds --- 20061103 but it's easier to parse if we split on the colon, and treat them --- as several tokens -lexer cont (':':cs) = cont TKcolon cs --- 20060420 Likewise does it create identifiers starting with dollar. jds -lexer cont ('$':cs) = lexName cont TKname ('$':cs) -lexer _ (c:_) = failP "invalid character" [c] - -lexChar :: (Token -> String -> Int -> ParseResult a) -> String -> Int - -> ParseResult a -lexChar cont ('\\':'x':h1:h0:'\'':cs) - | isHexEscape [h1,h0] = cont (TKchar (hexToChar h1 h0)) cs -lexChar _ ('\\':cs) = failP "invalid char character" ('\\':(take 10 cs)) -lexChar _ ('\'':_) = failP "invalid char character" ['\''] -lexChar _ ('\"':_) = failP "invalid char character" ['\"'] -lexChar cont (c:'\'':cs) = cont (TKchar c) cs -lexChar _ cs = panic ("lexChar: " ++ show cs) - -lexString :: String -> (Token -> [Char] -> Int -> ParseResult a) - -> String -> Int -> ParseResult a -lexString s cont ('\\':'x':h1:h0:cs) - | isHexEscape [h1,h0] = lexString (s++[hexToChar h1 h0]) cont cs -lexString _ _ ('\\':_) = failP "invalid string character" ['\\'] -lexString _ _ ('\'':_) = failP "invalid string character" ['\''] -lexString s cont ('\"':cs) = cont (TKstring s) cs -lexString s cont (c:cs) = lexString (s++[c]) cont cs -lexString _ _ [] = panic "lexString []" - -isHexEscape :: String -> Bool -isHexEscape = all (\c -> isHexDigit c && (isDigit c || isLower c)) - -hexToChar :: Char -> Char -> Char -hexToChar h1 h0 = chr (digitToInt h1 * 16 + digitToInt h0) - -lexNum :: (Token -> String -> a) -> String -> a -lexNum cont cs = - case cs of - ('-':cs) -> f (-1) cs - _ -> f 1 cs - where f sgn cs = - case span isDigit cs of - (digits,'.':c:rest) - | isDigit c -> cont (TKrational (fromInteger sgn * r)) rest' - where ((r,rest'):_) = readFloat (digits ++ ('.':c:rest)) - -- When reading a floating-point number, which is - -- a bit complicated, use the standard library function - -- "readFloat" - (digits,rest) -> cont (TKinteger (sgn * (read digits))) rest - -lexName :: (a -> String -> b) -> (String -> a) -> String -> b -lexName cont cstr cs = cont (cstr name) rest - where (name,rest) = span isNameChar cs - -lexKeyword :: (Token -> [Char] -> Int -> ParseResult a) -> String -> Int - -> ParseResult a -lexKeyword cont cs = - case span isKeywordChar cs of - ("module",rest) -> cont TKmodule rest - ("data",rest) -> cont TKdata rest - ("newtype",rest) -> cont TKnewtype rest - ("forall",rest) -> cont TKforall rest - ("rec",rest) -> cont TKrec rest - ("let",rest) -> cont TKlet rest - ("in",rest) -> cont TKin rest - ("case",rest) -> cont TKcase rest - ("of",rest) -> cont TKof rest - ("cast",rest) -> cont TKcast rest - ("note",rest) -> cont TKnote rest - ("external",rest) -> cont TKexternal rest - ("local",rest) -> cont TKlocal rest - ("_",rest) -> cont TKwild rest - _ -> failP "invalid keyword" ('%':cs) - diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 3d02393d17..88a0f07d90 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -117,6 +117,7 @@ $small = [$ascsmall $unismall \_] $unigraphic = \x06 -- Trick Alex into handling Unicode. See alexGetChar. $graphic = [$small $large $symbol $digit $special $unigraphic \:\"\'] +$binit = 0-1 $octit = 0-7 $hexit = [$decdigit A-F a-f] $symchar = [$symbol \:] @@ -134,6 +135,7 @@ $docsym = [\| \^ \* \$] @consym = \: $symchar* @decimal = $decdigit+ +@binary = $binit+ @octal = $octit+ @hexadecimal = $hexit+ @exponent = [eE] [\-\+]? @decimal @@ -401,9 +403,12 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } <0> { -- Normal integral literals (:: Num a => a, from Integer) @decimal { tok_num positive 0 0 decimal } + 0[bB] @binary / { ifExtension binaryLiteralsEnabled } { tok_num positive 2 2 binary } 0[oO] @octal { tok_num positive 2 2 octal } 0[xX] @hexadecimal { tok_num positive 2 2 hexadecimal } @negative @decimal / { ifExtension negativeLiteralsEnabled } { tok_num negative 1 1 decimal } + @negative 0[bB] @binary / { ifExtension negativeLiteralsEnabled `alexAndPred` + ifExtension binaryLiteralsEnabled } { tok_num negative 3 3 binary } @negative 0[oO] @octal / { ifExtension negativeLiteralsEnabled } { tok_num negative 3 3 octal } @negative 0[xX] @hexadecimal / { ifExtension negativeLiteralsEnabled } { tok_num negative 3 3 hexadecimal } @@ -417,13 +422,19 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } -- It's simpler (and faster?) to give separate cases to the negatives, -- especially considering octal/hexadecimal prefixes. @decimal \# / { ifExtension magicHashEnabled } { tok_primint positive 0 1 decimal } + 0[bB] @binary \# / { ifExtension magicHashEnabled `alexAndPred` + ifExtension binaryLiteralsEnabled } { tok_primint positive 2 3 binary } 0[oO] @octal \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 octal } 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 hexadecimal } @negative @decimal \# / { ifExtension magicHashEnabled } { tok_primint negative 1 2 decimal } + @negative 0[bB] @binary \# / { ifExtension magicHashEnabled `alexAndPred` + ifExtension binaryLiteralsEnabled } { tok_primint negative 3 4 binary } @negative 0[oO] @octal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 octal } @negative 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 hexadecimal } @decimal \# \# / { ifExtension magicHashEnabled } { tok_primword 0 2 decimal } + 0[bB] @binary \# \# / { ifExtension magicHashEnabled `alexAndPred` + ifExtension binaryLiteralsEnabled } { tok_primword 2 4 binary } 0[oO] @octal \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 octal } 0[xX] @hexadecimal \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 hexadecimal } @@ -516,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 @@ -635,7 +650,7 @@ data Token -- facilitates using a keyword in two different extensions that can be -- activated independently) -- -reservedWordsFM :: UniqFM (Token, Int) +reservedWordsFM :: UniqFM (Token, ExtsBitmap) reservedWordsFM = listToUFM $ map (\(x, y, z) -> (mkFastString x, (y, z))) [( "_", ITunderscore, 0 ), @@ -664,34 +679,34 @@ reservedWordsFM = listToUFM $ ( "type", ITtype, 0 ), ( "where", ITwhere, 0 ), - ( "forall", ITforall, bit explicitForallBit .|. - bit inRulePragBit), - ( "mdo", ITmdo, bit recursiveDoBit), + ( "forall", ITforall, xbit ExplicitForallBit .|. + xbit InRulePragBit), + ( "mdo", ITmdo, xbit RecursiveDoBit), -- See Note [Lexing type pseudo-keywords] ( "family", ITfamily, 0 ), ( "role", ITrole, 0 ), - ( "pattern", ITpattern, bit patternSynonymsBit), - ( "group", ITgroup, bit transformComprehensionsBit), - ( "by", ITby, bit transformComprehensionsBit), - ( "using", ITusing, bit transformComprehensionsBit), - - ( "foreign", ITforeign, bit ffiBit), - ( "export", ITexport, bit ffiBit), - ( "label", ITlabel, bit ffiBit), - ( "dynamic", ITdynamic, bit ffiBit), - ( "safe", ITsafe, bit ffiBit .|. - bit safeHaskellBit), - ( "interruptible", ITinterruptible, bit interruptibleFfiBit), - ( "unsafe", ITunsafe, bit ffiBit), - ( "stdcall", ITstdcallconv, bit ffiBit), - ( "ccall", ITccallconv, bit ffiBit), - ( "capi", ITcapiconv, bit cApiFfiBit), - ( "prim", ITprimcallconv, bit ffiBit), - ( "javascript", ITjavascriptcallconv, bit ffiBit), - - ( "rec", ITrec, bit arrowsBit .|. - bit recursiveDoBit), - ( "proc", ITproc, bit arrowsBit) + ( "pattern", ITpattern, xbit PatternSynonymsBit), + ( "group", ITgroup, xbit TransformComprehensionsBit), + ( "by", ITby, xbit TransformComprehensionsBit), + ( "using", ITusing, xbit TransformComprehensionsBit), + + ( "foreign", ITforeign, xbit FfiBit), + ( "export", ITexport, xbit FfiBit), + ( "label", ITlabel, xbit FfiBit), + ( "dynamic", ITdynamic, xbit FfiBit), + ( "safe", ITsafe, xbit FfiBit .|. + xbit SafeHaskellBit), + ( "interruptible", ITinterruptible, xbit InterruptibleFfiBit), + ( "unsafe", ITunsafe, xbit FfiBit), + ( "stdcall", ITstdcallconv, xbit FfiBit), + ( "ccall", ITccallconv, xbit FfiBit), + ( "capi", ITcapiconv, xbit CApiFfiBit), + ( "prim", ITprimcallconv, xbit FfiBit), + ( "javascript", ITjavascriptcallconv, xbit FfiBit), + + ( "rec", ITrec, xbit ArrowsBit .|. + xbit RecursiveDoBit), + ( "proc", ITproc, xbit ArrowsBit) ] {----------------------------------- @@ -711,7 +726,7 @@ Also, note that these are included in the `varid` production in the parser -- a key detail to make all this work. -------------------------------------} -reservedSymsFM :: UniqFM (Token, Int -> Bool) +reservedSymsFM :: UniqFM (Token, ExtsBitmap -> Bool) reservedSymsFM = listToUFM $ map (\ (x,y,z) -> (mkFastString x,(y,z))) [ ("..", ITdotdot, always) @@ -822,11 +837,11 @@ nextCharIs buf p = not (atEnd buf) && p (currentChar buf) nextCharIsNot :: StringBuffer -> (Char -> Bool) -> Bool nextCharIsNot buf p = not (nextCharIs buf p) -notFollowedBy :: Char -> AlexAccPred Int +notFollowedBy :: Char -> AlexAccPred ExtsBitmap notFollowedBy char _ _ _ (AI _ buf) = nextCharIsNot buf (== char) -notFollowedBySymbol :: AlexAccPred Int +notFollowedBySymbol :: AlexAccPred ExtsBitmap notFollowedBySymbol _ _ _ (AI _ buf) = nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~") @@ -835,7 +850,7 @@ notFollowedBySymbol _ _ _ (AI _ buf) -- maximal munch, but not always, because the nested comment rule is -- valid in all states, but the doc-comment rules are only valid in -- the non-layout states. -isNormalComment :: AlexAccPred Int +isNormalComment :: AlexAccPred ExtsBitmap isNormalComment bits _ _ (AI _ buf) | haddockEnabled bits = notFollowedByDocOrPragma | otherwise = nextCharIsNot buf (== '#') @@ -849,10 +864,10 @@ afterOptionalSpace buf p then p (snd (nextChar buf)) else p buf -atEOL :: AlexAccPred Int +atEOL :: AlexAccPred ExtsBitmap atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n' -ifExtension :: (Int -> Bool) -> AlexAccPred Int +ifExtension :: (ExtsBitmap -> Bool) -> AlexAccPred ExtsBitmap ifExtension pred bits _ _ _ = pred bits multiline_doc_comment :: Action @@ -954,12 +969,12 @@ withLexedDocType lexDocComment = do -- off again at the end of the pragma. rulePrag :: Action rulePrag span _buf _len = do - setExts (.|. bit inRulePragBit) + setExts (.|. xbit InRulePragBit) return (L span ITrules_prag) endPrag :: Action endPrag span _buf _len = do - setExts (.&. complement (bit inRulePragBit)) + setExts (.&. complement (xbit InRulePragBit)) return (L span ITclose_prag) -- docCommentEnd @@ -1112,6 +1127,7 @@ positive = id negative = negate decimal, octal, hexadecimal :: (Integer, Char -> Int) decimal = (10,octDecDigit) +binary = (2,octDecDigit) octal = (8,octDecDigit) hexadecimal = (16,hexDigit) @@ -1410,6 +1426,7 @@ lex_escape = do 'x' -> readNum is_hexdigit 16 hexDigit 'o' -> readNum is_octdigit 8 octDecDigit + 'b' -> readNum is_bindigit 2 octDecDigit x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x) c1 -> do @@ -1592,7 +1609,7 @@ data PState = PState { last_loc :: RealSrcSpan, -- pos of previous token last_len :: !Int, -- len of previous token loc :: RealSrcLoc, -- current loc (end of prev token + 1) - extsBitmap :: !Int, -- bitmap that determines permitted + extsBitmap :: !ExtsBitmap, -- bitmap that determines permitted -- extensions context :: [LayoutContext], lex_state :: [Int], @@ -1664,18 +1681,18 @@ 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 -extension :: (Int -> Bool) -> P Bool +extension :: (ExtsBitmap -> Bool) -> P Bool extension p = P $ \s -> POk s (p $! extsBitmap s) -getExts :: P Int +getExts :: P ExtsBitmap getExts = P $ \s -> POk s (extsBitmap s) -setExts :: (Int -> Int) -> P () +setExts :: (ExtsBitmap -> ExtsBitmap) -> P () setExts f = P $ \s -> POk s{ extsBitmap = f (extsBitmap s) } () setSrcLoc :: RealSrcLoc -> P () @@ -1855,130 +1872,110 @@ setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () -- for reasons of efficiency, flags indicating language extensions (eg, -- -fglasgow-exts or -XParallelArrays) are represented by a bitmap --- stored in an unboxed Int - -ffiBit :: Int -ffiBit= 0 -interruptibleFfiBit :: Int -interruptibleFfiBit = 1 -cApiFfiBit :: Int -cApiFfiBit = 2 -parrBit :: Int -parrBit = 3 -arrowsBit :: Int -arrowsBit = 4 -thBit :: Int -thBit = 5 -ipBit :: Int -ipBit = 6 -explicitForallBit :: Int -explicitForallBit = 7 -- the 'forall' keyword and '.' symbol -bangPatBit :: Int -bangPatBit = 8 -- Tells the parser to understand bang-patterns - -- (doesn't affect the lexer) -patternSynonymsBit :: Int -patternSynonymsBit = 9 -- pattern synonyms -haddockBit :: Int -haddockBit = 10 -- Lex and parse Haddock comments -magicHashBit :: Int -magicHashBit = 11 -- "#" in both functions and operators -kindSigsBit :: Int -kindSigsBit = 12 -- Kind signatures on type variables -recursiveDoBit :: Int -recursiveDoBit = 13 -- mdo -unicodeSyntaxBit :: Int -unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc -unboxedTuplesBit :: Int -unboxedTuplesBit = 15 -- (# and #) -datatypeContextsBit :: Int -datatypeContextsBit = 16 -transformComprehensionsBit :: Int -transformComprehensionsBit = 17 -qqBit :: Int -qqBit = 18 -- enable quasiquoting -inRulePragBit :: Int -inRulePragBit = 19 -rawTokenStreamBit :: Int -rawTokenStreamBit = 20 -- producing a token stream with all comments included -sccProfilingOnBit :: Int -sccProfilingOnBit = 21 -hpcBit :: Int -hpcBit = 22 -alternativeLayoutRuleBit :: Int -alternativeLayoutRuleBit = 23 -relaxedLayoutBit :: Int -relaxedLayoutBit = 24 -nondecreasingIndentationBit :: Int -nondecreasingIndentationBit = 25 -safeHaskellBit :: Int -safeHaskellBit = 26 -traditionalRecordSyntaxBit :: Int -traditionalRecordSyntaxBit = 27 -typeLiteralsBit :: Int -typeLiteralsBit = 28 -explicitNamespacesBit :: Int -explicitNamespacesBit = 29 -lambdaCaseBit :: Int -lambdaCaseBit = 30 -negativeLiteralsBit :: Int -negativeLiteralsBit = 31 - - -always :: Int -> Bool +-- stored in an unboxed Word64 +type ExtsBitmap = Word64 + +xbit :: ExtBits -> ExtsBitmap +xbit = bit . fromEnum + +xtest :: ExtBits -> ExtsBitmap -> Bool +xtest ext xmap = testBit xmap (fromEnum ext) + +data ExtBits + = FfiBit + | InterruptibleFfiBit + | CApiFfiBit + | ParrBit + | ArrowsBit + | ThBit + | IpBit + | ExplicitForallBit -- the 'forall' keyword and '.' symbol + | BangPatBit -- Tells the parser to understand bang-patterns + -- (doesn't affect the lexer) + | PatternSynonymsBit -- pattern synonyms + | HaddockBit-- Lex and parse Haddock comments + | MagicHashBit -- "#" in both functions and operators + | KindSigsBit -- Kind signatures on type variables + | RecursiveDoBit -- mdo + | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc + | UnboxedTuplesBit -- (# and #) + | DatatypeContextsBit + | TransformComprehensionsBit + | QqBit -- enable quasiquoting + | InRulePragBit + | RawTokenStreamBit -- producing a token stream with all comments included + | SccProfilingOnBit + | HpcBit + | AlternativeLayoutRuleBit + | RelaxedLayoutBit + | NondecreasingIndentationBit + | SafeHaskellBit + | TraditionalRecordSyntaxBit + | TypeLiteralsBit + | ExplicitNamespacesBit + | LambdaCaseBit + | BinaryLiteralsBit + | NegativeLiteralsBit + deriving Enum + + +always :: ExtsBitmap -> Bool always _ = True -parrEnabled :: Int -> Bool -parrEnabled flags = testBit flags parrBit -arrowsEnabled :: Int -> Bool -arrowsEnabled flags = testBit flags arrowsBit -thEnabled :: Int -> Bool -thEnabled flags = testBit flags thBit -ipEnabled :: Int -> Bool -ipEnabled flags = testBit flags ipBit -explicitForallEnabled :: Int -> Bool -explicitForallEnabled flags = testBit flags explicitForallBit -bangPatEnabled :: Int -> Bool -bangPatEnabled flags = testBit flags bangPatBit -haddockEnabled :: Int -> Bool -haddockEnabled flags = testBit flags haddockBit -magicHashEnabled :: Int -> Bool -magicHashEnabled flags = testBit flags magicHashBit --- kindSigsEnabled :: Int -> Bool --- kindSigsEnabled flags = testBit flags kindSigsBit -unicodeSyntaxEnabled :: Int -> Bool -unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit -unboxedTuplesEnabled :: Int -> Bool -unboxedTuplesEnabled flags = testBit flags unboxedTuplesBit -datatypeContextsEnabled :: Int -> Bool -datatypeContextsEnabled flags = testBit flags datatypeContextsBit -qqEnabled :: Int -> Bool -qqEnabled flags = testBit flags qqBit -inRulePrag :: Int -> Bool -inRulePrag flags = testBit flags inRulePragBit -rawTokenStreamEnabled :: Int -> Bool -rawTokenStreamEnabled flags = testBit flags rawTokenStreamBit -alternativeLayoutRule :: Int -> Bool -alternativeLayoutRule flags = testBit flags alternativeLayoutRuleBit -hpcEnabled :: Int -> Bool -hpcEnabled flags = testBit flags hpcBit -relaxedLayout :: Int -> Bool -relaxedLayout flags = testBit flags relaxedLayoutBit -nondecreasingIndentation :: Int -> Bool -nondecreasingIndentation flags = testBit flags nondecreasingIndentationBit -sccProfilingOn :: Int -> Bool -sccProfilingOn flags = testBit flags sccProfilingOnBit -traditionalRecordSyntaxEnabled :: Int -> Bool -traditionalRecordSyntaxEnabled flags = testBit flags traditionalRecordSyntaxBit -typeLiteralsEnabled :: Int -> Bool -typeLiteralsEnabled flags = testBit flags typeLiteralsBit - -explicitNamespacesEnabled :: Int -> Bool -explicitNamespacesEnabled flags = testBit flags explicitNamespacesBit -lambdaCaseEnabled :: Int -> Bool -lambdaCaseEnabled flags = testBit flags lambdaCaseBit -negativeLiteralsEnabled :: Int -> Bool -negativeLiteralsEnabled flags = testBit flags negativeLiteralsBit -patternSynonymsEnabled :: Int -> Bool -patternSynonymsEnabled flags = testBit flags patternSynonymsBit +parrEnabled :: ExtsBitmap -> Bool +parrEnabled = xtest ParrBit +arrowsEnabled :: ExtsBitmap -> Bool +arrowsEnabled = xtest ArrowsBit +thEnabled :: ExtsBitmap -> Bool +thEnabled = xtest ThBit +ipEnabled :: ExtsBitmap -> Bool +ipEnabled = xtest IpBit +explicitForallEnabled :: ExtsBitmap -> Bool +explicitForallEnabled = xtest ExplicitForallBit +bangPatEnabled :: ExtsBitmap -> Bool +bangPatEnabled = xtest BangPatBit +haddockEnabled :: ExtsBitmap -> Bool +haddockEnabled = xtest HaddockBit +magicHashEnabled :: ExtsBitmap -> Bool +magicHashEnabled = xtest MagicHashBit +-- kindSigsEnabled :: ExtsBitmap -> Bool +-- kindSigsEnabled = xtest KindSigsBit +unicodeSyntaxEnabled :: ExtsBitmap -> Bool +unicodeSyntaxEnabled = xtest UnicodeSyntaxBit +unboxedTuplesEnabled :: ExtsBitmap -> Bool +unboxedTuplesEnabled = xtest UnboxedTuplesBit +datatypeContextsEnabled :: ExtsBitmap -> Bool +datatypeContextsEnabled = xtest DatatypeContextsBit +qqEnabled :: ExtsBitmap -> Bool +qqEnabled = xtest QqBit +inRulePrag :: ExtsBitmap -> Bool +inRulePrag = xtest InRulePragBit +rawTokenStreamEnabled :: ExtsBitmap -> Bool +rawTokenStreamEnabled = xtest RawTokenStreamBit +alternativeLayoutRule :: ExtsBitmap -> Bool +alternativeLayoutRule = xtest AlternativeLayoutRuleBit +hpcEnabled :: ExtsBitmap -> Bool +hpcEnabled = xtest HpcBit +relaxedLayout :: ExtsBitmap -> Bool +relaxedLayout = xtest RelaxedLayoutBit +nondecreasingIndentation :: ExtsBitmap -> Bool +nondecreasingIndentation = xtest NondecreasingIndentationBit +sccProfilingOn :: ExtsBitmap -> Bool +sccProfilingOn = xtest SccProfilingOnBit +traditionalRecordSyntaxEnabled :: ExtsBitmap -> Bool +traditionalRecordSyntaxEnabled = xtest TraditionalRecordSyntaxBit +typeLiteralsEnabled :: ExtsBitmap -> Bool +typeLiteralsEnabled = xtest TypeLiteralsBit + +explicitNamespacesEnabled :: ExtsBitmap -> Bool +explicitNamespacesEnabled = xtest ExplicitNamespacesBit +lambdaCaseEnabled :: ExtsBitmap -> Bool +lambdaCaseEnabled = xtest LambdaCaseBit +binaryLiteralsEnabled :: ExtsBitmap -> Bool +binaryLiteralsEnabled = xtest BinaryLiteralsBit +negativeLiteralsEnabled :: ExtsBitmap -> Bool +negativeLiteralsEnabled = xtest NegativeLiteralsBit +patternSynonymsEnabled :: ExtsBitmap -> Bool +patternSynonymsEnabled = xtest PatternSynonymsBit -- PState for parsing options pragmas -- @@ -1999,7 +1996,7 @@ mkPState flags buf loc = last_loc = mkRealSrcSpan loc loc, last_len = 0, loc = loc, - extsBitmap = fromIntegral bitmap, + extsBitmap = bitmap, context = [], lex_state = [bol, 0], srcfiles = [], @@ -2011,41 +2008,42 @@ mkPState flags buf loc = alr_justClosedExplicitLetBlock = False } where - bitmap = ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags - .|. interruptibleFfiBit `setBitIf` xopt Opt_InterruptibleFFI flags - .|. cApiFfiBit `setBitIf` xopt Opt_CApiFFI flags - .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags - .|. arrowsBit `setBitIf` xopt Opt_Arrows flags - .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags - .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags - .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags - .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags - .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags - .|. haddockBit `setBitIf` gopt Opt_Haddock flags - .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags - .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags - .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags - .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags - .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags - .|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags - .|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags - .|. transformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags - .|. rawTokenStreamBit `setBitIf` gopt Opt_KeepRawTokenStream flags - .|. hpcBit `setBitIf` gopt Opt_Hpc flags - .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags - .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags - .|. sccProfilingOnBit `setBitIf` gopt Opt_SccProfilingOn flags - .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags - .|. safeHaskellBit `setBitIf` safeImportsOn flags - .|. traditionalRecordSyntaxBit `setBitIf` xopt Opt_TraditionalRecordSyntax flags - .|. typeLiteralsBit `setBitIf` xopt Opt_DataKinds flags - .|. explicitNamespacesBit `setBitIf` xopt Opt_ExplicitNamespaces flags - .|. lambdaCaseBit `setBitIf` xopt Opt_LambdaCase flags - .|. negativeLiteralsBit `setBitIf` xopt Opt_NegativeLiterals flags - .|. patternSynonymsBit `setBitIf` xopt Opt_PatternSynonyms flags + bitmap = FfiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags + .|. InterruptibleFfiBit `setBitIf` xopt Opt_InterruptibleFFI flags + .|. CApiFfiBit `setBitIf` xopt Opt_CApiFFI flags + .|. ParrBit `setBitIf` xopt Opt_ParallelArrays flags + .|. ArrowsBit `setBitIf` xopt Opt_Arrows flags + .|. ThBit `setBitIf` xopt Opt_TemplateHaskell flags + .|. QqBit `setBitIf` xopt Opt_QuasiQuotes flags + .|. IpBit `setBitIf` xopt Opt_ImplicitParams flags + .|. ExplicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags + .|. BangPatBit `setBitIf` xopt Opt_BangPatterns flags + .|. HaddockBit `setBitIf` gopt Opt_Haddock flags + .|. MagicHashBit `setBitIf` xopt Opt_MagicHash flags + .|. KindSigsBit `setBitIf` xopt Opt_KindSignatures flags + .|. RecursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags + .|. UnicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags + .|. UnboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags + .|. DatatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags + .|. TransformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags + .|. TransformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags + .|. RawTokenStreamBit `setBitIf` gopt Opt_KeepRawTokenStream flags + .|. HpcBit `setBitIf` gopt Opt_Hpc flags + .|. AlternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags + .|. RelaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags + .|. SccProfilingOnBit `setBitIf` gopt Opt_SccProfilingOn flags + .|. NondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags + .|. SafeHaskellBit `setBitIf` safeImportsOn flags + .|. TraditionalRecordSyntaxBit `setBitIf` xopt Opt_TraditionalRecordSyntax flags + .|. TypeLiteralsBit `setBitIf` xopt Opt_DataKinds flags + .|. ExplicitNamespacesBit `setBitIf` xopt Opt_ExplicitNamespaces flags + .|. LambdaCaseBit `setBitIf` xopt Opt_LambdaCase flags + .|. BinaryLiteralsBit `setBitIf` xopt Opt_BinaryLiterals flags + .|. NegativeLiteralsBit `setBitIf` xopt Opt_NegativeLiterals flags + .|. PatternSynonymsBit `setBitIf` xopt Opt_PatternSynonyms flags -- - setBitIf :: Int -> Bool -> Int - b `setBitIf` cond | cond = bit b + setBitIf :: ExtBits -> Bool -> ExtsBitmap + b `setBitIf` cond | cond = xbit b | otherwise = 0 addWarning :: WarningFlag -> SrcSpan -> SDoc -> P () @@ -2434,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)), @@ -2447,7 +2449,7 @@ dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToStr Just found -> found span buf len Nothing -> lexError "unknown pragma" -known_pragma :: Map String Action -> AlexAccPred Int +known_pragma :: Map String Action -> AlexAccPred ExtsBitmap known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf) = isKnown && nextCharIsNot curbuf pragmaNameChar where l = lexemeToString startbuf (byteDiff startbuf curbuf) diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 27d6c3839f..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 @@ -1041,7 +1091,7 @@ sigtypedoc :: { LHsType RdrName } -- Always a HsForAllTy : ctypedoc { L1 (mkImplicitHsForAllTy (noLoc []) $1) } -- Wrap an Implicit forall if there isn't one there already -sig_vars :: { Located [Located RdrName] } +sig_vars :: { Located [Located RdrName] } -- Returned in reversed order : sig_vars ',' var { LL ($3 : unLoc $1) } | var { L1 [$1] } @@ -1423,7 +1473,7 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) } {% do s <- checkValSig $1 $3 ; return (LL $ unitOL (LL $ SigD s)) } | var ',' sig_vars '::' sigtypedoc - { LL $ toOL [ LL $ SigD (TypeSig ($1 : unLoc $3) $5) ] } + { LL $ toOL [ LL $ SigD (TypeSig ($1 : reverse (unLoc $3)) $5) ] } | infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1)))) | n <- unLoc $3 ] } | '{-# INLINE' activation qvar '#-}' @@ -1476,18 +1526,18 @@ infixexp :: { LHsExpr RdrName } exp10 :: { LHsExpr RdrName } : '\\' apat apats opt_asig '->' exp - { LL $ HsLam (mkMatchGroup [LL $ Match ($2:$3) $4 + { LL $ HsLam (mkMatchGroup FromSource [LL $ Match ($2:$3) $4 (unguardedGRHSs $6) - ]) } + ]) } | 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 } | '\\' 'lcase' altslist - { LL $ HsLamCase placeHolderType (mkMatchGroup (unLoc $3)) } + { LL $ HsLamCase placeHolderType (mkMatchGroup FromSource (unLoc $3)) } | 'if' exp optSemi 'then' exp optSemi 'else' exp {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >> return (LL $ mkHsIf $2 $5 $8) } | 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >> return (LL $ HsMultiIf placeHolderType (reverse $ unLoc $2)) } - | 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) } + | 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup FromSource (unLoc $4)) } | '-' fexp { LL $ NegApp $2 noSyntaxExpr } | 'do' stmtlist { L (comb2 $1 $2) (mkHsDo DoExpr (unLoc $2)) } diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y deleted file mode 100644 index 4e7f48c6fc..0000000000 --- a/compiler/parser/ParserCore.y +++ /dev/null @@ -1,397 +0,0 @@ -{ -{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 -{-# OPTIONS -Wwarn -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - -module ParserCore ( parseCore ) where - -import IfaceSyn -import ForeignCall -import RdrHsSyn -import HsSyn hiding (toHsType, toHsKind) -import RdrName -import OccName -import TypeRep ( TyThing(..) ) -import Type ( Kind, - liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, - mkTyConApp - ) -import Kind( mkArrowKind ) -import Name( Name, nameOccName, nameModule, mkExternalName, wiredInNameTyThing_maybe ) -import Module -import ParserCoreUtils -import LexCore -import Literal -import SrcLoc -import PrelNames -import TysPrim -import TyCon ( TyCon, tyConName ) -import FastString -import Outputable -import Data.Char -import Unique - -#include "../HsVersions.h" - -} - -%name parseCore -%expect 0 -%tokentype { Token } - -%token - '%module' { TKmodule } - '%data' { TKdata } - '%newtype' { TKnewtype } - '%forall' { TKforall } - '%rec' { TKrec } - '%let' { TKlet } - '%in' { TKin } - '%case' { TKcase } - '%of' { TKof } - '%cast' { TKcast } - '%note' { TKnote } - '%external' { TKexternal } - '%local' { TKlocal } - '%_' { TKwild } - '(' { TKoparen } - ')' { TKcparen } - '{' { TKobrace } - '}' { TKcbrace } - '#' { TKhash} - '=' { TKeq } - ':' { TKcolon } - '::' { TKcoloncolon } - ':=:' { TKcoloneqcolon } - '*' { TKstar } - '->' { TKrarrow } - '\\' { TKlambda} - '@' { TKat } - '.' { TKdot } - '?' { TKquestion} - ';' { TKsemicolon } - NAME { TKname $$ } - CNAME { TKcname $$ } - INTEGER { TKinteger $$ } - RATIONAL { TKrational $$ } - STRING { TKstring $$ } - CHAR { TKchar $$ } - -%monad { P } { thenP } { returnP } -%lexer { lexer } { TKEOF } - -%% - -module :: { HsExtCore RdrName } - -- : '%module' modid tdefs vdefgs { HsExtCore $2 $3 $4 } - : '%module' modid tdefs vdefgs { HsExtCore $2 [] [] } - - -------------------------------------------------------------- --- Names: the trickiest bit in here - --- A name of the form A.B.C could be: --- module A.B.C --- dcon C in module A.B --- tcon C in module A.B -modid :: { Module } - : NAME ':' mparts { undefined } - -q_dc_name :: { Name } - : NAME ':' mparts { undefined } - -q_tc_name :: { Name } - : NAME ':' mparts { undefined } - -q_var_occ :: { Name } - : NAME ':' vparts { undefined } - -mparts :: { [String] } - : CNAME { [$1] } - | CNAME '.' mparts { $1:$3 } - -vparts :: { [String] } - : var_occ { [$1] } - | CNAME '.' vparts { $1:$3 } - -------------------------------------------------------------- --- Type and newtype declarations are in HsSyn syntax - -tdefs :: { [TyClDecl RdrName] } - : {- empty -} {[]} - | tdef tdefs {$1:$2} - -tdef :: { TyClDecl RdrName } - : '%data' q_tc_name tv_bndrs '=' '{' cons '}' ';' - { DataDecl { tcdLName = noLoc (ifaceExtRdrName $2) - , tcdTyVars = mkHsQTvs (map toHsTvBndr $3) - , tcdDataDefn = HsDataDefn { dd_ND = DataType, dd_ctxt = noLoc [] - , dd_kindSig = Nothing - , dd_cons = $6, dd_derivs = Nothing } } } - | '%newtype' q_tc_name tv_bndrs trep ';' - { let tc_rdr = ifaceExtRdrName $2 in - DataDecl { tcdLName = noLoc tc_rdr - , tcdTyVars = mkHsQTvs (map toHsTvBndr $3) - , tcdDataDefn = HsDataDefn { dd_ND = NewType, dd_ctxt = noLoc [] - , dd_kindSig = Nothing - , dd_cons = $4 (rdrNameOcc tc_rdr), dd_derivs = Nothing } } } - --- For a newtype we have to invent a fake data constructor name --- It doesn't matter what it is, because it won't be used -trep :: { OccName -> [LConDecl RdrName] } - : {- empty -} { (\ tc_occ -> []) } - | '=' ty { (\ tc_occ -> let { dc_name = mkRdrUnqual (setOccNameSpace dataName tc_occ) ; - con_info = PrefixCon [toHsType $2] } - in [noLoc $ mkSimpleConDecl (noLoc dc_name) [] - (noLoc []) con_info]) } - -cons :: { [LConDecl RdrName] } - : {- empty -} { [] } -- 20060420 Empty data types allowed. jds - | con { [$1] } - | con ';' cons { $1:$3 } - -con :: { LConDecl RdrName } - : d_pat_occ attv_bndrs hs_atys - { noLoc $ mkSimpleConDecl (noLoc (mkRdrUnqual $1)) $2 (noLoc []) (PrefixCon $3) } --- ToDo: parse record-style declarations - -attv_bndrs :: { [LHsTyVarBndr RdrName] } - : {- empty -} { [] } - | '@' tv_bndr attv_bndrs { toHsTvBndr $2 : $3 } - -hs_atys :: { [LHsType RdrName] } - : atys { map toHsType $1 } - - ---------------------------------------- --- Types ---------------------------------------- - -atys :: { [IfaceType] } - : {- empty -} { [] } - | aty atys { $1:$2 } - -aty :: { IfaceType } - : fs_var_occ { IfaceTyVar $1 } - | q_tc_name { IfaceTyConApp (IfaceTc $1) [] } - | '(' ty ')' { $2 } - -bty :: { IfaceType } - : fs_var_occ atys { foldl IfaceAppTy (IfaceTyVar $1) $2 } - | q_var_occ atys { undefined } - | q_tc_name atys { IfaceTyConApp (IfaceTc $1) $2 } - | '(' ty ')' { $2 } - -ty :: { IfaceType } - : bty { $1 } - | bty '->' ty { IfaceFunTy $1 $3 } - | '%forall' tv_bndrs '.' ty { foldr IfaceForAllTy $4 $2 } - ----------------------------------------------- --- Bindings are in Iface syntax - -vdefgs :: { [IfaceBinding] } - : {- empty -} { [] } - | let_bind ';' vdefgs { $1 : $3 } - -let_bind :: { IfaceBinding } - : '%rec' '{' vdefs1 '}' { IfaceRec $3 } -- Can be empty. Do we care? - | vdef { let (b,r) = $1 - in IfaceNonRec b r } - -vdefs1 :: { [(IfaceLetBndr, IfaceExpr)] } - : vdef { [$1] } - | vdef ';' vdefs1 { $1:$3 } - -vdef :: { (IfaceLetBndr, IfaceExpr) } - : fs_var_occ '::' ty '=' exp { (IfLetBndr $1 $3 NoInfo, $5) } - | '%local' vdef { $2 } - - -- NB: qd_occ includes data constructors, because - -- we allow data-constructor wrappers at top level - -- But we discard the module name, because it must be the - -- same as the module being compiled, and Iface syntax only - -- has OccNames in binding positions. Ah, but it has Names now! - ---------------------------------------- --- Binders -bndr :: { IfaceBndr } - : '@' tv_bndr { IfaceTvBndr $2 } - | id_bndr { IfaceIdBndr $1 } - -bndrs :: { [IfaceBndr] } - : bndr { [$1] } - | bndr bndrs { $1:$2 } - -id_bndr :: { IfaceIdBndr } - : '(' fs_var_occ '::' ty ')' { ($2,$4) } - -tv_bndr :: { IfaceTvBndr } - : fs_var_occ { ($1, ifaceLiftedTypeKind) } - | '(' fs_var_occ '::' akind ')' { ($2, $4) } - -tv_bndrs :: { [IfaceTvBndr] } - : {- empty -} { [] } - | tv_bndr tv_bndrs { $1:$2 } - -akind :: { IfaceKind } - : '*' { ifaceLiftedTypeKind } - | '#' { ifaceUnliftedTypeKind } - | '?' { ifaceOpenTypeKind } - | '(' kind ')' { $2 } - -kind :: { IfaceKind } - : akind { $1 } - | akind '->' kind { ifaceArrow $1 $3 } - ------------------------------------------ --- Expressions - -aexp :: { IfaceExpr } - : fs_var_occ { IfaceLcl $1 } - | q_var_occ { IfaceExt $1 } - | q_dc_name { IfaceExt $1 } - | lit { IfaceLit $1 } - | '(' exp ')' { $2 } - -fexp :: { IfaceExpr } - : fexp aexp { IfaceApp $1 $2 } - | fexp '@' aty { IfaceApp $1 (IfaceType $3) } - | aexp { $1 } - -exp :: { IfaceExpr } - : fexp { $1 } - | '\\' bndrs '->' exp { foldr IfaceLam $4 $2 } - | '%let' let_bind '%in' exp { IfaceLet $2 $4 } --- gaw 2004 - | '%case' '(' ty ')' aexp '%of' id_bndr - '{' alts1 '}' { IfaceCase $5 (fst $7) $9 } --- The following line is broken and is hard to fix. Not fixing now --- because this whole parser is bitrotten anyway. --- Richard Eisenberg, July 2013 --- | '%cast' aexp aty { IfaceCast $2 $3 } --- No InlineMe any more --- | '%note' STRING exp --- { case $2 of --- --"SCC" -> IfaceNote (IfaceSCC "scc") $3 --- "InlineMe" -> IfaceNote IfaceInlineMe $3 --- } - | '%external' STRING aty { IfaceFCall (ForeignCall.CCall - (CCallSpec (StaticTarget (mkFastString $2) Nothing True) - CCallConv PlaySafe)) - $3 } - -alts1 :: { [IfaceAlt] } - : alt { [$1] } - | alt ';' alts1 { $1:$3 } - -alt :: { IfaceAlt } - : q_dc_name bndrs '->' exp - { (IfaceDataAlt $1, map ifaceBndrName $2, $4) } - -- The external syntax currently includes the types of the - -- the args, but they aren't needed internally - -- Nor is the module qualifier - | q_dc_name '->' exp - { (IfaceDataAlt $1, [], $3) } - | lit '->' exp - { (IfaceLitAlt $1, [], $3) } - | '%_' '->' exp - { (IfaceDefault, [], $3) } - -lit :: { Literal } - : '(' INTEGER '::' aty ')' { convIntLit $2 $4 } - | '(' RATIONAL '::' aty ')' { convRatLit $2 $4 } - | '(' CHAR '::' aty ')' { MachChar $2 } - | '(' STRING '::' aty ')' { MachStr (fastStringToByteString (mkFastString $2)) } - -fs_var_occ :: { FastString } - : NAME { mkFastString $1 } - -var_occ :: { String } - : NAME { $1 } - - --- Data constructor in a pattern or data type declaration; use the dataName, --- because that's what we expect in Core case patterns -d_pat_occ :: { OccName } - : CNAME { mkOccName dataName $1 } - -{ - -ifaceKind kc = IfaceTyConApp kc [] - -ifaceBndrName (IfaceIdBndr (n,_)) = n -ifaceBndrName (IfaceTvBndr (n,_)) = n - -convIntLit :: Integer -> IfaceType -> Literal -convIntLit i (IfaceTyConApp tc []) - | tc `eqTc` intPrimTyCon = MachInt i - | tc `eqTc` wordPrimTyCon = MachWord i - | tc `eqTc` charPrimTyCon = MachChar (chr (fromInteger i)) - | tc `eqTc` addrPrimTyCon && i == 0 = MachNullAddr -convIntLit i aty - = pprPanic "Unknown integer literal type" (ppr aty) - -convRatLit :: Rational -> IfaceType -> Literal -convRatLit r (IfaceTyConApp tc []) - | tc `eqTc` floatPrimTyCon = MachFloat r - | tc `eqTc` doublePrimTyCon = MachDouble r -convRatLit i aty - = pprPanic "Unknown rational literal type" (ppr aty) - -eqTc :: IfaceTyCon -> TyCon -> Bool -- Ugh! -eqTc (IfaceTc name) tycon = name == tyConName tycon - --- Tiresomely, we have to generate both HsTypes (in type/class decls) --- and IfaceTypes (in Core expressions). So we parse them as IfaceTypes, --- and convert to HsTypes here. But the IfaceTypes we can see here --- are very limited (see the productions for 'ty'), so the translation --- isn't hard -toHsType :: IfaceType -> LHsType RdrName -toHsType (IfaceTyVar v) = noLoc $ HsTyVar (mkRdrUnqual (mkTyVarOccFS v)) -toHsType (IfaceAppTy t1 t2) = noLoc $ HsAppTy (toHsType t1) (toHsType t2) -toHsType (IfaceFunTy t1 t2) = noLoc $ HsFunTy (toHsType t1) (toHsType t2) -toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl mkHsAppTy (noLoc $ HsTyVar (ifaceExtRdrName tc)) (map toHsType ts) -toHsType (IfaceForAllTy tv t) = add_forall (toHsTvBndr tv) (toHsType t) - --- Only a limited form of kind will be encountered... hopefully -toHsKind :: IfaceKind -> LHsKind RdrName --- IA0_NOTE: Shouldn't we add kind variables? -toHsKind (IfaceFunTy ifK1 ifK2) = noLoc $ HsFunTy (toHsKind ifK1) (toHsKind ifK2) -toHsKind (IfaceTyConApp ifKc []) = noLoc $ HsTyVar (nameRdrName (tyConName (toKindTc ifKc))) -toHsKind other = pprPanic "toHsKind" (ppr other) - -toKindTc :: IfaceTyCon -> TyCon -toKindTc (IfaceTc n) | Just (ATyCon tc) <- wiredInNameTyThing_maybe n = tc -toKindTc other = pprPanic "toKindTc" (ppr other) - -ifaceTcType ifTc = IfaceTyConApp ifTc [] - -ifaceLiftedTypeKind = ifaceTcType (IfaceTc liftedTypeKindTyConName) -ifaceOpenTypeKind = ifaceTcType (IfaceTc openTypeKindTyConName) -ifaceUnliftedTypeKind = ifaceTcType (IfaceTc unliftedTypeKindTyConName) - -ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2 - -toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName -toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig - where - bsig = toHsKind k - -ifaceExtRdrName :: Name -> RdrName -ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name) -ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other) - -add_forall tv (L _ (HsForAllTy exp tvs cxt t)) - = noLoc $ HsForAllTy exp (mkHsQTvs (tv : hsQTvBndrs tvs)) cxt t -add_forall tv t - = noLoc $ HsForAllTy Explicit (mkHsQTvs [tv]) (noLoc []) t - -happyError :: P a -happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l -} - diff --git a/compiler/parser/ParserCoreUtils.hs b/compiler/parser/ParserCoreUtils.hs deleted file mode 100644 index 8f67d96239..0000000000 --- a/compiler/parser/ParserCoreUtils.hs +++ /dev/null @@ -1,77 +0,0 @@ -module ParserCoreUtils where - -import Exception -import System.IO - -data ParseResult a = OkP a | FailP String -type P a = String -> Int -> ParseResult a - -thenP :: P a -> (a -> P b) -> P b -m `thenP` k = \ s l -> - case m s l of - OkP a -> k a s l - FailP s -> FailP s - -returnP :: a -> P a -returnP m _ _ = OkP m - -failP :: String -> P a -failP s s' _ = FailP (s ++ ":" ++ s') - -getCoreModuleName :: FilePath -> IO String -getCoreModuleName fpath = - catchIO (do - h <- openFile fpath ReadMode - ls <- hGetContents h - let mo = findMod (words ls) - -- make sure we close up the file right away. - (length mo) `seq` return () - hClose h - return mo) - (\ _ -> return "Main") - where - findMod [] = "Main" - -- TODO: this should just return the module name, without the package name - findMod ("%module":m:_) = m - findMod (_:xs) = findMod xs - - -data Token = - TKmodule - | TKdata - | TKnewtype - | TKforall - | TKrec - | TKlet - | TKin - | TKcase - | TKof - | TKcast - | TKnote - | TKexternal - | TKlocal - | TKwild - | TKoparen - | TKcparen - | TKobrace - | TKcbrace - | TKhash - | TKeq - | TKcolon - | TKcoloncolon - | TKcoloneqcolon - | TKstar - | TKrarrow - | TKlambda - | TKat - | TKdot - | TKquestion - | TKsemicolon - | TKname String - | TKcname String - | TKinteger Integer - | TKrational Rational - | TKstring String - | TKchar Char - | TKEOF - diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index b1e177a3a9..84a284f0ab 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -4,6 +4,8 @@ o% Functions over HsSyn specialised to RdrName. \begin{code} +{-# LANGUAGE CPP #-} + module RdrHsSyn ( mkHsOpApp, mkHsIntegral, mkHsFractional, mkHsIsString, @@ -15,6 +17,7 @@ module RdrHsSyn ( mkTyFamInst, mkFamDecl, splitCon, mkInlinePragma, + splitPatSyn, toPatSynMatchGroup, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp mkTyLit, mkTyClD, mkInstD, @@ -32,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 @@ -71,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 ) @@ -122,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 @@ -142,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, @@ -170,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 })) } @@ -179,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 @@ -212,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 @@ -315,7 +334,7 @@ cvBindsAndSigs fb = go (fromOL fb) go [] = (emptyBag, [], [], [], [], []) go (L l (SigD s) : ds) = (bs, L l s : ss, ts, tfis, dfis, docs) where (bs, ss, ts, tfis, dfis, docs) = go ds - go (L l (ValD b) : ds) = ((FromSource, b') `consBag` bs, ss, ts, tfis, dfis, docs) + go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, tfis, dfis, docs) where (b', ds') = getMonoBind (L l b) ds (bs, ss, ts, tfis, dfis, docs) = go ds' go (L l (TyClD (FamDecl t)) : ds) = (bs, ss, L l t : ts, tfis, dfis, docs) @@ -410,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] @@ -500,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 "= ...") @@ -666,7 +751,7 @@ checkAPat msg loc e0 = do ExplicitTuple es b | all tupArgPresent es -> do ps <- mapM (checkLPat msg) [e | Present e <- es] - return (TuplePat ps b placeHolderType) + return (TuplePat ps b []) | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0) RecordCon c _ (HsRecFields fs dd) @@ -735,7 +820,7 @@ checkFunBind msg lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) makeFunBind :: Located id -> Bool -> [LMatch id (LHsExpr id)] -> HsBind id -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too makeFunBind fn is_infix ms - = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms, + = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup FromSource ms, fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing } checkPatBind :: SDoc 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 014e0e7483..eaefff2364 100644 --- a/compiler/prelude/PrelInfo.lhs +++ b/compiler/prelude/PrelInfo.lhs @@ -4,13 +4,7 @@ \section[PrelInfo]{The @PrelInfo@ interface to the compiler's prelude knowledge} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - +{-# LANGUAGE CPP #-} module PrelInfo ( wiredInIds, ghcPrimIds, primOpRules, builtinRules, @@ -18,7 +12,7 @@ module PrelInfo ( ghcPrimExports, wiredInThings, basicKnownKeyNames, primOpId, - + -- Random other things maybeCharLikeCon, maybeIntLikeCon, @@ -48,9 +42,9 @@ import Data.Array \end{code} %************************************************************************ -%* * +%* * \subsection[builtinNameInfo]{Lookup built-in names} -%* * +%* * %************************************************************************ Notes about wired in things @@ -58,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. @@ -77,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 @@ -99,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 @@ -116,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 @@ -129,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). @@ -151,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 86f8d29229..5757ba1234 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -37,56 +37,73 @@ Nota Bene: all Names defined in here should come from the base package Note [Known-key names] ~~~~~~~~~~~~~~~~~~~~~~ +It is *very* important that the compiler gives wired-in things and +things with "known-key" names the correct Uniques wherever they +occur. We have to be careful about this in exactly two places: -It is *very* important that the compiler gives wired-in things and things with "known-key" names -the correct Uniques wherever they occur. We have to be careful about this in exactly two places: + 1. When we parse some source code, renaming the AST better yield an + AST whose Names have the correct uniques - 1. When we parse some source code, renaming the AST better yield an AST whose Names have the - correct uniques - - 2. When we read an interface file, the read-in gubbins better have the right uniques + 2. When we read an interface file, the read-in gubbins better have + the right uniques This is accomplished through a combination of mechanisms: - 1. When parsing source code, the RdrName-decorated AST has some RdrNames which are Exact. These are - wired-in RdrNames where the we could directly tell from the parsed syntax what Name to use. For - example, when we parse a [] in a type we can just insert an Exact RdrName Name with the listTyConKey. - - Currently, I believe this is just an optimisation: it would be equally valid to just output Orig - RdrNames that correctly record the module etc we expect the final Name to come from. However, - were we to eliminate isTupleOcc_maybe it would become essential (see point 3). - - 2. The knownKeyNames (which consist of the basicKnownKeyNames from the module, and those names reachable - via the wired-in stuff from TysWiredIn) are used to initialise the "original name cache" in IfaceEnv. - This initialization ensures that when the type checker or renamer (both of which use IfaceEnv) look up - an original name (i.e. a pair of a Module and an OccName) for a known-key name they get the correct Unique. + 1. When parsing source code, the RdrName-decorated AST has some + RdrNames which are Exact. These are wired-in RdrNames where the + we could directly tell from the parsed syntax what Name to + use. For example, when we parse a [] in a type we can just insert + an Exact RdrName Name with the listTyConKey. + + Currently, I believe this is just an optimisation: it would be + equally valid to just output Orig RdrNames that correctly record + the module etc we expect the final Name to come from. However, + were we to eliminate isBuiltInOcc_maybe it would become essential + (see point 3). + + 2. The knownKeyNames (which consist of the basicKnownKeyNames from + the module, and those names reachable via the wired-in stuff from + TysWiredIn) are used to initialise the "OrigNameCache" in + IfaceEnv. This initialization ensures that when the type checker + or renamer (both of which use IfaceEnv) look up an original name + (i.e. a pair of a Module and an OccName) for a known-key name + they get the correct Unique. + + This is the most important mechanism for ensuring that known-key + stuff gets the right Unique, and is why it is so important to + place your known-key names in the appropriate lists. + + 3. For "infinite families" of known-key names (i.e. tuples), we have + to be extra careful. Because there are an infinite number of + these things, we cannot add them to the list of known-key names + used to initialise the OrigNameCache. Instead, we have to + rely on never having to look them up in that cache. - This is the most important mechanism for ensuring that known-key stuff gets the right Unique, and is why - it is so important to place your known-key names in the appropriate lists. + This is accomplished through a variety of mechanisms: - 3. For "infinite families" of known-key names (i.e. tuples, Any tycons and implicit parameter TyCons), we - have to be extra careful. Because there are an infinite number of these things, we cannot add them to - the list of known-key names used to initialise the original name cache. Instead, we have to rely on - never having to look them up in that cache. + a) The parser recognises them specially and generates an + Exact Name (hence not looked up in the orig-name cache) - This is accomplished through a variety of mechanisms: + b) The known infinite families of names are specially + serialised by BinIface.putName, with that special treatment + detected when we read back to ensure that we get back to the + correct uniques. - a) The known infinite families of names are specially serialised by BinIface.putName, with that special treatment - detected when we read back to ensure that we get back to the correct uniques. + Most of the infinite families cannot occur in source code, + so mechanisms (a,b) sufficies to ensure that they always have + the right Unique. In particular, implicit param TyCon names, + constraint tuples and Any TyCons cannot be mentioned by the + user. - b) Most of the infinite families cannot occur in source code, so mechanism a) sufficies to ensure that they - always have the right Unique. In particular, implicit param TyCon names, constraint tuples and Any TyCons - cannot be mentioned by the user. + c) IfaceEnv.lookupOrigNameCache uses isBuiltInOcc_maybe to map + built-in syntax directly onto the corresponding name, rather + than trying to find it in the original-name cache. - c) Tuple TyCon/DataCon names have a special hack (isTupleOcc_maybe) that is used by the original name cache - lookup routine to detect tuple names and give them the right Unique. You might think that this is unnecessary - because tuple TyCon/DataCons are parsed as Exact RdrNames and *don't* appear as original names in interface files - (because serialization gives them special treatment), so we will never look them up in the original name cache. + See also Note [Built-in syntax and the OrigNameCache] - However, there is a subtle reason why this is not the case: if you use setRdrNameSpace on an Exact RdrName - it may be turned into an Orig RdrName. So if the original name was an Exact tuple Name we might end up with - an Orig instead, which *will* lead to an original name cache query. \begin{code} +{-# LANGUAGE CPP #-} + module PrelNames ( Unique, Uniquable(..), hasKey, -- Re-exported for convenience @@ -113,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} %* * %************************************************************************ @@ -431,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") @@ -442,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} %************************************************************************ @@ -473,10 +503,10 @@ mkMainModule_ m = mkModule mainPackageId m %************************************************************************ \begin{code} -mkTupleModule :: TupleSort -> Arity -> Module -mkTupleModule BoxedTuple _ = gHC_TUPLE -mkTupleModule ConstraintTuple _ = gHC_TUPLE -mkTupleModule UnboxedTuple _ = gHC_PRIM +mkTupleModule :: TupleSort -> Module +mkTupleModule BoxedTuple = gHC_TUPLE +mkTupleModule ConstraintTuple = gHC_TUPLE +mkTupleModule UnboxedTuple = gHC_PRIM \end{code} @@ -802,20 +832,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 @@ -828,10 +858,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 @@ -849,7 +879,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 @@ -860,7 +890,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 @@ -888,10 +918,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, @@ -958,23 +988,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 @@ -990,7 +1020,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 @@ -1016,33 +1046,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, @@ -1050,24 +1080,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 @@ -1075,7 +1108,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 @@ -1089,12 +1122,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 @@ -1104,21 +1137,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 @@ -1129,9 +1162,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 @@ -1187,10 +1220,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} %************************************************************************ @@ -1299,7 +1328,7 @@ addrPrimTyConKey, arrayPrimTyConKey, arrayArrayPrimTyConKey, boolTyConKey, byteA floatPrimTyConKey, floatTyConKey, funTyConKey, intPrimTyConKey, intTyConKey, int8TyConKey, int16TyConKey, int32PrimTyConKey, int32TyConKey, int64PrimTyConKey, int64TyConKey, - integerTyConKey, digitsTyConKey, + integerTyConKey, listTyConKey, foreignObjPrimTyConKey, weakPrimTyConKey, mutableArrayPrimTyConKey, mutableArrayArrayPrimTyConKey, mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey, ratioTyConKey, rationalTyConKey, @@ -1326,7 +1355,7 @@ int32TyConKey = mkPreludeTyConUnique 19 int64PrimTyConKey = mkPreludeTyConUnique 20 int64TyConKey = mkPreludeTyConUnique 21 integerTyConKey = mkPreludeTyConUnique 22 -digitsTyConKey = mkPreludeTyConUnique 23 + listTyConKey = mkPreludeTyConUnique 24 foreignObjPrimTyConKey = mkPreludeTyConUnique 25 weakPrimTyConKey = mkPreludeTyConUnique 27 diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index 786780654e..d2e648f382 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -12,8 +12,8 @@ ToDo: (i1 + i2) only if it results in a valid Float. \begin{code} -{-# LANGUAGE RankNTypes #-} -{-# OPTIONS -optc-DNON_POSIX_SOURCE #-} +{-# LANGUAGE CPP, RankNTypes #-} +{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} module PrelRules ( primOpRules, builtinRules ) where diff --git a/compiler/prelude/PrimOp.lhs b/compiler/prelude/PrimOp.lhs index 12f71c2230..198078bc9f 100644 --- a/compiler/prelude/PrimOp.lhs +++ b/compiler/prelude/PrimOp.lhs @@ -4,6 +4,8 @@ \section[PrimOp]{Primitive operations (machine-level)} \begin{code} +{-# LANGUAGE CPP #-} + module PrimOp ( PrimOp(..), PrimOpVecCat(..), allThePrimOps, primOpType, primOpSig, @@ -38,7 +40,7 @@ import Unique ( Unique, mkPrimOpIdUnique ) import Outputable import FastTypes import FastString -import Module ( PackageId ) +import Module ( PackageKey ) \end{code} %************************************************************************ @@ -327,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 @@ -357,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' @@ -383,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. @@ -420,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 @@ -441,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 @@ -585,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/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index 789d121519..de151fd92f 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -6,7 +6,8 @@ \section[TysPrim]{Wired-in knowledge about primitive types} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -158,7 +159,15 @@ mkPrimTc fs unique tycon = mkWiredInName gHC_PRIM (mkTcOccFS fs) unique (ATyCon tycon) -- Relevant TyCon - UserSyntax -- None are built-in syntax + UserSyntax + +mkBuiltInPrimTc :: FastString -> Unique -> TyCon -> Name +mkBuiltInPrimTc fs unique tycon + = mkWiredInName gHC_PRIM (mkTcOccFS fs) + unique + (ATyCon tycon) -- Relevant TyCon + BuiltInSyntax + charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, voidPrimTyConName :: Name charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon @@ -175,7 +184,7 @@ statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey stat voidPrimTyConName = mkPrimTc (fsLit "Void#") voidPrimTyConKey voidPrimTyCon proxyPrimTyConName = mkPrimTc (fsLit "Proxy#") proxyPrimTyConKey proxyPrimTyCon eqPrimTyConName = mkPrimTc (fsLit "~#") eqPrimTyConKey eqPrimTyCon -eqReprPrimTyConName = mkPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon +eqReprPrimTyConName = mkBuiltInPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon @@ -700,7 +709,7 @@ threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName PtrRep Note [Any types] ~~~~~~~~~~~~~~~~ -The type constructor Any of kind forall k. k -> k has these properties: +The type constructor Any of kind forall k. k has these properties: * It is defined in module GHC.Prim, and exported so that it is available to users. For this reason it's treated like any other @@ -713,7 +722,7 @@ The type constructor Any of kind forall k. k -> k has these properties: g :: ty ~ (Fst ty, Snd ty) If Any was a *data* type, then we'd get inconsistency because 'ty' could be (Any '(k1,k2)) and then we'd have an equality with Any on - one side and '(,) on the other + one side and '(,) on the other. See also #9097. * It is lifted, and hence represented by a pointer @@ -770,20 +779,12 @@ anyTy :: Type anyTy = mkTyConTy anyTyCon anyTyCon :: TyCon -anyTyCon = mkLiftedPrimTyCon anyTyConName kind [Nominal] PtrRep - where kind = ForAllTy kKiVar (mkTyVarTy kKiVar) - -{- Can't do this yet without messing up kind proxies --- RAE: I think you can now. -anyTyCon :: TyCon -anyTyCon = mkSynTyCon anyTyConName kind [kKiVar] +anyTyCon = mkSynTyCon anyTyConName kind [kKiVar] [Nominal] syn_rhs NoParentTyCon where kind = ForAllTy kKiVar (mkTyVarTy kKiVar) - syn_rhs = SynFamilyTyCon { synf_open = False, synf_injective = True } - -- NB Closed, injective --} + syn_rhs = AbstractClosedSynFamilyTyCon anyTypeOfKind :: Kind -> Type anyTypeOfKind kind = TyConApp anyTyCon [kind] diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 5ca43a36ec..4586b90cb2 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -4,11 +4,13 @@ \section[TysWiredIn]{Wired-in knowledge about {\em non-primitive} types} \begin{code} +{-# LANGUAGE CPP #-} + -- | This module is about types that can be defined in Haskell, but which -- must be wired into the compiler nonetheless. C.f module TysPrim module TysWiredIn ( -- * All wired in things - wiredInTyCons, + wiredInTyCons, isBuiltInOcc_maybe, -- * Bool boolTy, boolTyCon, boolTyCon_RDR, boolTyConName, @@ -333,11 +335,11 @@ typeSymbolKind = TyConApp (promoteTyCon typeSymbolKindCon) [] %************************************************************************ %* * -\subsection[TysWiredIn-tuples]{The tuple types} + Stuff for dealing with tuples %* * %************************************************************************ -Note [How tuples work] +Note [How tuples work] See also Note [Known-key names] in PrelNames ~~~~~~~~~~~~~~~~~~~~~~ * There are three families of tuple TyCons and corresponding DataCons, (boxed, unboxed, and constraint tuples), expressed by the @@ -356,6 +358,68 @@ Note [How tuples work] are not serialised into interface files using OccNames at all. \begin{code} +isBuiltInOcc_maybe :: OccName -> Maybe Name +-- Built in syntax isn't "in scope" so these OccNames +-- map to wired-in Names with BuiltInSyntax +isBuiltInOcc_maybe occ + = case occNameString occ of + "[]" -> choose_ns listTyCon nilDataCon + ":" -> Just consDataConName + "[::]" -> Just parrTyConName + "(##)" -> choose_ns unboxedUnitTyCon unboxedUnitDataCon + "()" -> choose_ns unitTyCon unitDataCon + '(':'#':',':rest -> parse_tuple UnboxedTuple 2 rest + '(':',':rest -> parse_tuple BoxedTuple 2 rest + _other -> Nothing + where + ns = occNameSpace occ + + parse_tuple sort n rest + | (',' : rest2) <- rest = parse_tuple sort (n+1) rest2 + | tail_matches sort rest = choose_ns (tupleTyCon sort n) + (tupleCon sort n) + | otherwise = Nothing + + tail_matches BoxedTuple ")" = True + tail_matches UnboxedTuple "#)" = True + tail_matches _ _ = False + + choose_ns tc dc + | isTcClsNameSpace ns = Just (getName tc) + | isDataConNameSpace ns = Just (getName dc) + | otherwise = Just (getName (dataConWorkId dc)) + +mkTupleOcc :: NameSpace -> TupleSort -> Arity -> OccName +mkTupleOcc ns sort ar = mkOccName ns str + where + -- No need to cache these, the caching is done in mk_tuple + str = case sort of + UnboxedTuple -> '(' : '#' : commas ++ "#)" + BoxedTuple -> '(' : commas ++ ")" + ConstraintTuple -> '(' : commas ++ ")" + + commas = take (ar-1) (repeat ',') + + -- Cute hack: we reuse the standard tuple OccNames (and hence code) + -- for fact tuples, but give them different Uniques so they are not equal. + -- + -- You might think that this will go wrong because isBuiltInOcc_maybe won't + -- be able to tell the difference between boxed tuples and constraint tuples. BUT: + -- 1. Constraint tuples never occur directly in user code, so it doesn't matter + -- that we can't detect them in Orig OccNames originating from the user + -- programs (or those built by setRdrNameSpace used on an Exact tuple Name) + -- 2. Interface files have a special representation for tuple *occurrences* + -- in IfaceTyCons, their workers (in IfaceSyn) and their DataCons (in case + -- alternatives). Thus we don't rely on the OccName to figure out what kind + -- of tuple an occurrence was trying to use in these situations. + -- 3. We *don't* represent tuple data type declarations specially, so those + -- are still turned into wired-in names via isBuiltInOcc_maybe. But that's OK + -- because we don't actually need to declare constraint tuples thanks to this hack. + -- + -- So basically any OccName like (,,) flowing to isBuiltInOcc_maybe will always + -- refer to the standard boxed tuple. Cool :-) + + tupleTyCon :: TupleSort -> Arity -> TyCon tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i) -- Build one specially tupleTyCon BoxedTuple i = fst (boxedTupleArr ! i) @@ -388,7 +452,7 @@ mk_tuple sort arity = (tycon, tuple_con) UnboxedTuple -> Nothing ConstraintTuple -> Nothing - modu = mkTupleModule sort arity + modu = mkTupleModule sort tc_name = mkWiredInName modu (mkTupleOcc tcName sort arity) tc_uniq (ATyCon tycon) BuiltInSyntax tc_kind = mkArrowKinds (map tyVarKind tyvars) res_kind diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 10dd19d4bb..d5566fe363 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -247,13 +247,19 @@ primop NotIOp "notI#" Monadic Int# -> Int# primop IntNegOp "negateInt#" Monadic Int# -> Int# primop IntAddCOp "addIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) - {Add with carry. First member of result is (wrapped) sum; - second member is 0 iff no overflow occured.} + {Add signed integers reporting overflow. + First member of result is the sum truncated to an {\tt Int#}; + second member is zero if the true sum fits in an {\tt Int#}, + nonzero if overflow occurred (the sum is either too large + or too small to fit in an {\tt Int#}).} with code_size = 2 primop IntSubCOp "subIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) - {Subtract with carry. First member of result is (wrapped) difference; - second member is 0 iff no overflow occured.} + {Subtract signed integers reporting overflow. + First member of result is the difference truncated to an {\tt Int#}; + second member is zero if the true difference fits in an {\tt Int#}, + nonzero if overflow occurred (the difference is either too large + or too small to fit in an {\tt Int#}).} with code_size = 2 primop IntGtOp ">#" Compare Int# -> Int# -> Int# @@ -380,6 +386,28 @@ primop PopCnt64Op "popCnt64#" GenPrimOp WORD64 -> Word# primop PopCntOp "popCnt#" Monadic Word# -> Word# {Count the number of set bits in a word.} +primop Clz8Op "clz8#" Monadic Word# -> Word# + {Count leading zeros in the lower 8 bits of a word.} +primop Clz16Op "clz16#" Monadic Word# -> Word# + {Count leading zeros in the lower 16 bits of a word.} +primop Clz32Op "clz32#" Monadic Word# -> Word# + {Count leading zeros in the lower 32 bits of a word.} +primop Clz64Op "clz64#" GenPrimOp WORD64 -> Word# + {Count leading zeros in a 64-bit word.} +primop ClzOp "clz#" Monadic Word# -> Word# + {Count leading zeros in a word.} + +primop Ctz8Op "ctz8#" Monadic Word# -> Word# + {Count trailing zeros in the lower 8 bits of a word.} +primop Ctz16Op "ctz16#" Monadic Word# -> Word# + {Count trailing zeros in the lower 16 bits of a word.} +primop Ctz32Op "ctz32#" Monadic Word# -> Word# + {Count trailing zeros in the lower 32 bits of a word.} +primop Ctz64Op "ctz64#" GenPrimOp WORD64 -> Word# + {Count trailing zeros in a 64-bit word.} +primop CtzOp "ctz#" Monadic Word# -> Word# + {Count trailing zeros in a word.} + primop BSwap16Op "byteSwap16#" Monadic Word# -> Word# {Swap bytes in the lower 16 bits of a word. The higher bytes are undefined. } primop BSwap32Op "byteSwap32#" Monadic Word# -> Word# @@ -843,8 +871,22 @@ primop CasArrayOp "casArray#" GenPrimOp section "Small Arrays" {Operations on {\tt SmallArray\#}. A {\tt SmallArray\#} works - just like an {\tt Array\#}, except that its implementation is - optimized for small arrays (i.e. no more than 128 elements.)} + just like an {\tt Array\#}, but with different space use and + performance characteristics (that are often useful with small + arrays). The {\tt SmallArray\#} and {\tt SmallMutableArray#} + lack a `card table'. The purpose of a card table is to avoid + having to scan every element of the array on each GC by + keeping track of which elements have changed since the last GC + and only scanning those that have changed. So the consequence + of there being no card table is that the representation is + somewhat smaller and the writes are somewhat faster (because + the card table does not need to be updated). The disadvantage + of course is that for a {\tt SmallMutableArray#} the whole + array has to be scanned on each GC. Thus it is best suited for + use cases where the mutable array is not long lived, e.g. + where a mutable array is initialised quickly and then frozen + to become an immutable {\tt SmallArray\#}. + } ------------------------------------------------------------------------ @@ -1032,6 +1074,30 @@ primop ByteArrayContents_Char "byteArrayContents#" GenPrimOp primop SameMutableByteArrayOp "sameMutableByteArray#" GenPrimOp MutableByteArray# s -> MutableByteArray# s -> Int# +primop ShrinkMutableByteArrayOp_Char "shrinkMutableByteArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> State# s + {Shrink mutable byte array to new specified size (in bytes), in + the specified state thread. The new size argument must be less than or + equal to the current size as reported by {\tt sizeofMutableArray\#}.} + with out_of_line = True + has_side_effects = True + +primop ResizeMutableByteArrayOp_Char "resizeMutableByteArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s,MutableByteArray# s #) + {Resize (unpinned) mutable byte array to new specified size (in bytes). + The returned {\tt MutableByteArray\#} is either the original + {\tt MutableByteArray\#} resized in-place or, if not possible, a newly + allocated (unpinned) {\tt MutableByteArray\#} (with the original content + copied over). + + To avoid undefined behaviour, the original {\tt MutableByteArray\#} shall + not be accessed anymore after a {\tt resizeMutableByteArray\#} has been + performed. Moreover, no reference to the old one should be kept in order + to allow garbage collection of the original {\tt MutableByteArray\#} in + case a new {\tt MutableByteArray\#} had to be allocated.} + with out_of_line = True + has_side_effects = True + primop UnsafeFreezeByteArrayOp "unsafeFreezeByteArray#" GenPrimOp MutableByteArray# s -> State# s -> (# State# s, ByteArray# #) {Make a mutable byte array immutable, without copying.} @@ -1082,34 +1148,42 @@ primop IndexByteArrayOp_StablePtr "indexStablePtrArray#" GenPrimOp primop IndexByteArrayOp_Int8 "indexInt8Array#" GenPrimOp ByteArray# -> Int# -> Int# + {Read 8-bit integer; offset in bytes.} with can_fail = True primop IndexByteArrayOp_Int16 "indexInt16Array#" GenPrimOp ByteArray# -> Int# -> Int# + {Read 16-bit integer; offset in 16-bit words.} with can_fail = True primop IndexByteArrayOp_Int32 "indexInt32Array#" GenPrimOp ByteArray# -> Int# -> INT32 + {Read 32-bit integer; offset in 32-bit words.} with can_fail = True primop IndexByteArrayOp_Int64 "indexInt64Array#" GenPrimOp ByteArray# -> Int# -> INT64 + {Read 64-bit integer; offset in 64-bit words.} with can_fail = True primop IndexByteArrayOp_Word8 "indexWord8Array#" GenPrimOp ByteArray# -> Int# -> Word# + {Read 8-bit word; offset in bytes.} with can_fail = True primop IndexByteArrayOp_Word16 "indexWord16Array#" GenPrimOp ByteArray# -> Int# -> Word# + {Read 16-bit word; offset in 16-bit words.} with can_fail = True primop IndexByteArrayOp_Word32 "indexWord32Array#" GenPrimOp ByteArray# -> Int# -> WORD32 + {Read 32-bit word; offset in 32-bit words.} with can_fail = True primop IndexByteArrayOp_Word64 "indexWord64Array#" GenPrimOp ByteArray# -> Int# -> WORD64 + {Read 64-bit word; offset in 64-bit words.} with can_fail = True primop ReadByteArrayOp_Char "readCharArray#" GenPrimOp @@ -1126,11 +1200,13 @@ primop ReadByteArrayOp_WideChar "readWideCharArray#" GenPrimOp primop ReadByteArrayOp_Int "readIntArray#" GenPrimOp MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #) + {Read intger; offset in words.} with has_side_effects = True can_fail = True primop ReadByteArrayOp_Word "readWordArray#" GenPrimOp MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #) + {Read word; offset in words.} with has_side_effects = True can_fail = True @@ -1339,19 +1415,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 ------------------------------------------------------------------------ @@ -1797,6 +1933,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 @@ -2413,7 +2554,7 @@ pseudoop "seq" { Evaluates its first argument to head normal form, and then returns its second argument as the result. } -primtype Any k +primtype Any { The type constructor {\tt Any} is type to which you can unsafely coerce any lifted type, and back. @@ -2438,8 +2579,11 @@ primtype Any k {\tt length (Any *) ([] (Any *))} - Note that {\tt Any} is kind polymorphic, and takes a kind {\tt k} as its - first argument. The kind of {\tt Any} is thus {\tt forall k. k -> k}.} + Above, we print kinds explicitly, as if with + {\tt -fprint-explicit-kinds}. + + Note that {\tt Any} is kind polymorphic; its kind is thus + {\tt forall k. k}.} primtype AnyK { The kind {\tt AnyK} is the kind level counterpart to {\tt Any}. In a diff --git a/compiler/profiling/CostCentre.lhs b/compiler/profiling/CostCentre.lhs index fffd6462b2..8a6ed044fb 100644 --- a/compiler/profiling/CostCentre.lhs +++ b/compiler/profiling/CostCentre.lhs @@ -1,32 +1,24 @@ \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://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/profiling/SCCfinal.lhs b/compiler/profiling/SCCfinal.lhs index fdcf7447eb..4a6da2417e 100644 --- a/compiler/profiling/SCCfinal.lhs +++ b/compiler/profiling/SCCfinal.lhs @@ -2,6 +2,8 @@ % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \begin{code} +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- Modify and collect code generation for final STG program diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index ba94a390f4..0f9f44aed6 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -9,7 +9,7 @@ type-synonym declarations; those cannot be done at this stage because they may be affected by renaming (which isn't fully worked out yet). \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -47,7 +47,7 @@ import NameSet import RdrName ( RdrName, rdrNameOcc ) import SrcLoc import ListSetOps ( findDupsEq ) -import BasicTypes ( RecFlag(..), Origin ) +import BasicTypes ( RecFlag(..) ) import Digraph ( SCC(..) ) import Bag import Outputable @@ -275,7 +275,7 @@ rnValBindsLHS :: NameMaker -> HsValBinds RdrName -> RnM (HsValBindsLR Name RdrName) rnValBindsLHS topP (ValBindsIn mbinds sigs) - = do { mbinds' <- mapBagM (wrapOriginLocM (rnBindLHS topP doc)) mbinds + = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds ; return $ ValBindsIn mbinds' sigs } where bndrs = collectHsBindsBinders mbinds @@ -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 @@ -448,12 +448,12 @@ rnBindLHS name_maker _ bind@(PatSynBind{ patsyn_id = rdrname@(L nameLoc _) }) rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b) rnLBind :: (Name -> [Name]) -- Signature tyvar function - -> (Origin, LHsBindLR Name RdrName) - -> RnM ((Origin, LHsBind Name), [Name], Uses) -rnLBind sig_fn (origin, (L loc bind)) + -> LHsBindLR Name RdrName + -> RnM (LHsBind Name, [Name], Uses) +rnLBind sig_fn (L loc bind) = setSrcSpan loc $ do { (bind', bndrs, dus) <- rnBind sig_fn bind - ; return ((origin, L loc bind'), bndrs, dus) } + ; return (L loc bind', bndrs, dus) } -- assumes the left-hands-side vars are in scope rnBind :: (Name -> [Name]) -- Signature tyvar function @@ -476,8 +476,9 @@ rnBind _ bind@(PatBind { pat_lhs = pat bndrs = collectPatBinders pat bind' = bind { pat_rhs = grhss', bind_fvs = fvs' } is_wild_pat = case pat of - L _ (WildPat {}) -> True - _ -> False + L _ (WildPat {}) -> True + L _ (BangPat (L _ (WildPat {}))) -> True -- #9127 + _ -> False -- Warn if the pattern binds no variables, except for the -- entirely-explicit idiom _ = rhs @@ -514,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 @@ -538,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 @@ -564,24 +592,38 @@ 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. -} --------------------- -depAnalBinds :: Bag ((Origin, LHsBind Name), [Name], Uses) +depAnalBinds :: Bag (LHsBind Name, [Name], Uses) -> ([(RecFlag, LHsBinds Name)], DefUses) -- Dependency analysis; this is important so that -- unused-binding reporting is accurate @@ -666,10 +708,9 @@ rnMethodBinds cls sig_fn binds ; foldlM do_one (emptyBag, emptyFVs) (bagToList binds) } where meth_names = collectMethodBinders binds - do_one (binds,fvs) (origin,bind) + do_one (binds,fvs) bind = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn bind - ; let bind'' = mapBag (\bind -> (origin,bind)) bind' - ; return (binds `unionBags` bind'', fvs_bind `plusFV` fvs) } + ; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) } rnMethodBind :: Name -> (Name -> [Name]) @@ -677,7 +718,7 @@ rnMethodBind :: Name -> RnM (Bag (LHsBindLR Name Name), FreeVars) rnMethodBind cls sig_fn (L loc bind@(FunBind { fun_id = name, fun_infix = is_infix - , fun_matches = MG { mg_alts = matches } })) + , fun_matches = MG { mg_alts = matches, mg_origin = origin } })) = setSrcSpan loc $ do sel_name <- wrapLocM (lookupInstDeclBndr cls (ptext (sLit "method"))) name let plain_name = unLoc sel_name @@ -685,7 +726,7 @@ rnMethodBind cls sig_fn (new_matches, fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ mapFvRn (rnMatch (FunRhs plain_name is_infix) rnLExpr) matches - let new_group = mkMatchGroup new_matches + let new_group = mkMatchGroup origin new_matches when is_infix $ checkPrecMatch plain_name new_group return (unitBag (L loc (bind { fun_id = sel_name @@ -889,11 +930,11 @@ rnMatchGroup :: Outputable (body RdrName) => HsMatchContext Name -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) -> MatchGroup RdrName (Located (body RdrName)) -> RnM (MatchGroup Name (Located (body Name)), FreeVars) -rnMatchGroup ctxt rnBody (MG { mg_alts = ms }) +rnMatchGroup ctxt rnBody (MG { mg_alts = ms, mg_origin = origin }) = do { empty_case_ok <- xoptM Opt_EmptyCase ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt)) ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms - ; return (mkMatchGroup new_ms, ms_fvs) } + ; return (mkMatchGroup origin new_ms, ms_fvs) } rnMatch :: Outputable (body RdrName) => HsMatchContext Name -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 49cbbad13d..f333a239a1 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -4,6 +4,8 @@ \section[RnEnv]{Environment manipulation for the renamer monad} \begin{code} +{-# LANGUAGE CPP #-} + module RnEnv ( newTopSrcBinder, lookupLocatedTopBndrRn, lookupTopBndrRn, @@ -38,10 +40,7 @@ module RnEnv ( warnUnusedMatches, warnUnusedTopBinds, warnUnusedLocalBinds, dataTcOccs, kindSigErr, perhapsForallMsg, - HsDocContext(..), docOfHsDocContext, - - -- FsEnv - FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv + HsDocContext(..), docOfHsDocContext ) where #include "HsVersions.h" @@ -59,7 +58,6 @@ import NameSet import NameEnv import Avail import Module -import UniqFM import ConLike import DataCon ( dataConFieldLabels, dataConTyCon ) import TyCon ( isTupleTyCon, tyConArity ) @@ -270,14 +268,29 @@ lookupExactOcc name ; return name } - [gre] -> return (gre_name gre) - _ -> pprPanic "lookupExactOcc" (ppr name $$ ppr gres) } + [gre] -> return (gre_name gre) + (gre:_) -> do {addErr dup_nm_err + ; return (gre_name gre) + } + -- We can get more than one GRE here, if there are multiple + -- bindings for the same name. Sometimes they are caught later + -- by findLocalDupsRdrEnv, like in this example (Trac #8932): + -- $( [d| foo :: a->a; foo x = x |]) + -- foo = True + -- But when the names are totally identical, we panic (Trac #7241): + -- $(newName "Foo" >>= \o -> return [DataD [] o [] [RecC o []] [''Show]]) + -- So, let's emit an error here, even if it will lead to duplication in some cases. + } where exact_nm_err = hang (ptext (sLit "The exact Name") <+> quotes (ppr name) <+> ptext (sLit "is not in scope")) 2 (vcat [ ptext (sLit "Probable cause: you used a unique Template Haskell name (NameU), ") , ptext (sLit "perhaps via newName, but did not bind it") , ptext (sLit "If that's it, then -ddump-splices might be useful") ]) + dup_nm_err = hang (ptext (sLit "Duplicate exact Name") <+> quotes (ppr $ nameOccName name)) + 2 (vcat [ ptext (sLit "Probable cause: you used a unique Template Haskell name (NameU), ") + , ptext (sLit "perhaps via newName, but bound it multiple times") + , ptext (sLit "If that's it, then -ddump-splices might be useful") ]) ----------------------------------------------- lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name @@ -1072,20 +1085,6 @@ deprecation declarations, and lookup of names in GHCi. \begin{code} -------------------------------- -type FastStringEnv a = UniqFM a -- Keyed by FastString - - -emptyFsEnv :: FastStringEnv a -lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a -extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a -mkFsEnv :: [(FastString,a)] -> FastStringEnv a - -emptyFsEnv = emptyUFM -lookupFsEnv = lookupUFM -extendFsEnv = addToUFM -mkFsEnv = listToUFM - --------------------------------- type MiniFixityEnv = FastStringEnv (Located Fixity) -- Mini fixity env for the names we're about -- to bind, in a single binding group @@ -1453,7 +1452,7 @@ unknownNameSuggestErr where_look tried_rdr_name all_possibilities = [ (showPpr dflags r, (r, Left loc)) | (r,loc) <- local_possibilities local_env ] - ++ [ (showPpr dflags r, rp) | (r,rp) <- global_possibilities global_env ] + ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ] suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities perhaps = ptext (sLit "Perhaps you meant") @@ -1465,19 +1464,24 @@ unknownNameSuggestErr where_look tried_rdr_name ; return extra_err } where pp_item :: (RdrName, HowInScope) -> SDoc - pp_item (rdr, Left loc) = quotes (ppr rdr) <+> loc' -- Locally defined + pp_item (rdr, Left loc) = pp_ns rdr <+> quotes (ppr rdr) <+> loc' -- Locally defined where loc' = case loc of UnhelpfulSpan l -> parens (ppr l) RealSrcSpan l -> parens (ptext (sLit "line") <+> int (srcSpanStartLine l)) - pp_item (rdr, Right is) = quotes (ppr rdr) <+> -- Imported + pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+> -- Imported parens (ptext (sLit "imported from") <+> ppr (is_mod is)) + pp_ns :: RdrName -> SDoc + pp_ns rdr | ns /= tried_ns = pprNameSpace ns + | otherwise = empty + where ns = rdrNameSpace rdr + tried_occ = rdrNameOcc tried_rdr_name tried_is_sym = isSymOcc tried_occ tried_ns = occNameSpace tried_occ tried_is_qual = isQual tried_rdr_name - correct_name_space occ = occNameSpace occ == tried_ns + correct_name_space occ = nameSpacesRelated (occNameSpace occ) tried_ns && isSymOcc occ == tried_is_sym -- Treat operator and non-operators as non-matching -- This heuristic avoids things like diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 01e8a4492d..697303f276 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -10,6 +10,8 @@ general, all of these functions return a renamed thing, and a set of free variables. \begin{code} +{-# LANGUAGE CPP, ScopedTypeVariables #-} + module RnExpr ( rnLExpr, rnExpr, rnStmts ) where @@ -38,6 +40,7 @@ import UniqSet import Data.List import Util import ListSetOps ( removeDups ) +import ErrUtils import Outputable import SrcLoc import FastString @@ -45,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} @@ -66,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. @@ -120,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 @@ -163,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 @@ -178,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 @@ -205,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)) @@ -248,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 @@ -290,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 @@ -304,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. @@ -332,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 @@ -402,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' @@ -425,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 @@ -441,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 @@ -486,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)) @@ -578,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} %************************************************************************ @@ -959,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) @@ -1003,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 @@ -1245,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 ] @@ -1261,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 @@ -1285,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 56ee969aed..5071828e4d 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -4,6 +4,8 @@ \section[RnNames]{Extracting imported and top-level names in scope} \begin{code} +{-# LANGUAGE CPP, NondecreasingIndentation #-} + module RnNames ( rnImports, getLocalNonValBinders, rnExports, extendGlobalRdrEnvRn, @@ -257,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] @@ -572,6 +574,29 @@ the environment, and then process the type instances. @filterImports@ takes the @ExportEnv@ telling what the imported module makes available, and filters it through the import spec (if any). +Note [Dealing with imports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For import M( ies ), we take the mi_exports of M, and make + imp_occ_env :: OccEnv (Name, AvailInfo, Maybe Name) +One entry for each Name that M exports; the AvailInfo describes just +that Name. + +The situation is made more complicated by associated types. E.g. + module M where + class C a where { data T a } + instance C Int where { data T Int = T1 | T2 } + instance C Bool where { data T Int = T3 } +Then M's export_avails are (recall the AvailTC invariant from Avails.hs) + C(C,T), T(T,T1,T2,T3) +Notice that T appears *twice*, once as a child and once as a parent. +From this we construct the imp_occ_env + C -> (C, C(C,T), Nothing + T -> (T, T(T,T1,T2,T3), Just C) + T1 -> (T1, T(T1,T2,T3), Nothing) -- similarly T2,T3 + +Note that the imp_occ_env will have entries for data constructors too, +although we never look up data constructors. + \begin{code} filterImports :: ModIface -> ImpDeclSpec -- The span for the entire import decl @@ -605,34 +630,22 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) where all_avails = mi_exports iface - -- This environment is how we map names mentioned in the import - -- list to the actual Name they correspond to, and the name family - -- that the Name belongs to (the AvailInfo). The situation is - -- complicated by associated families, which introduce a three-level - -- hierachy, where class = grand parent, assoc family = parent, and - -- data constructors = children. The occ_env entries for associated - -- families needs to capture all this information; hence, we have the - -- third component of the environment that gives the class name (= - -- grand parent) in case of associated families. - -- - -- This env will have entries for data constructors too, - -- they won't make any difference because naked entities like T - -- in an import list map to TcOccs, not VarOccs. - occ_env :: OccEnv (Name, -- the name - AvailInfo, -- the export item providing the name - Maybe Name) -- the parent of associated types - occ_env = mkOccEnv_C combine [ (nameOccName n, (n, a, Nothing)) - | a <- all_avails, n <- availNames a] + -- See Note [Dealing with imports] + imp_occ_env :: OccEnv (Name, -- the name + AvailInfo, -- the export item providing the name + Maybe Name) -- the parent of associated types + imp_occ_env = mkOccEnv_C combine [ (nameOccName n, (n, a, Nothing)) + | a <- all_avails, n <- availNames a] where - -- we know that (1) there are at most 2 entries for one name, (2) their - -- first component is identical, (3) they are for tys/cls, and (4) one - -- entry has the name in its parent position (the other doesn't) - combine (name, AvailTC p1 subs1, Nothing) - (_ , AvailTC p2 subs2, Nothing) - = let - (parent, subs) = if p1 == name then (p2, subs1) else (p1, subs2) - in - (name, AvailTC name subs, Just parent) + -- See example in Note [Dealing with imports] + -- 'combine' is only called for associated types which appear twice + -- in the all_avails. In the example, we combine + -- T(T,T1,T2,T3) and C(C,T) to give (T, T(T,T1,T2,T3), Just C) + combine (name1, a1@(AvailTC p1 _), mp1) + (name2, a2@(AvailTC p2 _), mp2) + = ASSERT( name1 == name2 && isNothing mp1 && isNothing mp2 ) + if p1 == name1 then (name1, a1, Just p2) + else (name1, a2, Just p1) combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y) lookup_name :: RdrName -> IELookupM (Name, AvailInfo, Maybe Name) @@ -640,7 +653,7 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) | Just succ <- mb_success = return succ | otherwise = failLookupWith BadImport where - mb_success = lookupOccEnv occ_env (rdrNameOcc rdr) + mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr) lookup_lie :: LIE RdrName -> TcRn [(LIE Name, AvailInfo)] lookup_lie (L loc ieRdr) @@ -677,7 +690,7 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) -- type/class and a data constructor. Moreover, when we import -- data constructors of an associated family, we need separate -- AvailInfos for the data constructors and the family (as they have - -- different parents). See the discussion at occ_env. + -- different parents). See Note [Dealing with imports] lookup_ie :: IE RdrName -> IELookupM ([(IE Name, AvailInfo)], [IELookupWarning]) lookup_ie ie = handle_bad_import $ do case ie of @@ -713,11 +726,16 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) -> do nameAvail <- lookup_name tc return ([mkIEThingAbs nameAvail], []) - IEThingWith tc ns -> do - (name, AvailTC _ subnames, mb_parent) <- lookup_name tc + IEThingWith rdr_tc rdr_ns -> do + (name, AvailTC _ ns, mb_parent) <- lookup_name rdr_tc -- Look up the children in the sub-names of the parent - let mb_children = lookupChildren subnames ns + let subnames = case ns of -- The tc is first in ns, + [] -> [] -- if it is there at all + -- See the AvailTC Invariant in Avail.hs + (n1:ns1) | n1 == name -> ns1 + | otherwise -> ns + mb_children = lookupChildren subnames rdr_ns children <- if any isNothing mb_children then failLookupWith BadImport @@ -1285,11 +1303,14 @@ type ImportDeclUsage warnUnusedImportDecls :: TcGblEnv -> RnM () warnUnusedImportDecls gbl_env = do { uses <- readMutVar (tcg_used_rdrnames gbl_env) - ; let imports = filter explicit_import (tcg_rn_imports gbl_env) + ; let user_imports = filterOut (ideclImplicit . unLoc) (tcg_rn_imports gbl_env) + -- This whole function deals only with *user* imports + -- both for warning about unnecessary ones, and for + -- deciding the minimal ones rdr_env = tcg_rdr_env gbl_env ; let usage :: [ImportDeclUsage] - usage = findImportUsage imports rdr_env (Set.elems uses) + usage = findImportUsage user_imports rdr_env (Set.elems uses) ; traceRn (vcat [ ptext (sLit "Uses:") <+> ppr (Set.elems uses) , ptext (sLit "Import usage") <+> ppr usage]) @@ -1298,10 +1319,6 @@ warnUnusedImportDecls gbl_env ; whenGOptM Opt_D_dump_minimal_imports $ printMinimalImports usage } - where - explicit_import (L _ decl) = not (ideclImplicit decl) - -- Filter out the implicit Prelude import - -- which we do not want to bleat about \end{code} @@ -1417,6 +1434,11 @@ warnUnusedImport :: ImportDeclUsage -> RnM () warnUnusedImport (L loc decl, used, unused) | Just (False,[]) <- ideclHiding decl = return () -- Do not warn for 'import M()' + + | Just (True, hides) <- ideclHiding decl + , not (null hides) + , pRELUDE_NAME == unLoc (ideclName decl) + = return () -- Note [Do not warn about Prelude hiding] | null used = addWarnAt loc msg1 -- Nothing used; drop entire decl | null unused = return () -- Everything imported is used; nop | otherwise = addWarnAt loc msg2 -- Some imports are unused @@ -1436,6 +1458,19 @@ warnUnusedImport (L loc decl, used, unused) pp_not_used = text "is redundant" \end{code} +Note [Do not warn about Prelude hiding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not warn about + import Prelude hiding( x, y ) +because even if nothing else from Prelude is used, it may be essential to hide +x,y to avoid name-shadowing warnings. Example (Trac #9061) + import Prelude hiding( log ) + f x = log where log = () + + + +Note [Printing minimal imports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ To print the minimal imports we walk over the user-supplied import decls, and simply trim their import lists. NB that @@ -1446,6 +1481,7 @@ decls, and simply trim their import lists. NB that \begin{code} printMinimalImports :: [ImportDeclUsage] -> RnM () +-- See Note [Printing minimal imports] printMinimalImports imports_w_usage = do { imports' <- mapM mk_minimal imports_w_usage ; this_mod <- getModule diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 3c48f34032..48fffce374 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -10,13 +10,8 @@ general, all of these functions return a renamed thing, and a set of free variables. \begin{code} --- 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 CPP, RankNTypes, ScopedTypeVariables #-} -{-# LANGUAGE ScopedTypeVariables #-} module RnPat (-- main entry points rnPat, rnPats, rnBindPat, rnPatAndThen, @@ -439,7 +434,7 @@ rnPatAndThen mk (PArrPat pats _) rnPatAndThen mk (TuplePat pats boxed _) = do { liftCps $ checkTupSize (length pats) ; pats' <- rnLPatsAndThen mk pats - ; return (TuplePat pats' boxed placeHolderType) } + ; return (TuplePat pats' boxed []) } rnPatAndThen _ (SplicePat splice) = do { -- XXX How to deal with free variables? diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index c726d554fc..a3bd38a3ec 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -4,6 +4,8 @@ \section[RnSource]{Main pass of renamer} \begin{code} +{-# LANGUAGE CPP, ScopedTypeVariables #-} + module RnSource ( rnSrcDecls, addTcgDUs, rnTyClDecls, findSplice ) where @@ -35,7 +37,7 @@ import NameEnv import Avail import Outputable import Bag -import BasicTypes ( RuleName, Origin(..) ) +import BasicTypes ( RuleName ) import FastString import SrcLoc import DynFlags @@ -382,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) } @@ -400,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 @@ -443,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,_) -> @@ -461,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') @@ -491,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 @@ -559,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 @@ -585,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) @@ -635,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 @@ -863,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. @@ -936,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 @@ -961,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 @@ -1006,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', @@ -1404,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} @@ -1518,7 +1537,7 @@ add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest) = tycls { group_roles = d : roles } : rest add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a -add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` (FromSource, b)) sigs +add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind" add_sig :: LSig a -> HsValBinds a -> HsValBinds a diff --git a/compiler/rename/RnSplice.lhs b/compiler/rename/RnSplice.lhs index e0614d4248..3c0c145e6b 100644 --- a/compiler/rename/RnSplice.lhs +++ b/compiler/rename/RnSplice.lhs @@ -1,4 +1,6 @@ \begin{code} +{-# LANGUAGE CPP #-} + module RnSplice ( rnTopSpliceDecls, rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl, diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 23c54c3bed..2f9bfdd653 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -4,6 +4,8 @@ \section[RnSource]{Main pass of renamer} \begin{code} +{-# LANGUAGE CPP #-} + module RnTypes ( -- Type related stuff rnHsType, rnLHsType, rnLHsTypes, rnContext, @@ -360,8 +362,9 @@ bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside kvs_from_tv_bndrs = [ kv | L _ (KindedTyVar _ kind) <- tvs , let (_, kvs) = extractHsTyRdrTyVars kind , kv <- kvs ] - all_kvs = filterOut (`elemLocalRdrEnv` rdr_env) $ - nub (kv_bndrs ++ kvs_from_tv_bndrs) + all_kvs' = nub (kv_bndrs ++ kvs_from_tv_bndrs) + all_kvs = filterOut (`elemLocalRdrEnv` rdr_env) all_kvs' + overlap_kvs = [ kv | kv <- all_kvs, any ((==) kv . hsLTyVarName) tvs ] -- These variables appear both as kind and type variables -- in the same declaration; eg type family T (x :: *) (y :: x) @@ -395,8 +398,12 @@ bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside ; (tv_bndrs', fvs1) <- mapFvRn rn_tv_bndr tvs ; (res, fvs2) <- bindLocalNamesFV (map hsLTyVarName tv_bndrs') $ - do { env <- getLocalRdrEnv - ; traceRn (text "bhtv" <+> (ppr tvs $$ ppr all_kvs $$ ppr env)) + do { inner_rdr_env <- getLocalRdrEnv + ; traceRn (text "bhtv" <+> vcat + [ ppr tvs, ppr kv_bndrs, ppr kvs_from_tv_bndrs + , ppr $ map (`elemLocalRdrEnv` rdr_env) all_kvs' + , ppr $ map (getUnique . rdrNameOcc) all_kvs' + , ppr all_kvs, ppr rdr_env, ppr inner_rdr_env ]) ; thing_inside (HsQTvs { hsq_tvs = tv_bndrs', hsq_kvs = kv_names }) } ; return (res, fvs1 `plusFV` fvs2) } } diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs index 691f883d02..90715737c2 100644 --- a/compiler/simplCore/CSE.lhs +++ b/compiler/simplCore/CSE.lhs @@ -4,6 +4,8 @@ \section{Common subexpression} \begin{code} +{-# LANGUAGE CPP #-} + module CSE (cseProgram) where #include "HsVersions.h" diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index 2eac83b384..6a2610e7f1 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -4,15 +4,14 @@ \section[CoreMonad]{The core pipeline monad} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# LANGUAGE CPP, UndecidableInstances #-} +{-# 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 UndecidableInstances #-} - module CoreMonad ( -- * Configuration of the core-to-core passes CoreToDo(..), runWhen, runMaybe, diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs index 8a35749c67..f00768a9f5 100644 --- a/compiler/simplCore/FloatIn.lhs +++ b/compiler/simplCore/FloatIn.lhs @@ -12,7 +12,8 @@ case, so that we don't allocate things, save them on the stack, and then discover that they aren't needed in the chosen branch. \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -25,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 @@ -154,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. @@ -274,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 @@ -287,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 @@ -321,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 @@ -363,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 @@ -402,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 @@ -417,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 ae6bb776c1..0649b62d0f 100644 --- a/compiler/simplCore/FloatOut.lhs +++ b/compiler/simplCore/FloatOut.lhs @@ -6,8 +6,9 @@ ``Long-distance'' floating of bindings towards the top level. \begin{code} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -457,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/LiberateCase.lhs b/compiler/simplCore/LiberateCase.lhs index a89396b782..2593ab159c 100644 --- a/compiler/simplCore/LiberateCase.lhs +++ b/compiler/simplCore/LiberateCase.lhs @@ -4,7 +4,8 @@ \section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index 2487787c8d..2ce32a1e9a 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -12,7 +12,8 @@ The occurrence analyser re-typechecks a core expression, returning a new core expression with (hopefully) improved usage information. \begin{code} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP, BangPatterns #-} + module OccurAnal ( occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap ) where @@ -1171,10 +1172,10 @@ occAnal env expr@(Var v) = (mkOneOcc env v False, expr) occAnal _ (Coercion co) = (addIdOccs emptyDetails (coVarsOfCo co), Coercion co) - -- See Note [Gather occurrences of coercion veriables] + -- See Note [Gather occurrences of coercion variables] \end{code} -Note [Gather occurrences of coercion veriables] +Note [Gather occurrences of coercion variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We need to gather info about what coercion variables appear, so that we can sort them into the right place when doing dependency analysis. @@ -1198,7 +1199,7 @@ occAnal env (Cast expr co) = case occAnal env expr of { (usage, expr') -> let usage1 = markManyIf (isRhsEnv env) usage usage2 = addIdOccs usage1 (coVarsOfCo co) - -- See Note [Gather occurrences of coercion veriables] + -- See Note [Gather occurrences of coercion variables] in (usage2, Cast expr' co) -- If we see let x = y `cast` co -- then mark y as 'Many' so that we don't @@ -1268,7 +1269,7 @@ occAnal env (Case scrut bndr ty alts) Just _ -> (usage `delVarEnv` bndr, setIdOccInfo bndr NoOccInfo) alt_env = mkAltEnv env scrut bndr - occ_anal_alt = occAnalAlt alt_env bndr + occ_anal_alt = occAnalAlt alt_env occ_anal_scrut (Var v) (alt1 : other_alts) | not (null other_alts) || not (isDefaultAlt alt1) @@ -1403,30 +1404,41 @@ scrutinised y). \begin{code} occAnalAlt :: (OccEnv, Maybe (Id, CoreExpr)) - -> CoreBndr -> CoreAlt -> (UsageDetails, Alt IdWithOccInfo) -occAnalAlt (env, scrut_bind) case_bndr (con, bndrs, rhs) +occAnalAlt (env, scrut_bind) (con, bndrs, rhs) = case occAnal env rhs of { (rhs_usage1, rhs1) -> let - (rhs_usage2, rhs2) = - wrapProxy (occ_binder_swap env) scrut_bind case_bndr rhs_usage1 rhs1 - (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage2 bndrs - bndrs' = tagged_bndrs -- See Note [Binders in case alternatives] + (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs + -- See Note [Binders in case alternatives] + (alt_usg', rhs2) = + wrapAltRHS env scrut_bind alt_usg tagged_bndrs rhs1 in - (alt_usg, (con, bndrs', rhs2)) } - -wrapProxy :: Bool -> Maybe (Id, CoreExpr) -> Id -> UsageDetails -> CoreExpr -> (UsageDetails, CoreExpr) -wrapProxy enable_binder_swap (Just (scrut_var, rhs)) case_bndr body_usg body - | enable_binder_swap, - scrut_var `usedIn` body_usg - = ( body_usg' +++ unitVarEnv case_bndr NoOccInfo - , Let (NonRec tagged_scrut_var rhs) body ) + (alt_usg', (con, tagged_bndrs, rhs2)) } + +wrapAltRHS :: OccEnv + -> Maybe (Id, CoreExpr) -- proxy mapping generated by mkAltEnv + -> UsageDetails -- usage for entire alt (p -> rhs) + -> [Var] -- alt binders + -> CoreExpr -- alt RHS + -> (UsageDetails, CoreExpr) +wrapAltRHS env (Just (scrut_var, let_rhs)) alt_usg bndrs alt_rhs + | occ_binder_swap env + , scrut_var `usedIn` alt_usg -- bndrs are not be present in alt_usg so this + -- handles condition (a) in Note [Binder swap] + , not captured -- See condition (b) in Note [Binder swap] + = ( alt_usg' +++ let_rhs_usg + , Let (NonRec tagged_scrut_var let_rhs') alt_rhs ) where - (body_usg', tagged_scrut_var) = tagBinder body_usg scrut_var - -wrapProxy _ _ _ body_usg body - = (body_usg, body) + captured = any (`usedIn` let_rhs_usg) bndrs + -- The rhs of the let may include coercion variables + -- if the scrutinee was a cast, so we must gather their + -- usage. See Note [Gather occurrences of coercion variables] + (let_rhs_usg, let_rhs') = occAnal env let_rhs + (alt_usg', tagged_scrut_var) = tagBinder alt_usg scrut_var + +wrapAltRHS _ _ alt_usg _ alt_rhs + = (alt_usg, alt_rhs) \end{code} diff --git a/compiler/simplCore/SAT.lhs b/compiler/simplCore/SAT.lhs index bc1ce42cd6..92ebdfe389 100644 --- a/compiler/simplCore/SAT.lhs +++ b/compiler/simplCore/SAT.lhs @@ -49,7 +49,8 @@ essential to make this work well! \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs index fc1e4df48b..ad5b119137 100644 --- a/compiler/simplCore/SetLevels.lhs +++ b/compiler/simplCore/SetLevels.lhs @@ -42,7 +42,8 @@ the scrutinee of the case, and we can inline it. \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 37feeb028f..79784a3efc 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -4,6 +4,8 @@ \section[SimplCore]{Driver for simplifying @Core@ programs} \begin{code} +{-# LANGUAGE CPP #-} + module SimplCore ( core2core, simplifyExpr ) where #include "HsVersions.h" diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index 5f1013def8..d8aec03b03 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -4,6 +4,8 @@ \section[SimplMonad]{The simplifier Monad} \begin{code} +{-# LANGUAGE CPP #-} + module SimplEnv ( InId, InBind, InExpr, InAlt, InArg, InType, InBndr, InVar, OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr, OutVar, @@ -29,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" @@ -45,7 +47,7 @@ import VarEnv import VarSet import OrdList import Id -import MkCore +import MkCore ( mkWildValBinder ) import TysWiredIn import qualified CoreSubst import qualified Type @@ -342,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 @@ -386,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}) @@ -421,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 @@ -435,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 @@ -475,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 ad12d7ec82..888c923254 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -4,6 +4,8 @@ \section[SimplUtils]{The simplifier utilities} \begin{code} +{-# LANGUAGE CPP #-} + module SimplUtils ( -- Rebuilding mkLam, mkCase, prepareAlts, tryEtaExpandRhs, @@ -852,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] @@ -961,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 @@ -1190,15 +1200,14 @@ because the latter is not well-kinded. \begin{code} tryEtaExpandRhs :: SimplEnv -> OutId -> OutExpr -> SimplM (Arity, OutExpr) -- See Note [Eta-expanding at let bindings] --- and Note [Eta expansion to manifest arity] tryEtaExpandRhs env bndr rhs = do { dflags <- getDynFlags ; (new_arity, new_rhs) <- try_expand dflags - ; WARN( new_arity < old_arity || new_arity < _dmd_arity, - (ptext (sLit "Arity decrease:") <+> (ppr bndr <+> ppr old_arity - <+> ppr new_arity <+> ppr _dmd_arity) $$ ppr new_rhs) ) - -- Note [Arity decrease] + ; WARN( new_arity < old_id_arity, + (ptext (sLit "Arity decrease:") <+> (ppr bndr <+> ppr old_id_arity + <+> ppr old_arity <+> ppr new_arity) $$ ppr new_rhs) ) + -- Note [Arity decrease] in Simplify return (new_arity, new_rhs) } where try_expand dflags @@ -1209,15 +1218,14 @@ tryEtaExpandRhs env bndr rhs , let new_arity1 = findRhsArity dflags bndr rhs old_arity new_arity2 = idCallArity bndr new_arity = max new_arity1 new_arity2 - , new_arity > manifest_arity -- And the curent manifest arity isn't enough + , new_arity > old_arity -- And the current manifest arity isn't enough = do { tick (EtaExpansion bndr) ; return (new_arity, etaExpand new_arity rhs) } | otherwise - = return (manifest_arity, rhs) + = return (old_arity, rhs) - manifest_arity = manifestArity rhs - old_arity = idArity bndr - _dmd_arity = length $ fst $ splitStrictSig $ idStrictness bndr + old_arity = exprArity rhs -- See Note [Do not expand eta-expand PAPs] + old_id_arity = idArity bndr \end{code} Note [Eta-expanding at let bindings] @@ -1226,7 +1234,7 @@ We now eta expand at let-bindings, which is where the payoff comes. The most significant thing is that we can do a simple arity analysis (in CoreArity.findRhsArity), which we can't do for free-floating lambdas -One useful consequence is this example: +One useful consequence of not eta-expanding lambdas is this example: genMap :: C a => ... {-# INLINE genMap #-} genMap f xs = ... @@ -1236,7 +1244,7 @@ One useful consequence is this example: myMap = genMap Notice that 'genMap' should only inline if applied to two arguments. -In the InlineRule for myMap we'll have the unfolding +In the stable unfolding for myMap we'll have the unfolding (\d -> genMap Int (..d..)) We do not want to eta-expand to (\d f xs -> genMap Int (..d..) f xs) @@ -1244,6 +1252,29 @@ because then 'genMap' will inline, and it really shouldn't: at least as far as the programmer is concerned, it's not applied to two arguments! +Note [Do not eta-expand PAPs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to have old_arity = manifestArity rhs, which meant that we +would eta-expand even PAPs. But this gives no particular advantage, +and can lead to a massive blow-up in code size, exhibited by Trac #9020. +Suppose we have a PAP + foo :: IO () + foo = returnIO () +Then we can eta-expand do + foo = (\eta. (returnIO () |> sym g) eta) |> g +where + g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #) + +But there is really no point in doing this, and it generates masses of +coercions and whatnot that eventually disappear again. For T9020, GHC +allocated 6.6G beore, and 0.8G afterwards; and residency dropped from +1.8G to 45M. + +But note that this won't eta-expand, say + f = \g -> map g +Does it matter not eta-expanding such functions? I'm not sure. Perhaps +strictness analysis will have less to bite on? + %************************************************************************ %* * diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 02470be050..cc214f7513 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -4,6 +4,8 @@ \section[Simplify]{The main module of the simplifier} \begin{code} +{-# LANGUAGE CPP #-} + module Simplify ( simplTopBinds, simplExpr ) where #include "HsVersions.h" @@ -219,9 +221,7 @@ simplTopBinds env0 binds0 -- It's rather as if the top-level binders were imported. -- See note [Glomming] in OccurAnal. ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0) - ; dflags <- getDynFlags - ; let dump_flag = dopt Opt_D_verbose_core2core dflags - ; env2 <- simpl_binds dump_flag env1 binds0 + ; env2 <- simpl_binds env1 binds0 ; freeTick SimplifierDone ; return env2 } where @@ -229,16 +229,10 @@ simplTopBinds env0 binds0 -- they should have their fragile IdInfo zapped (notably occurrence info) -- That's why we run down binds and bndrs' simultaneously. -- - -- The dump-flag emits a trace for each top-level binding, which - -- helps to locate the tracing for inlining and rule firing - simpl_binds :: Bool -> SimplEnv -> [InBind] -> SimplM SimplEnv - simpl_binds _ env [] = return env - simpl_binds dump env (bind:binds) = do { env' <- trace_bind dump bind $ - simpl_bind env bind - ; simpl_binds dump env' binds } - - trace_bind True bind = pprTrace "SimplBind" (ppr (bindersOf bind)) - trace_bind False _ = \x -> x + simpl_binds :: SimplEnv -> [InBind] -> SimplM SimplEnv + simpl_binds env [] = return env + simpl_binds env (bind:binds) = do { env' <- simpl_bind env bind + ; simpl_binds env' binds } simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel NonRecursive b b' r @@ -293,12 +287,21 @@ simplRecOrTopPair :: SimplEnv -> SimplM SimplEnv -- Returns an env that includes the binding simplRecOrTopPair env top_lvl is_rec old_bndr new_bndr rhs - = do dflags <- getDynFlags - -- Check for unconditional inline - if preInlineUnconditionally dflags env top_lvl old_bndr rhs + = do { dflags <- getDynFlags + ; trace_bind dflags $ + if preInlineUnconditionally dflags env top_lvl old_bndr rhs + -- Check for unconditional inline then do tick (PreInlineUnconditionally old_bndr) return (extendIdSubst env old_bndr (mkContEx env rhs)) - else simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env + else simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env } + where + trace_bind dflags thing_inside + | not (dopt Opt_D_verbose_core2core dflags) + = thing_inside + | otherwise + = pprTrace "SimplBind" (ppr old_bndr) thing_inside + -- trace_bind emits a trace for each top-level binding, which + -- helps to locate the tracing for inlining and rule firing \end{code} @@ -323,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 @@ -375,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) @@ -394,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 @@ -641,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 @@ -1174,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 @@ -1324,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 @@ -1339,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} %************************************************************************ @@ -1714,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. @@ -1860,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 } @@ -1867,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)), @@ -1928,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 @@ -2264,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/simplStg/SimplStg.lhs b/compiler/simplStg/SimplStg.lhs index c43b6526b5..4d33e3392e 100644 --- a/compiler/simplStg/SimplStg.lhs +++ b/compiler/simplStg/SimplStg.lhs @@ -4,6 +4,8 @@ \section[SimplStg]{Driver for simplifying @STG@ programs} \begin{code} +{-# LANGUAGE CPP #-} + module SimplStg ( stg2stg ) where #include "HsVersions.h" diff --git a/compiler/simplStg/StgStats.lhs b/compiler/simplStg/StgStats.lhs index 5424495468..2a776757da 100644 --- a/compiler/simplStg/StgStats.lhs +++ b/compiler/simplStg/StgStats.lhs @@ -21,6 +21,8 @@ The program gather statistics about \end{enumerate} \begin{code} +{-# LANGUAGE CPP #-} + module StgStats ( showStgStats ) where #include "HsVersions.h" diff --git a/compiler/simplStg/UnariseStg.lhs b/compiler/simplStg/UnariseStg.lhs index b1717ad120..1f121f71fd 100644 --- a/compiler/simplStg/UnariseStg.lhs +++ b/compiler/simplStg/UnariseStg.lhs @@ -27,6 +27,8 @@ which is the Arity taking into account any expanded arguments, and corresponds t the number of (possibly-void) *registers* arguments will arrive in. \begin{code} +{-# LANGUAGE CPP #-} + module UnariseStg (unarise) where #include "HsVersions.h" diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index 70fc09a2ef..2abf7fbdca 100644 --- a/compiler/specialise/Rules.lhs +++ b/compiler/specialise/Rules.lhs @@ -4,6 +4,8 @@ \section[CoreRules]{Transformation rules} \begin{code} +{-# LANGUAGE CPP #-} + -- | Functions for collecting together and applying rewrite rules to a module. -- The 'CoreRule' datatype itself is declared elsewhere. module Rules ( diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index 86a56f4013..24820eba40 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -9,6 +9,8 @@ ToDo [Oct 2013] \section[SpecConstr]{Specialise over constructors} \begin{code} +{-# LANGUAGE CPP #-} + module SpecConstr( specConstrProgram #ifdef GHCI @@ -396,16 +398,19 @@ use the calls in the un-specialised RHS as seeds. We call these Note [Top-level recursive groups] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If all the bindings in a top-level recursive group are not exported, -all the calls are in the rest of the top-level bindings. -This means we can specialise with those call patterns instead of with the RHSs -of the recursive group. +If all the bindings in a top-level recursive group are local (not +exported), then all the calls are in the rest of the top-level +bindings. This means we can specialise with those call patterns +instead of with the RHSs of the recursive group. + +(Question: maybe we should *also* use calls in the rest of the +top-level bindings as seeds? -To get the call usage information, we work backwards through the top-level bindings -so we see the usage before we get to the binding of the function. -Before we can collect the usage though, we go through all the bindings and add them -to the environment. This is necessary because usage is only tracked for functions -in the environment. +To get the call usage information, we work backwards through the +top-level bindings so we see the usage before we get to the binding of +the function. Before we can collect the usage though, we go through +all the bindings and add them to the environment. This is necessary +because usage is only tracked for functions in the environment. The actual seeding of the specialisation is very similar to Note [Local recursive group]. @@ -1323,16 +1328,14 @@ scTopBind env usage (Rec prs) = do { (rhs_usgs, rhss') <- mapAndUnzipM (scExpr env) rhss ; return (usage `combineUsage` (combineUsages rhs_usgs), Rec (bndrs `zip` rhss')) } | otherwise -- Do specialisation - = do { (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs env) (bndrs `zip` rhss) + = do { (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs env) prs -- ; pprTrace "scTopBind" (ppr bndrs $$ ppr (map (lookupVarEnv (scu_calls usage)) bndrs)) (return ()) -- Note [Top-level recursive groups] - ; let (usg,rest) = if all (not . isExportedId) bndrs - then -- pprTrace "scTopBind-T" (ppr bndrs $$ ppr (map (fmap (map snd) . lookupVarEnv (scu_calls usage)) bndrs)) - ( usage - , [SI [] 0 (Just us) | us <- rhs_usgs] ) - else ( combineUsages rhs_usgs - , [SI [] 0 Nothing | _ <- rhs_usgs] ) + ; let (usg,rest) | any isExportedId bndrs -- Seed from RHSs + = ( combineUsages rhs_usgs, [SI [] 0 Nothing | _ <- rhs_usgs] ) + | otherwise -- Seed from body only + = ( usage, [SI [] 0 (Just us) | us <- rhs_usgs] ) ; (usage', specs) <- specLoop (scForce env force_spec) (scu_calls usg) rhs_infos nullUsage rest @@ -1446,11 +1449,6 @@ specialise env bind_calls (RI fn _ arg_bndrs body arg_occs) , notNull arg_bndrs -- Only specialise functions , Just all_calls <- lookupVarEnv bind_calls fn = do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls --- ; pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int (length pats) <+> text "good patterns" --- , text "arg_occs" <+> ppr arg_occs --- , text "calls" <+> ppr all_calls --- , text "good pats" <+> ppr pats]) $ --- return () -- Bale out if too many specialisations ; let n_pats = length pats @@ -1473,12 +1471,25 @@ specialise env bind_calls (RI fn _ arg_bndrs body arg_occs) _normal_case -> do { - let spec_env = decreaseSpecCount env n_pats +-- ; if (not (null pats) || isJust mb_unspec) then +-- pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int (length pats) <+> text "good patterns" +-- , text "mb_unspec" <+> ppr (isJust mb_unspec) +-- , text "arg_occs" <+> ppr arg_occs +-- , text "good pats" <+> ppr pats]) $ +-- return () +-- else return () + + ; let spec_env = decreaseSpecCount env n_pats ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body) (pats `zip` [spec_count..]) -- See Note [Specialise original body] ; let spec_usg = combineUsages spec_usgs + + -- If there were any boring calls among the seeds (= all_calls), then those + -- calls will call the un-specialised function. So we should use the seeds + -- from the _unspecialised_ function's RHS, which are in mb_unspec, by returning + -- then in new_usg. (new_usg, mb_unspec') = case mb_unspec of Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing) diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 3191ae946e..baa5d1971f 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -4,6 +4,8 @@ \section[Specialise]{Stamping out overloading, and (optionally) polymorphism} \begin{code} +{-# LANGUAGE CPP #-} + module Specialise ( specProgram ) where #include "HsVersions.h" diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index 7b632b4ac2..073a1c3bfa 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -1,4 +1,6 @@ \begin{code} +{-# LANGUAGE CPP #-} + -- -- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -- diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs index 04349db3df..ec9f6fa9d6 100644 --- a/compiler/stgSyn/StgLint.lhs +++ b/compiler/stgSyn/StgLint.lhs @@ -4,6 +4,8 @@ \section[StgLint]{A ``lint'' pass to check for Stg correctness} \begin{code} +{-# LANGUAGE CPP #-} + module StgLint ( lintStgBindings ) where import StgSyn diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs index 3fa8c68c16..2ecd573133 100644 --- a/compiler/stgSyn/StgSyn.lhs +++ b/compiler/stgSyn/StgSyn.lhs @@ -9,6 +9,7 @@ being one that happens to be ideally suited to spineless tagless code generation. \begin{code} +{-# LANGUAGE CPP #-} module StgSyn ( GenStgArg(..), diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 3294371964..a3b7c0b72a 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -7,7 +7,8 @@ ----------------- \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module DmdAnal ( dmdAnalProgram ) where @@ -114,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') @@ -593,9 +594,18 @@ dmdAnalRhs :: TopLevelFlag -- Process the RHS of the binding, add the strictness signature -- to the Id, and augment the environment with the signature as well. dmdAnalRhs top_lvl rec_flag env id rhs - | Just fn <- unpackTrivial rhs -- See Note [Trivial right-hand sides] + | Just fn <- unpackTrivial rhs -- See Note [Demand analysis for trivial right-hand sides] , let fn_str = getStrictness env fn - = (fn_str, emptyDmdEnv, set_idStrictness env id fn_str, rhs) + fn_fv | isLocalId fn = unitVarEnv fn topDmd + | otherwise = emptyDmdEnv + -- Note [Remember to demand the function itself] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- fn_fv: don't forget to produce a demand for fn itself + -- Lacking this caused Trac #9128 + -- The demand is very conservative (topDmd), but that doesn't + -- matter; trivial bindings are usually inlined, so it only + -- kicks in for top-level bindings and NOINLINE bindings + = (fn_str, fn_fv, set_idStrictness env id fn_str, rhs) | otherwise = (sig_ty, lazy_fv, id', mkLams bndrs' body') @@ -638,7 +648,7 @@ dmdAnalRhs top_lvl rec_flag env id rhs unpackTrivial :: CoreExpr -> Maybe Id -- Returns (Just v) if the arg is really equal to v, modulo -- casts, type applications etc --- See Note [Trivial right-hand sides] +-- See Note [Demand analysis for trivial right-hand sides] unpackTrivial (Var v) = Just v unpackTrivial (Cast e _) = unpackTrivial e unpackTrivial (Lam v e) | isTyVar v = unpackTrivial e @@ -646,15 +656,23 @@ unpackTrivial (App e a) | isTypeArg a = unpackTrivial e unpackTrivial _ = Nothing \end{code} -Note [Trivial right-hand sides] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Demand analysis for trivial right-hand sides] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider foo = plusInt |> co where plusInt is an arity-2 function with known strictness. Clearly we want plusInt's strictness to propagate to foo! But because it has -no manifest lambdas, it won't do so automatically. So we have a +no manifest lambdas, it won't do so automatically, and indeed 'co' might +have type (Int->Int->Int) ~ T, so we *can't* eta-expand. So we have a special case for right-hand sides that are "trivial", namely variables, -casts, type applications, and the like. +casts, type applications, and the like. + +Note that this can mean that 'foo' has an arity that is smaller than that +indicated by its demand info. e.g. if co :: (Int->Int->Int) ~ T, then +foo's arity will be zero (see Note [exprArity invariant] in CoreArity), +but its demand signature will be that of plusInt. A small example is the +test case of Trac #8963. + Note [Product demands for function body] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs index f5bc18b69e..5b9d0a3083 100644 --- a/compiler/stranal/WorkWrap.lhs +++ b/compiler/stranal/WorkWrap.lhs @@ -4,7 +4,8 @@ \section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -259,16 +260,28 @@ tryWW dflags fam_envs is_rec fn_id rhs -- Furthermore, don't even expose strictness info = return [ (fn_id, rhs) ] + | isStableUnfolding (realIdUnfolding fn_id) + = return [ (fn_id, rhs) ] + -- See Note [Don't w/w INLINE things] + -- and Note [Don't w/w INLINABLE things] + -- NB: use realIdUnfolding because we want to see the unfolding + -- even if it's a loop breaker! + + | certainlyWillInline dflags (idUnfolding fn_id) + = let inline_rule = mkInlineUnfolding Nothing rhs + in return [ (fn_id `setIdUnfolding` inline_rule, rhs) ] + -- Note [Don't w/w inline small non-loop-breaker things] + -- NB: use idUnfolding because we don't want to apply + -- this criterion to a loop breaker! + + | is_fun + = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds res_info rhs + + | is_thunk -- See Note [Thunk splitting] + = splitThunk dflags fam_envs is_rec new_fn_id rhs + | otherwise - = do - let doSplit | is_fun = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds res_info rhs - | is_thunk = splitThunk dflags fam_envs is_rec new_fn_id rhs - -- See Note [Thunk splitting] - | otherwise = return Nothing - try <- doSplit - case try of - Nothing -> return $ [ (new_fn_id, rhs) ] - Just binds -> checkSize dflags new_fn_id rhs binds + = return [ (new_fn_id, rhs) ] where fn_info = idInfo fn_id @@ -291,29 +304,10 @@ tryWW dflags fam_envs is_rec fn_id rhs is_fun = notNull wrap_dmds is_thunk = not is_fun && not (exprIsHNF rhs) ---------------------- -checkSize :: DynFlags -> Id -> CoreExpr -> [(Id,CoreExpr)] -> UniqSM [(Id,CoreExpr)] -checkSize dflags fn_id rhs thing_inside - | isStableUnfolding (realIdUnfolding fn_id) - = return [ (fn_id, rhs) ] - -- See Note [Don't w/w INLINE things] - -- and Note [Don't w/w INLINABLE things] - -- NB: use realIdUnfolding because we want to see the unfolding - -- even if it's a loop breaker! - - | certainlyWillInline dflags (idUnfolding fn_id) - = return [ (fn_id `setIdUnfolding` inline_rule, rhs) ] - -- Note [Don't w/w inline small non-loop-breaker things] - -- NB: use idUnfolding because we don't want to apply - -- this criterion to a loop breaker! - - | otherwise = return thing_inside - where - inline_rule = mkInlineUnfolding Nothing rhs --------------------- splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> DmdResult -> CoreExpr - -> UniqSM (Maybe [(Id, CoreExpr)]) + -> UniqSM [(Id, CoreExpr)] splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) do -- The arity should match the signature @@ -361,12 +355,11 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs `setIdOccInfo` NoOccInfo -- Zap any loop-breaker-ness, to avoid bleating from Lint -- about a loop breaker with an INLINE rule - return $ Just [(work_id, work_rhs), (wrap_id, wrap_rhs)] + return $ [(work_id, work_rhs), (wrap_id, wrap_rhs)] -- Worker first, because wrapper mentions it -- mkWwBodies has already built a wrap_rhs with an INLINE pragma wrapped around it - Nothing -> - return Nothing + Nothing -> return [(fn_id, rhs)] where fun_ty = idType fn_id inl_prag = inlinePragInfo fn_info @@ -452,11 +445,11 @@ then the splitting will go deeper too. -- --> x = let x = e in -- case x of (a,b) -> let x = (a,b) in x -splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM (Maybe [(Var, Expr Var)]) -splitThunk dflags fam_envs is_rec fn_id rhs = do - (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs [fn_id] - let res = [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ] - if useful then ASSERT2( isNonRec is_rec, ppr fn_id ) -- The thunk must be non-recursive - return (Just res) - else return Nothing +splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)] +splitThunk dflags fam_envs is_rec fn_id rhs + = do { (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs [fn_id] + ; let res = [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ] + ; if useful then ASSERT2( isNonRec is_rec, ppr fn_id ) -- The thunk must be non-recursive + return res + else return [(fn_id, rhs)] } \end{code} diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs index 68292839ed..7a9845b3d7 100644 --- a/compiler/stranal/WwLib.lhs +++ b/compiler/stranal/WwLib.lhs @@ -4,6 +4,8 @@ \section[WwLib]{A library for the ``worker\/wrapper'' back-end to the strictness analyser} \begin{code} +{-# LANGUAGE CPP #-} + module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs , deepSplitProductType_maybe, findTypeShape ) where @@ -732,7 +734,7 @@ mk_absent_let dflags arg where arg_ty = idType arg abs_rhs = mkRuntimeErrorApp aBSENT_ERROR_ID arg_ty msg - msg = showSDocDebug dflags (ppr arg <+> ppr (idType arg)) + msg = showSDoc dflags (ppr arg <+> ppr (idType arg)) mk_seq_case :: Id -> CoreExpr -> CoreExpr mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)] diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index 572874b875..d0b2d0da5a 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -1,8 +1,8 @@ The @FamInst@ type: family instance heads \begin{code} -{-# LANGUAGE GADTs #-} -{-# OPTIONS -fno-warn-tabs #-} +{-# LANGUAGE CPP, GADTs #-} +{-# 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 @@ -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 1dc96aa037..5cfd22664a 100644 --- a/compiler/typecheck/FunDeps.lhs +++ b/compiler/typecheck/FunDeps.lhs @@ -8,6 +8,8 @@ FunDeps - functional dependencies It's better to read it as: "if we know these, then we're going to know these" \begin{code} +{-# LANGUAGE CPP #-} + module FunDeps ( FDEq (..), Equation(..), pprEquation, @@ -26,8 +28,8 @@ import Unify import InstEnv import VarSet import VarEnv -import Maybes( firstJusts ) import Outputable +import ErrUtils( Validity(..), allValid ) import Util import FastString @@ -415,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 -- @@ -424,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] @@ -559,7 +561,7 @@ if s1 matches \begin{code} checkFunDeps :: (InstEnv, InstEnv) -> ClsInst -> Maybe [ClsInst] -- Nothing <=> ok - -- Just dfs <=> conflict with dfs + -- Just dfs <=> conflict with dfs -- Check wheher adding DFunId would break functional-dependency constraints -- Used only for instance decls defined in the module being compiled checkFunDeps inst_envs ispec diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index e934984383..a27c0bd0f6 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -6,7 +6,8 @@ The @Inst@ type: dictionaries or method instances \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -48,7 +49,6 @@ import TcMType import Type import Coercion ( Role(..) ) import TcType -import Unify import HscTypes import Id import Name @@ -59,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} @@ -382,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 } @@ -408,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. @@ -436,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 @@ -446,37 +463,17 @@ 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 = traceTc "Adding instances:" (vcat (map pp ispecs)) where - pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec + pp ispec = hang (ppr (instanceDFunId ispec) <+> colon) + 2 (ppr ispec) -- Print the dfun name itself too funDepErr :: ClsInst -> [ClsInst] -> TcRn () @@ -489,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/TcAnnotations.lhs b/compiler/typecheck/TcAnnotations.lhs index e12552f419..cbd19cf8f3 100644 --- a/compiler/typecheck/TcAnnotations.lhs +++ b/compiler/typecheck/TcAnnotations.lhs @@ -5,6 +5,8 @@ \section[TcAnnotations]{Typechecking annotations} \begin{code} +{-# LANGUAGE CPP #-} + module TcAnnotations ( tcAnnotations, annCtxt ) where #ifdef GHCI diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index b427dd5409..eab8941956 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -5,16 +5,11 @@ Typecheck arrow notation \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details +{-# LANGUAGE RankNTypes #-} module TcArrows ( tcProc ) where -import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr ) +import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr ) import HsSyn import TcMatches @@ -77,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} @@ -112,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 @@ -126,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 @@ -166,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 @@ -199,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. @@ -219,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 @@ -227,76 +222,76 @@ 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 -- ------------------------------ -- D;G |-a (\x.cmd) : (t,stk) --> res tc_cmd env - (HsCmdLam (MG { mg_alts = [L mtch_loc (match@(Match pats _maybe_rhs_sig grhss))] })) + (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 }) - ; return (mkHsCmdCast co cmd') } + , mg_res_ty = res_ty, mg_origin = origin }) + ; 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 @@ -307,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) @@ -333,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 @@ -369,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 @@ -390,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 +%* * %************************************************************************ @@ -413,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 8b2928c8c8..14a570423e 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -5,6 +5,8 @@ \section[TcBinds]{TcBinds} \begin{code} +{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} + module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds, tcHsBootSigs, tcPolyCheck, PragFun, tcSpecPrags, tcVectDecls, mkPragFun, @@ -14,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 @@ -37,6 +39,7 @@ import TysPrim import Id import Var import VarSet +import VarEnv( TidyEnv ) import Module import Name import NameSet @@ -54,6 +57,7 @@ import FastString import Type(mkStrLitTy) import Class(classTyCon) import PrelNames(ipClassName) +import TcValidity (checkValidType) import Control.Monad @@ -270,6 +274,30 @@ time by defaulting. No no no. However [Oct 10] this is all handled automatically by the untouchable-range idea. +Note [Placeholder PatSyn kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (Trac #9161) + + {-# LANGUAGE PatternSynonyms, DataKinds #-} + pattern A = () + b :: A + b = undefined + +Here, the type signature for b mentions A. But A is a pattern +synonym, which is typechecked (for very good reasons; a view pattern +in the RHS may mention a value binding) as part of a group of +bindings. It is entirely resonable to reject this, but to do so +we need A to be in the kind environment when kind-checking the signature for B. + +Hence the tcExtendKindEnv2 patsyn_placeholder_kinds, which adds a binding + A -> AGlobal (AConLike (PatSynCon _|_)) +to the environment. Then TcHsType.tcTyVar will find A in the kind environment, +and will give a 'wrongThingErr' as a result. But the lookup of A won't fail. + +The _|_ (= panic "fakePatSynCon") works because the wrongThingErr call, in +tcTyVar, doesn't look inside the TcTyThing. + + \begin{code} tcValBinds :: TopLevelFlag -> [(RecFlag, LHsBinds Name)] -> [LSig Name] @@ -277,19 +305,31 @@ tcValBinds :: TopLevelFlag -> TcM ([(RecFlag, LHsBinds TcId)], thing) tcValBinds top_lvl binds sigs thing_inside - = do { -- Typecheck the signature - (poly_ids, sig_fn) <- tcTySigs sigs + = do { -- Typecheck the signature + ; (poly_ids, sig_fn) <- tcExtendKindEnv2 patsyn_placeholder_kinds $ + -- See Note [Placeholder PatSyn kinds] + tcTySigs sigs ; let prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds) -- Extend the envt right away with all -- the Ids declared with type signatures -- Use tcExtendIdEnv2 to avoid extending the TcIdBinder stack - ; (binds', thing) <- tcExtendIdEnv2 [(idName id, id) | id <- poly_ids] $ - tcBindGroups top_lvl sig_fn prag_fn - binds thing_inside - - ; return (binds', thing) } + ; 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)| PSB{ psb_id = L _ name } <- patsyns ] + placeholder_patsyn_tything + = AGlobal $ AConLike $ PatSynCon $ panic "fakePatSynCon" ------------------------ tcBindGroups :: TopLevelFlag -> TcSigFun -> PragFun @@ -345,14 +385,14 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside ; return ([(Recursive, binds1)], thing) } -- Rec them all together where - hasPatSyn = anyBag (isPatSyn . unLoc . snd) binds + hasPatSyn = anyBag (isPatSyn . unLoc) binds isPatSyn PatSynBind{} = True isPatSyn _ = False - sccs :: [SCC (Origin, LHsBind Name)] + sccs :: [SCC (LHsBind Name)] sccs = stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds) - go :: [SCC (Origin, LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], thing) + go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], thing) go (scc:sccs) = do { (binds1, ids1, closed) <- tc_scc scc ; (binds2, ids2, thing) <- tcExtendLetEnv top_lvl closed ids1 $ go sccs @@ -368,7 +408,7 @@ recursivePatSynErr :: OutputableBndr name => LHsBinds name -> TcM a recursivePatSynErr binds = failWithTc $ hang (ptext (sLit "Recursive pattern synonym definition with following bindings:")) - 2 (vcat $ map (pprLBind . snd) . bagToList $ binds) + 2 (vcat $ map pprLBind . bagToList $ binds) where pprLoc loc = parens (ptext (sLit "defined at") <+> ppr loc) pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+> @@ -376,11 +416,10 @@ recursivePatSynErr binds tc_single :: forall thing. TopLevelFlag -> TcSigFun -> PragFun - -> (Origin, LHsBind Name) -> TcM thing + -> 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) : @@ -400,12 +439,12 @@ tc_single top_lvl sig_fn prag_fn lbind thing_inside ------------------------ mkEdges :: TcSigFun -> LHsBinds Name - -> [((Origin, LHsBind Name), BKey, [BKey])] + -> [(LHsBind Name, BKey, [BKey])] type BKey = Int -- Just number off the bindings mkEdges sig_fn binds - = [ (bind, key, [key | n <- nameSetToList (bind_fvs (unLoc . snd $ bind)), + = [ (bind, key, [key | n <- nameSetToList (bind_fvs (unLoc bind)), Just key <- [lookupNameEnv key_map n], no_sig n ]) | (bind, key) <- keyd_binds ] @@ -416,13 +455,13 @@ mkEdges sig_fn binds keyd_binds = bagToList binds `zip` [0::BKey ..] key_map :: NameEnv BKey -- Which binding it comes from - key_map = mkNameEnv [(bndr, key) | ((_, L _ bind), key) <- keyd_binds + key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds , bndr <- bindersOfHsBind bind ] 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" @@ -431,7 +470,7 @@ tcPolyBinds :: TopLevelFlag -> TcSigFun -> PragFun -> RecFlag -- Whether the group is really recursive -> RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures - -> [(Origin, LHsBind Name)] + -> [LHsBind Name] -> TcM (LHsBinds TcId, [TcId], TopLevelFlag) -- Typechecks a single bunch of bindings all together, @@ -471,9 +510,8 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list ; return result } where - bind_list' = map snd bind_list - binder_names = collectHsBindListBinders bind_list' - loc = foldr1 combineSrcSpans (map getLoc bind_list') + binder_names = collectHsBindListBinders bind_list + loc = foldr1 combineSrcSpans (map getLoc bind_list) -- The mbinds have been dependency analysed and -- may no longer be adjacent; so find the narrowest -- span that includes them all @@ -483,7 +521,7 @@ tcPolyNoGen -- No generalisation whatsoever :: RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures -> PragFun -> TcSigFun - -> [(Origin, LHsBind Name)] + -> [LHsBind Name] -> TcM (LHsBinds TcId, [TcId], TopLevelFlag) tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list @@ -508,7 +546,7 @@ tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list tcPolyCheck :: RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures -> PragFun -> TcSigInfo - -> (Origin, LHsBind Name) + -> LHsBind Name -> TcM (LHsBinds TcId, [TcId], TopLevelFlag) -- There is just one binding, -- it binds a single variable, @@ -516,7 +554,7 @@ tcPolyCheck :: RecFlag -- Whether it's recursive after breaking tcPolyCheck rec_tc prag_fn sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped , sig_theta = theta, sig_tau = tau, sig_loc = loc }) - bind@(origin, _) + bind = do { ev_vars <- newEvVars theta ; let skol_info = SigSkol (FunSigCtxt (idName poly_id)) (mkPhiTy theta tau) prag_sigs = prag_fn (idName poly_id) @@ -541,7 +579,7 @@ tcPolyCheck rec_tc prag_fn , abs_exports = [export], abs_binds = binds' } closed | isEmptyVarSet (tyVarsOfType (idType poly_id)) = TopLevel | otherwise = NotTopLevel - ; return (unitBag (origin, abs_bind), [poly_id], closed) } + ; return (unitBag abs_bind, [poly_id], closed) } ------------------ tcPolyInfer @@ -550,7 +588,7 @@ tcPolyInfer -> PragFun -> TcSigFun -> Bool -- True <=> apply the monomorphism restriction -> Bool -- True <=> free vars have closed types - -> [(Origin, LHsBind Name)] + -> [LHsBind Name] -> TcM (LHsBinds TcId, [TcId], TopLevelFlag) tcPolyInfer rec_tc prag_fn tc_sig_fn mono closed bind_list = do { ((binds', mono_infos), wanted) @@ -559,12 +597,11 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono closed bind_list ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos] ; traceTc "simplifyInfer call" (ppr name_taus $$ ppr wanted) - ; (qtvs, givens, mr_bites, ev_binds) <- - simplifyInfer closed mono name_taus wanted + ; (qtvs, givens, mr_bites, ev_binds) + <- simplifyInfer closed mono name_taus wanted - ; theta <- zonkTcThetaType (map evVarPred givens) + ; theta <- zonkTcThetaType (map evVarPred givens) ; exports <- checkNoErrs $ mapM (mkExport prag_fn qtvs theta) mono_infos - ; loc <- getSrcSpanM ; let poly_ids = map abe_poly exports final_closed | closed && not mr_bites = TopLevel @@ -576,10 +613,8 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono closed bind_list ; traceTc "Binding:" (ppr final_closed $$ ppr (poly_ids `zip` map idType poly_ids)) - ; return (unitBag (origin, abs_bind), poly_ids, final_closed) } + ; return (unitBag abs_bind, poly_ids, final_closed) } -- poly_ids are guaranteed zonked by mkExport - where - origin = if all isGenerated (map fst bind_list) then Generated else FromSource -------------- mkExport :: PragFun @@ -601,20 +636,12 @@ mkExport :: PragFun mkExport prag_fn qtvs theta (poly_name, mb_sig, mono_id) = do { mono_ty <- zonkTcType (idType mono_id) - ; let poly_id = case mb_sig of - Nothing -> mkLocalId poly_name inferred_poly_ty - Just sig -> sig_id sig - -- poly_id has a zonked type - - -- In the inference case (no signature) this stuff figures out - -- the right type variables and theta to quantify over - -- See Note [Impedence matching] - my_tvs2 = closeOverKinds (growThetaTyVars theta (tyVarsOfType mono_ty)) - -- Include kind variables! Trac #7916 - my_tvs = filter (`elemVarSet` my_tvs2) qtvs -- Maintain original order - my_theta = filter (quantifyPred my_tvs2) theta - inferred_poly_ty = mkSigmaTy my_tvs my_theta mono_ty + ; poly_id <- case mb_sig of + Just sig -> return (sig_id sig) + Nothing -> mkInferredPolyId poly_name qtvs theta mono_ty + + -- NB: poly_id has a zonked type ; poly_id <- addInlinePrags poly_id prag_sigs ; spec_prags <- tcSpecPrags poly_id prag_sigs -- tcPrags requires a zonked poly_id @@ -630,7 +657,7 @@ mkExport prag_fn qtvs theta (poly_name, mb_sig, mono_id) -- closed (unless we are doing NoMonoLocalBinds in which case all bets -- are off) -- See Note [Impedence matching] - ; (wrap, wanted) <- addErrCtxtM (mk_msg poly_id) $ + ; (wrap, wanted) <- addErrCtxtM (mk_bind_msg inferred True poly_name (idType poly_id)) $ captureConstraints $ tcSubType origin sig_ctxt sel_poly_ty (idType poly_id) ; ev_binds <- simplifyTop wanted @@ -641,24 +668,58 @@ mkExport prag_fn qtvs theta (poly_name, mb_sig, mono_id) , abe_prags = SpecPrags spec_prags }) } where inferred = isNothing mb_sig - - mk_msg poly_id tidy_env - = return (tidy_env', msg) - where - msg | inferred = hang (ptext (sLit "When checking that") <+> pp_name) - 2 (ptext (sLit "has the inferred type") <+> pp_ty) - $$ ptext (sLit "Probable cause: the inferred type is ambiguous") - | otherwise = hang (ptext (sLit "When checking that") <+> pp_name) - 2 (ptext (sLit "has the specified type") <+> pp_ty) - pp_name = quotes (ppr poly_name) - pp_ty = quotes (ppr tidy_ty) - (tidy_env', tidy_ty) = tidyOpenType tidy_env (idType poly_id) - prag_sigs = prag_fn poly_name origin = AmbigOrigin sig_ctxt sig_ctxt = InfSigCtxt poly_name + +mkInferredPolyId :: Name -> [TyVar] -> TcThetaType -> TcType -> TcM Id +-- In the inference case (no signature) this stuff figures out +-- the right type variables and theta to quantify over +-- See Note [Validity of inferred types] +mkInferredPolyId poly_name qtvs theta mono_ty + = addErrCtxtM (mk_bind_msg True False poly_name inferred_poly_ty) $ + do { checkValidType (InfSigCtxt poly_name) inferred_poly_ty + ; return (mkLocalId poly_name inferred_poly_ty) } + where + my_tvs2 = closeOverKinds (growThetaTyVars theta (tyVarsOfType mono_ty)) + -- Include kind variables! Trac #7916 + my_tvs = filter (`elemVarSet` my_tvs2) qtvs -- Maintain original order + my_theta = filter (quantifyPred my_tvs2) theta + inferred_poly_ty = mkSigmaTy my_tvs my_theta mono_ty + +mk_bind_msg :: Bool -> Bool -> Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) +mk_bind_msg inferred want_ambig poly_name poly_ty tidy_env + = return (tidy_env', msg) + where + msg = vcat [ ptext (sLit "When checking that") <+> quotes (ppr poly_name) + <+> ptext (sLit "has the") <+> what <+> ptext (sLit "type") + , nest 2 (ppr poly_name <+> dcolon <+> ppr tidy_ty) + , ppWhen want_ambig $ + ptext (sLit "Probable cause: the inferred type is ambiguous") ] + what | inferred = ptext (sLit "inferred") + | otherwise = ptext (sLit "specified") + (tidy_env', tidy_ty) = tidyOpenType tidy_env poly_ty \end{code} +Note [Validity of inferred types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to check inferred type for validity, in case it uses language +extensions that are not turned on. The principle is that if the user +simply adds the inferred type to the program source, it'll compile fine. +See #8883. + +Examples that might fail: + - an inferred theta that requires type equalities e.g. (F a ~ G b) + or multi-parameter type classes + - an inferred type that includes unboxed tuples + +However we don't do the ambiguity check (checkValidType omits it for +InfSigCtxt) because the impedence-matching stage, which follows +immediately, will do it and we don't want two error messages. +Moreover, because of the impedence matching stage, the ambiguity-check +suggestion of -XAllowAmbiguiousTypes will not work. + + Note [Impedence matching] ~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -723,7 +784,7 @@ mkPragFun sigs binds = \n -> lookupNameEnv prag_env n `orElse` [] -- ar_env maps a local to the arity of its definition ar_env :: NameEnv Arity - ar_env = foldrBag (lhsBindArity . snd) emptyNameEnv binds + ar_env = foldrBag lhsBindArity emptyNameEnv binds lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env @@ -778,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 @@ -993,12 +1054,12 @@ tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking pur -- i.e. the binders are mentioned in their RHSs, and -- we are not rescued by a type signature -> TcSigFun -> LetBndrSpec - -> [(Origin, LHsBind Name)] + -> [LHsBind Name] -> TcM (LHsBinds TcId, [MonoBindInfo]) tcMonoBinds is_rec sig_fn no_gen - [ (origin, L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, - fun_matches = matches, bind_fvs = fvs }))] + [ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, + fun_matches = matches, bind_fvs = fvs })] -- Single function binding, | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS , Nothing <- sig_fn name -- ...with no type signature @@ -1016,17 +1077,16 @@ tcMonoBinds is_rec sig_fn no_gen -- type of the thing whose rhs we are type checking tcMatchesFun name inf matches rhs_ty - ; return (unitBag (origin, - L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf, - fun_matches = matches', bind_fvs = fvs, - fun_co_fn = co_fn, fun_tick = Nothing })), + ; return (unitBag $ L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf, + fun_matches = matches', bind_fvs = fvs, + fun_co_fn = co_fn, fun_tick = Nothing }), [(name, Nothing, mono_id)]) } tcMonoBinds _ sig_fn no_gen binds - = do { tc_binds <- mapM (wrapOriginLocM (tcLhs sig_fn no_gen)) binds + = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds -- Bring the monomorphic Ids, into scope for the RHSs - ; let mono_info = getMonoBindInfo (map snd tc_binds) + ; let mono_info = getMonoBindInfo tc_binds rhs_id_env = [(name,mono_id) | (name, Nothing, mono_id) <- mono_info] -- A monomorphic binding for each term variable that lacks -- a type sig. (Ones with a sig are already in scope.) @@ -1034,7 +1094,7 @@ tcMonoBinds _ sig_fn no_gen binds ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id) | (n,id) <- rhs_id_env] ; binds' <- tcExtendIdEnv2 rhs_id_env $ - mapM (wrapOriginLocM tcRhs) tc_binds + mapM (wrapLocM tcRhs) tc_binds ; return (listToBag binds', mono_info) } ------------------------ @@ -1266,7 +1326,7 @@ data GeneralisationPlan Bool -- True <=> bindings mention only variables with closed types -- See Note [Bindings with closed types] in TcRnTypes - | CheckGen (Origin, LHsBind Name) TcSigInfo + | CheckGen (LHsBind Name) TcSigInfo -- One binding with a signature -- Explicit generalisation; there is an AbsBinds @@ -1280,7 +1340,7 @@ instance Outputable GeneralisationPlan where decideGeneralisationPlan :: DynFlags -> TcTypeEnv -> [Name] - -> [(Origin, LHsBind Name)] -> TcSigFun -> GeneralisationPlan + -> [LHsBind Name] -> TcSigFun -> GeneralisationPlan decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn | strict_pat_binds = NoGen | Just (lbind, sig) <- one_funbind_with_sig lbinds = CheckGen lbind sig @@ -1289,7 +1349,7 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn where bndr_set = mkNameSet bndr_names - binds = map (unLoc . snd) lbinds + binds = map unLoc lbinds strict_pat_binds = any isStrictHsBind binds -- Strict patterns (top level bang or unboxed tuple) must not @@ -1330,7 +1390,7 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn -- With OutsideIn, all nested bindings are monomorphic -- except a single function binding with a signature - one_funbind_with_sig [lbind@(_, L _ (FunBind { fun_id = v }))] + one_funbind_with_sig [lbind@(L _ (FunBind { fun_id = v }))] = case sig_fn (unLoc v) of Nothing -> Nothing Just sig -> Just (lbind, sig) @@ -1352,7 +1412,7 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn ------------------- checkStrictBinds :: TopLevelFlag -> RecFlag - -> [(Origin, LHsBind Name)] + -> [LHsBind Name] -> LHsBinds TcId -> [Id] -> TcM () -- Check that non-overloaded unlifted bindings are @@ -1391,31 +1451,31 @@ checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids return () where unlifted_bndrs = any is_unlifted poly_ids - any_strict_pat = any (isStrictHsBind . unLoc . snd) orig_binds - any_pat_looks_lazy = any (looksLazyPatBind . unLoc . snd) orig_binds + any_strict_pat = any (isStrictHsBind . unLoc) orig_binds + any_pat_looks_lazy = any (looksLazyPatBind . unLoc) orig_binds - is_unlifted id = case tcSplitForAllTys (idType id) of - (_, rho) -> isUnLiftedType rho + is_unlifted id = case tcSplitSigmaTy (idType id) of + (_, _, rho) -> isUnLiftedType rho - is_monomorphic (_, (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))) + is_monomorphic (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })) = null tvs && null evs is_monomorphic _ = True -unliftedMustBeBang :: [(Origin, LHsBind Name)] -> SDoc +unliftedMustBeBang :: [LHsBind Name] -> SDoc unliftedMustBeBang binds = hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:") - 2 (vcat (map (ppr . snd) binds)) + 2 (vcat (map ppr binds)) -polyBindErr :: [(Origin, LHsBind Name)] -> SDoc +polyBindErr :: [LHsBind Name] -> SDoc polyBindErr binds = hang (ptext (sLit "You can't mix polymorphic and unlifted bindings")) - 2 (vcat [vcat (map (ppr . snd) binds), + 2 (vcat [vcat (map ppr binds), ptext (sLit "Probable fix: use a bang pattern")]) -strictBindErr :: String -> Bool -> [(Origin, LHsBind Name)] -> SDoc +strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc strictBindErr flavour unlifted_bndrs binds = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:")) - 2 (vcat (map (ppr . snd) binds)) + 2 (vcat (map ppr binds)) where msg | unlifted_bndrs = ptext (sLit "bindings for unlifted types") | otherwise = ptext (sLit "bang-pattern or unboxed-tuple bindings") diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index cc53d03d47..d58d5db40f 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -1,4 +1,6 @@ \begin{code} +{-# LANGUAGE CPP #-} + module TcCanonical( canonicalize, emitWorkNC, StopOrContinue (..) @@ -492,13 +494,21 @@ flatten f ctxt (FunTy ty1 ty2) ; return (mkFunTy xi1 xi2, mkTcFunCo Nominal co1 co2) } flatten f ctxt (TyConApp tc tys) + + -- Expand type synonyms that mention type families + -- on the RHS; see Note [Flattening synonyms] + | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys + , any isSynFamilyTyCon (tyConsOfType rhs) + = flatten f ctxt (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') + -- For * a normal data type application - -- * type synonym application See Note [Flattening synonyms] -- * data family application + -- * type synonym application whose RHS does not mention type families + -- See Note [Flattening synonyms] -- we just recursively flatten the arguments. | not (isSynFamilyTyCon tc) - = do { (xis,cos) <- flattenMany f ctxt tys - ; return (mkTyConApp tc xis, mkTcTyConAppCo Nominal tc cos) } + = do { (xis,cos) <- flattenMany f ctxt tys + ; return (mkTyConApp tc xis, mkTcTyConAppCo Nominal tc cos) } -- Otherwise, it's a type function application, and we have to -- flatten it away as well, and generate a new given equality constraint @@ -534,6 +544,9 @@ flatten _f ctxt ty@(ForAllTy {}) Note [Flattening synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~ +Not expanding synonyms aggressively improves error messages, and +keeps types smaller. But we need to take care. + Suppose type T a = a -> a and we want to flatten the type (T (F a)). Then we can safely flatten @@ -541,12 +554,16 @@ the (F a) to a skolem, and return (T fsk). We don't need to expand the synonym. This works because TcTyConAppCo can deal with synonyms (unlike TyConAppCo), see Note [TcCoercions] in TcEvidence. -Not expanding synonyms aggressively improves error messages. +But (Trac #8979) for + type T a = (F a, a) where F is a type function +we must expand the synonym in (say) T Int, to expose the type function +to the flattener. + Note [Flattening under a forall] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Under a forall, we - (a) MUST apply the inert subsitution + (a) MUST apply the inert substitution (b) MUST NOT flatten type family applications Hence FMSubstOnly. @@ -1169,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 @@ -1245,7 +1265,7 @@ checkKind new_ev s1 k1 s2 k2 -- See Note [Equalities with incompatible kinds] do { traceTcS "canEqLeaf: incompatible kinds" (vcat [ppr k1, ppr k2]) -- Create a derived kind-equality, and solve it - ; mw <- newDerived kind_co_loc (mkEqPred k1 k2) + ; mw <- newDerived kind_co_loc (mkTcEqPred k1 k2) ; case mw of Nothing -> return () Just kev -> emitWorkNC [kev] diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 6fc2213cbc..be5a74f294 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -6,7 +6,8 @@ Typechecking class declarations \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -121,7 +122,7 @@ tcClassSigs clas sigs def_methods vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig nm ty) <- sigs] gen_sigs = [L loc (nm,ty) | L loc (GenericSig nm ty) <- sigs] dm_bind_names :: [Name] -- These ones have a value binding in the class decl - dm_bind_names = [op | (_, L _ (FunBind {fun_id = L _ op})) <- bagToList def_methods] + dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] tc_sig genop_env (op_names, op_hs_ty) = do { traceTc "ClsSig 1" (ppr op_names) @@ -238,18 +239,18 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn (sel_id, dm_info) --------------- tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar] -> Id -> TcSigInfo - -> TcSpecPrags -> (Origin, LHsBind Name) - -> TcM (Origin, LHsBind Id) + -> TcSpecPrags -> LHsBind Name + -> TcM (LHsBind Id) tcInstanceMethodBody skol_info tyvars dfun_ev_vars meth_id local_meth_sig - specs (origin, (L loc bind)) + specs (L loc bind) = do { let local_meth_id = sig_id local_meth_sig lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) }) -- Substitute the local_meth_name for the binder -- NB: the binding is always a FunBind ; (ev_binds, (tc_bind, _, _)) <- checkConstraints skol_info tyvars dfun_ev_vars $ - tcPolyCheck NonRecursive no_prag_fn local_meth_sig (origin, lm_bind) + tcPolyCheck NonRecursive no_prag_fn local_meth_sig lm_bind ; let export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id , abe_mono = local_meth_id, abe_prags = specs } @@ -258,7 +259,7 @@ tcInstanceMethodBody skol_info tyvars dfun_ev_vars , abs_ev_binds = ev_binds , abs_binds = tc_bind } - ; return (origin, L loc full_bind) } + ; return (L loc full_bind) } where no_prag_fn _ = [] -- No pragmas for local_meth_id; -- they are all for meth_id @@ -326,14 +327,14 @@ lookupHsSig = lookupNameEnv --------------------------- findMethodBind :: Name -- Selector name -> LHsBinds Name -- A group of bindings - -> Maybe ((Origin, LHsBind Name), SrcSpan) + -> Maybe (LHsBind Name, SrcSpan) -- Returns the binding, and the binding -- site of the method binder findMethodBind sel_name binds = foldlBag mplus Nothing (mapBag f binds) - where - f bind@(_, L _ (FunBind { fun_id = L bndr_loc op_name })) - | op_name == sel_name + where + f bind@(L _ (FunBind { fun_id = L bndr_loc op_name })) + | op_name == sel_name = Just (bind, bndr_loc) f _other = Nothing diff --git a/compiler/typecheck/TcDefaults.lhs b/compiler/typecheck/TcDefaults.lhs index d05a9485f8..7b5bd27321 100644 --- a/compiler/typecheck/TcDefaults.lhs +++ b/compiler/typecheck/TcDefaults.lhs @@ -5,7 +5,7 @@ \section[TcDefaults]{Typechecking \tr{default} declarations} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -39,7 +39,7 @@ tcDefaults :: [LDefaultDecl Name] tcDefaults [] = getDeclaredDefaultTys -- No default declaration, so get the -- default types from the envt; - -- i.e. use the curent ones + -- i.e. use the current ones -- (the caller will put them back there) -- It's important not to return defaultDefaultTys here (which -- we used to do) because in a TH program, tcDefaults [] is called diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 1e19bd4bd6..6812ac7387 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -6,6 +6,8 @@ Handles @deriving@ clauses on @data@ declarations. \begin{code} +{-# LANGUAGE CPP #-} + module TcDeriv ( tcDeriving ) where #include "HsVersions.h" @@ -18,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 @@ -60,7 +62,6 @@ import Outputable import FastString import Bag import Pair -import BasicTypes (Origin(..)) import Control.Monad import Data.List @@ -85,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 @@ -105,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} @@ -158,6 +160,10 @@ earlyDSLoc :: EarlyDerivSpec -> SrcSpan earlyDSLoc (InferTheta spec) = ds_loc spec earlyDSLoc (GivenTheta spec) = ds_loc spec +earlyDSClass :: EarlyDerivSpec -> Class +earlyDSClass (InferTheta spec) = ds_cls spec +earlyDSClass (GivenTheta spec) = ds_cls spec + splitEarlyDerivSpec :: [EarlyDerivSpec] -> ([DerivSpec ThetaOrigin], [DerivSpec ThetaType]) splitEarlyDerivSpec [] = ([],[]) splitEarlyDerivSpec (InferTheta spec : specs) = @@ -437,7 +443,7 @@ commonAuxiliaries = foldM snoc ([], emptyBag) where renameDeriv :: Bool -> [InstInfo RdrName] - -> Bag ((Origin, LHsBind RdrName), LSig RdrName) + -> Bag (LHsBind RdrName, LSig RdrName) -> TcM (Bag (InstInfo Name), HsValBinds Name, DefUses) renameDeriv is_boot inst_infos bagBinds | is_boot -- If we are compiling a hs-boot file, don't generate any derived bindings @@ -524,66 +530,60 @@ makeDerivSpecs :: Bool -> [LDerivDecl Name] -> TcM [EarlyDerivSpec] makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls - = do { eqns1 <- concatMapM (recoverM (return []) . deriveTyDecl) tycl_decls - ; eqns2 <- concatMapM (recoverM (return []) . deriveInstDecl) inst_decls - ; eqns3 <- mapAndRecoverM deriveStandalone deriv_decls - ; let eqns = eqns1 ++ eqns2 ++ eqns3 + = do { eqns1 <- concatMapM (recoverM (return []) . deriveTyDecl) tycl_decls + ; eqns2 <- concatMapM (recoverM (return []) . deriveInstDecl) inst_decls + ; eqns3 <- concatMapM (recoverM (return []) . deriveStandalone) deriv_decls -- If AutoDeriveTypeable is set, we automatically add Typeable instances -- for every data type and type class declared in the module - ; isAutoTypeable <- xoptM Opt_AutoDeriveTypeable - ; let eqns4 = if isAutoTypeable then deriveTypeable tycl_decls eqns else [] - ; eqns4' <- mapAndRecoverM deriveStandalone eqns4 - ; let eqns' = eqns ++ eqns4' + ; auto_typeable <- xoptM Opt_AutoDeriveTypeable + ; eqns4 <- deriveAutoTypeable auto_typeable (eqns1 ++ eqns3) tycl_decls + + ; let eqns = eqns1 ++ eqns2 ++ eqns3 ++ eqns4 ; if is_boot then -- No 'deriving' at all in hs-boot files - do { unless (null eqns') (add_deriv_err (head eqns')) + do { unless (null eqns) (add_deriv_err (head eqns)) ; return [] } - else return eqns' } + else return eqns } where - deriveTypeable :: [LTyClDecl Name] -> [EarlyDerivSpec] -> [LDerivDecl Name] - deriveTypeable tys dss = - [ L l (DerivDecl (L l (HsAppTy (noLoc (HsTyVar typeableClassName)) - (L l (HsTyVar (tcdName t)))))) - | L l t <- tys - -- Don't add Typeable instances for type synonyms and type families - , not (isSynDecl t), not (isTypeFamilyDecl t) - -- ... nor if the user has already given a deriving clause - , not (hasInstance (tcdName t) dss) ] - - -- Check if an automatically generated DS for deriving Typeable should be - -- ommitted because the user had manually requested for an instance - hasInstance :: Name -> [EarlyDerivSpec] -> Bool - hasInstance n = any (\ds -> n == tyConName (earlyDSTyCon ds)) - add_deriv_err eqn = setSrcSpan (earlyDSLoc eqn) $ addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file")) 2 (ptext (sLit "Use an instance declaration instead"))) +deriveAutoTypeable :: Bool -> [EarlyDerivSpec] -> [LTyClDecl Name] -> TcM [EarlyDerivSpec] +-- Runs over *all* TyCl declarations, including classes and data families +-- i.e. not just data type decls +deriveAutoTypeable auto_typeable done_specs tycl_decls + | not auto_typeable = return [] + | otherwise = do { cls <- tcLookupClass typeableClassName + ; concatMapM (do_one cls) tycl_decls } + where + done_tcs = mkNameSet [ tyConName (earlyDSTyCon spec) + | spec <- done_specs + , className (earlyDSClass spec) == typeableClassName ] + -- Check if an automatically generated DS for deriving Typeable should be + -- ommitted because the user had manually requested an instance + + do_one cls (L _ decl) + = do { tc <- tcLookupTyCon (tcdName decl) + ; if (isSynTyCon tc || tyConName tc `elemNameSet` done_tcs) + -- Do not derive Typeable for type synonyms or type families + then return [] + else mkPolyKindedTypeableEqn cls tc } + ------------------------------------------------------------------ deriveTyDecl :: LTyClDecl Name -> TcM [EarlyDerivSpec] -deriveTyDecl (L _ decl@(DataDecl { tcdLName = L loc tc_name +deriveTyDecl (L _ decl@(DataDecl { tcdLName = L _ tc_name , tcdDataDefn = HsDataDefn { dd_derivs = preds } })) = tcAddDeclCtxt decl $ do { tc <- tcLookupTyCon tc_name ; let tvs = tyConTyVars tc tys = mkTyVarTys tvs - pdcs :: [LDerivDecl Name] - pdcs = [ L loc (DerivDecl (L loc (HsAppTy (noLoc (HsTyVar typeableClassName)) - (L loc (HsTyVar (tyConName pdc)))))) - | Just pdc <- map promoteDataCon_maybe (tyConDataCons tc) ] - -- If AutoDeriveTypeable and DataKinds is set, we add Typeable instances - -- for every promoted data constructor of datatypes in this module - ; isAutoTypeable <- xoptM Opt_AutoDeriveTypeable - ; isDataKinds <- xoptM Opt_DataKinds - ; prom_dcs_Typeable_instances <- if isAutoTypeable && isDataKinds - then mapM deriveStandalone pdcs - else return [] - ; other_instances <- case preds of - Just preds' -> mapM (deriveTyData tvs tc tys) preds' - Nothing -> return [] - ; return (prom_dcs_Typeable_instances ++ other_instances) } + + ; case preds of + Just preds' -> concatMapM (deriveTyData False tvs tc tys) preds' + Nothing -> return [] } deriveTyDecl _ = return [] @@ -598,32 +598,49 @@ 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' _ -> - mapM (deriveTyData tvs' fam_tc pats') preds } - -- Tiresomely we must figure out the "lhs", which is awkward for type families - -- E.g. data T a b = .. deriving( Eq ) - -- Here, the lhs is (T a b) - -- 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. + concatMapM (deriveTyData True tvs' fam_tc pats') preds } 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 +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) - ; (tvs, theta, cls, inst_tys) <- tcHsInstHead TcType.InstDeclCtxt deriv_ty + ; (tvs, theta, cls, inst_tys) <- setXOptM Opt_DataKinds $ -- for polykinded typeable + tcHsInstHead TcType.InstDeclCtxt deriv_ty ; traceTc "Standalone deriving;" $ vcat [ text "tvs:" <+> ppr tvs , text "theta:" <+> ppr theta @@ -640,26 +657,74 @@ deriveStandalone (L loc (DerivDecl deriv_ty)) , text "type:" <+> ppr inst_ty ] ; case tcSplitTyConApp_maybe inst_ty of - Just (tycon, tc_args) - | className cls == typeableClassName || isAlgTyCon tycon - -> mkEqnHelp tvs cls cls_tys tycon tc_args (Just theta) + Just (tc, tc_args) + | className cls == typeableClassName -- Works for algebraic TyCons + -- _and_ data families + -> do { check_standalone_typeable theta tc tc_args + ; mkPolyKindedTypeableEqn cls tc } + + | isAlgTyCon tc -- All other classes + -> do { spec <- mkEqnHelp overlap_mode tvs cls cls_tys tc tc_args (Just theta) + ; return [spec] } _ -> -- Complain about functions, primitive types, etc, -- except for the Typeable class failWithTc $ derivingThingErr False cls cls_tys inst_ty $ ptext (sLit "The last argument of the instance must be a data or newtype application") } + where + check_standalone_typeable theta tc tc_args + -- We expect to see + -- deriving Typeable <kind> T + -- for some tycon T. But if S is kind-polymorphic, + -- say (S :: forall k. k -> *), we might see + -- deriving Typable <kind> (S k) + -- + -- But we should NOT see + -- deriving Typeable <kind> (T Int) + -- or deriving Typeable <kind> (S *) where S is kind-polymorphic + -- + -- So all the tc_args should be distinct kind variables + | null theta + , allDistinctTyVars tc_args + , all is_kind_var tc_args + = return () + + | otherwise + = do { polykinds <- xoptM Opt_PolyKinds + ; failWith (mk_msg polykinds theta tc tc_args) } + + is_kind_var tc_arg = case tcGetTyVar_maybe tc_arg of + Just v -> isKindVar v + Nothing -> False + + mk_msg polykinds theta tc tc_args + | not polykinds + , all isKind tc_args -- Non-empty, all kinds, at least one not a kind variable + , null theta + = hang (ptext (sLit "To make a Typeable instance of poly-kinded") + <+> quotes (ppr tc) <> comma) + 2 (ptext (sLit "use XPolyKinds")) + + | otherwise + = hang (ptext (sLit "Derived Typeable instance must be of form")) + 2 (ptext (sLit "deriving instance Typeable") <+> ppr tc) + ------------------------------------------------------------------ -deriveTyData :: [TyVar] -> TyCon -> [Type] -- LHS of data or data instance +deriveTyData :: Bool -- False <=> data/newtype + -- True <=> data/newtype *instance* + -> [TyVar] -> TyCon -> [Type] -- LHS of data or data instance -- Can be a data instance, hence [Type] args -> LHsType Name -- The deriving predicate - -> TcM EarlyDerivSpec + -> TcM [EarlyDerivSpec] -- The deriving clause of a data or newtype declaration -deriveTyData tvs tc tc_args (L loc deriv_pred) +-- I.e. not standalone deriving +deriveTyData is_instance tvs tc tc_args (L loc deriv_pred) = setSrcSpan loc $ -- Use the location of the 'deriving' item - do { (deriv_tvs, cls, cls_tys) <- tcExtendTyVarEnv tvs $ - tcHsDeriv deriv_pred + do { (deriv_tvs, cls, cls_tys, cls_arg_kind) + <- tcExtendTyVarEnv tvs $ + tcHsDeriv deriv_pred -- Deriving preds may (now) mention -- the type variables for the type constructor, hence tcExtendTyVarenv -- The "deriv_pred" is a LHsType to take account of the fact that for @@ -669,16 +734,12 @@ deriveTyData tvs tc tc_args (L loc deriv_pred) -- so the argument kind 'k' is not decomposable by splitKindFunTys -- as is the case for all other derivable type classes ; if className cls == typeableClassName - then derivePolyKindedTypeable cls cls_tys tvs tc tc_args - else do { - - -- Given data T a b c = ... deriving( C d ), - -- we want to drop type variables from T so that (C d (T a)) is well-kinded - ; let cls_tyvars = classTyVars cls - ; checkTc (not (null cls_tyvars)) derivingNullaryErr + then derivePolyKindedTypeable is_instance cls cls_tys tvs tc tc_args + else - ; let cls_arg_kind = tyVarKind (last cls_tyvars) - (arg_kinds, _) = splitKindFunTys cls_arg_kind + do { -- Given data T a b c = ... deriving( C d ), + -- we want to drop type variables from T so that (C d (T a)) is well-kinded + let (arg_kinds, _) = splitKindFunTys cls_arg_kind n_args_to_drop = length arg_kinds n_args_to_keep = tyConArity tc - n_args_to_drop args_to_drop = drop n_args_to_keep tc_args @@ -690,9 +751,9 @@ deriveTyData tvs tc tc_args (L loc deriv_pred) -- to the types. See Note [Unify kinds in deriving] -- We are assuming the tycon tyvars and the class tyvars are distinct mb_match = tcUnifyTy inst_ty_kind cls_arg_kind - Just kind_subst = mb_match + Just kind_subst = mb_match (univ_kvs, univ_tvs) = partition isKindVar $ varSetElems $ - mkVarSet deriv_tvs `unionVarSet` + mkVarSet deriv_tvs `unionVarSet` tyVarsOfTypes tc_args_to_keep univ_kvs' = filter (`notElemTvSubst` kind_subst) univ_kvs (subst', univ_tvs') = mapAccumL substTyVarBndr kind_subst univ_tvs @@ -725,33 +786,29 @@ deriveTyData tvs tc tc_args (L loc deriv_pred) -- newtype T a s = ... deriving( ST s ) -- newtype K a a = ... deriving( Monad ) - ; mkEqnHelp (univ_kvs' ++ univ_tvs') - cls final_cls_tys tc final_tc_args Nothing } } + ; spec <- mkEqnHelp Nothing (univ_kvs' ++ univ_tvs') + cls final_cls_tys tc final_tc_args Nothing + ; return [spec] } } -derivePolyKindedTypeable :: Class -> [Type] +derivePolyKindedTypeable :: Bool -> Class -> [Type] -> [TyVar] -> TyCon -> [Type] - -> TcM EarlyDerivSpec -derivePolyKindedTypeable cls cls_tys _tvs tc tc_args - = do { checkTc (isSingleton cls_tys) $ -- Typeable k + -> TcM [EarlyDerivSpec] +-- The deriving( Typeable ) clause of a data/newtype decl +-- I.e. not standalone deriving +derivePolyKindedTypeable is_instance cls cls_tys _tvs tc tc_args + | is_instance + = failWith (sep [ ptext (sLit "Deriving Typeable is not allowed for family instances;") + , ptext (sLit "derive Typeable for") + <+> quotes (pprSourceTyCon tc) + <+> ptext (sLit "alone") ]) + + | otherwise + = ASSERT( allDistinctTyVars tc_args ) -- Came from a data/newtype decl + do { checkTc (isSingleton cls_tys) $ -- Typeable k derivingThingErr False cls cls_tys (mkTyConApp tc tc_args) (classArgsErr cls cls_tys) - -- Check that we have not said, for example - -- deriving Typeable (T Int) - -- or deriving Typeable (S :: * -> *) where S is kind-polymorphic - ; checkTc (allDistinctTyVars tc_args) $ - derivingEtaErr cls cls_tys (mkTyConApp tc tc_kind_args) - - ; mkEqnHelp kind_vars cls cls_tys tc tc_kind_args Nothing } - where - kind_vars = kindVarsOnly tc_args - tc_kind_args = mkTyVarTys kind_vars - - kindVarsOnly :: [Type] -> [KindVar] - kindVarsOnly [] = [] - kindVarsOnly (t:ts) | Just v <- getTyVar_maybe t - , isKindVar v = v : kindVarsOnly ts - | otherwise = kindVarsOnly ts + ; mkPolyKindedTypeableEqn cls tc } \end{code} Note [Unify kinds in deriving] @@ -811,7 +868,8 @@ and occurrence sites. \begin{code} -mkEqnHelp :: [TyVar] +mkEqnHelp :: Maybe OverlapMode + -> [TyVar] -> Class -> [Type] -> TyCon -> [Type] -> DerivContext -- Just => context supplied (standalone deriving) @@ -822,18 +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 } - - | className cls == typeableClassName -- Polykinded Typeable - = do { dflags <- getDynFlags - ; case checkTypeableConditions (dflags, tycon, tc_args) of - Just err -> bale_out err - Nothing -> mkPolyKindedTypeableEqn 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 @@ -864,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) @@ -957,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 @@ -968,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 @@ -976,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 @@ -994,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 @@ -1002,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] @@ -1039,45 +1094,41 @@ 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 :: [TyVar] -> Class - -> TyCon -> [TcType] -> DerivContext - -> TcM EarlyDerivSpec +mkPolyKindedTypeableEqn :: Class -> TyCon -> TcM [EarlyDerivSpec] -- We can arrive here from a 'deriving' clause -- or from standalone deriving -mkPolyKindedTypeableEqn tvs cls tycon tc_args mtheta - = do { -- Check that we have not said, for example - -- deriving Typeable (T Int) - -- or deriving Typeable (S :: * -> *) where S is kind-polymorphic - - polykinds <- xoptM Opt_PolyKinds - ; checkTc (all is_kind_var tc_args) (mk_msg polykinds) - ; dfun_name <- new_dfun_name cls tycon - ; loc <- getSrcSpanM - ; let tc_app = mkTyConApp tycon tc_args - ; return (GivenTheta $ - DS { ds_loc = loc, ds_name = dfun_name - , ds_tvs = filter isKindVar tvs, ds_cls = cls - , ds_tys = typeKind tc_app : [tc_app] - -- Remember, Typeable :: forall k. k -> * - , ds_tc = tycon, ds_tc_args = tc_args - , ds_theta = mtheta `orElse` [] -- Context is empty for polykinded Typeable - , ds_newtype = False }) } +mkPolyKindedTypeableEqn cls tc + = do { dflags <- getDynFlags -- It's awkward to re-used checkFlag here, + ; checkTc(xopt Opt_DeriveDataTypeable dflags) -- so we do a DIY job + (hang (ptext (sLit "Can't make a Typeable instance of") <+> quotes (ppr tc)) + 2 (ptext (sLit "You need DeriveDataTypeable to derive Typeable instances"))) + + ; loc <- getSrcSpanM + ; let prom_dcs = mapMaybe promoteDataCon_maybe (tyConDataCons tc) + ; mapM (mk_one loc) (tc : prom_dcs) } where - is_kind_var tc_arg = case tcGetTyVar_maybe tc_arg of - Just v -> isKindVar v - Nothing -> False - - mk_msg polykinds | not polykinds - , all isKind tc_args -- Non-empty, all kinds, at least one not a kind variable - = hang (ptext (sLit "To make a Typeable instance of poly-kinded") - <+> quotes (ppr tycon) <> comma) - 2 (ptext (sLit "use XPolyKinds")) - | otherwise - = ptext (sLit "Derived Typeable instance must be of form") - <+> parens (ptext (sLit "Typeable") <+> ppr tycon) - + mk_one loc tc = do { traceTc "mkPolyKindedTypeableEqn" (ppr tc) + ; dfun_name <- new_dfun_name cls tc + ; return $ GivenTheta $ + DS { ds_loc = loc, ds_name = dfun_name + , ds_tvs = kvs, ds_cls = cls + , ds_tys = [tc_app_kind, tc_app] + -- Remember, Typeable :: forall k. k -> * + -- 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) + tc_args = mkTyVarTys kvs + tc_app = mkTyConApp tc tc_args inferConstraints :: Class -> [TcType] -> TyCon -> [TcType] @@ -1096,21 +1147,23 @@ inferConstraints cls inst_tys rep_tc rep_tc_args | otherwise -- The others are a bit more complicated = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc ) - return (stupid_constraints ++ extra_constraints - ++ sc_constraints - ++ con_arg_constraints cls get_std_constrained_tys) - + do { traceTc "inferConstraints" (vcat [ppr cls <+> ppr inst_tys, ppr arg_constraints]) + ; return (stupid_constraints ++ extra_constraints + ++ sc_constraints + ++ arg_constraints) } where + arg_constraints = con_arg_constraints cls get_std_constrained_tys + -- Constraints arising from the arguments of each constructor con_arg_constraints cls' get_constrained_tys - = [ mkPredOrigin (DerivOriginDC data_con arg_n) (mkClassPred cls' [arg_ty]) - | data_con <- tyConDataCons rep_tc, - (arg_n, arg_ty) <- - ASSERT( isVanillaDataCon data_con ) - zip [1..] $ -- ASSERT is precondition of dataConInstOrigArgTys - get_constrained_tys $ - dataConInstOrigArgTys data_con all_rep_tc_args, - not (isUnLiftedType arg_ty) ] + = [ mkPredOrigin (DerivOriginDC data_con arg_n) (mkClassPred cls' [inner_ty]) + | data_con <- tyConDataCons rep_tc + , (arg_n, arg_ty) <- ASSERT( isVanillaDataCon data_con ) + zip [1..] $ -- ASSERT is precondition of dataConInstOrigArgTys + dataConInstOrigArgTys data_con all_rep_tc_args + , not (isUnLiftedType arg_ty) + , inner_ty <- get_constrained_tys arg_ty ] + -- No constraints for unlifted types -- See Note [Deriving and unboxed types] @@ -1120,10 +1173,10 @@ inferConstraints cls inst_tys rep_tc rep_tc_args -- (b) The rep_tc_args will be one short is_functor_like = getUnique cls `elem` functorLikeClassKeys - get_std_constrained_tys :: [Type] -> [Type] - get_std_constrained_tys tys - | is_functor_like = concatMap (deepSubtypesContaining last_tv) tys - | otherwise = tys + get_std_constrained_tys :: Type -> [Type] + get_std_constrained_tys ty + | is_functor_like = deepSubtypesContaining last_tv ty + | otherwise = [ty] rep_tc_tvs = tyConTyVars rep_tc last_tv = last rep_tc_tvs @@ -1191,18 +1244,17 @@ 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 classArgsErr :: Class -> [Type] -> SDoc classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class") -checkTypeableConditions, checkOldTypeableConditions :: Condition -checkTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_TypeableOK +checkOldTypeableConditions :: Condition checkOldTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_oldTypeableOK nonStdErr :: Class -> SDoc @@ -1243,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 @@ -1252,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" @@ -1270,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) <+> @@ -1311,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 @@ -1333,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") @@ -1343,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") @@ -1354,30 +1403,16 @@ 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") bad_kind = quotes (pprSourceTyCon tc) <+> ptext (sLit "must only have arguments of kind `*'") -cond_TypeableOK :: Condition --- Only not ok if it's a data instance -cond_TypeableOK (_, tc, tc_args) - | isDataFamilyTyCon tc && not (null tc_args) - = Just no_families - - | otherwise - = Nothing - where - no_families = sep [ ptext (sLit "Deriving Typeable is not allowed for family instances;") - , ptext (sLit "derive Typeable for") - <+> quotes (pprSourceTyCon tc) - <+> ptext (sLit "alone") ] - functorLikeClassKeys :: [Unique] functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey] @@ -1390,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 @@ -1406,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") @@ -1432,20 +1467,10 @@ cond_functorOK allowFunctions (_, rep_tc, _) functions = ptext (sLit "must not contain function types") wrong_arg = ptext (sLit "must use the type variable only as the last argument of a data type") -allDistinctTyVars :: [KindOrType] -> Bool -allDistinctTyVars tkvs = go emptyVarSet tkvs - where - go _ [] = True - go so_far (ty : tys) - = case getTyVar_maybe ty of - Nothing -> False - Just tv | tv `elemVarSet` so_far -> False - | otherwise -> go (so_far `extendVarSet` tv) tys - 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") @@ -1543,14 +1568,15 @@ 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 ... - | might_derive_via_coercible && (newtype_deriving || std_class_via_coercible cls) + | ASSERT( length cls_tys + 1 == classArity cls ) + might_derive_via_coercible && (newtype_deriving || std_class_via_coercible cls) = do traceTc "newtype deriving:" (ppr tycon <+> ppr rep_tys <+> ppr all_preds) dfun_name <- new_dfun_name cls tycon loc <- getSrcSpanM @@ -1561,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 @@ -1568,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 @@ -1581,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 @@ -1677,15 +1705,10 @@ mkNewTypeEqn dflags tvs -- See Note [Determining whether newtype-deriving is appropriate] might_derive_via_coercible = not (non_coercible_class cls) - && arity_ok && eta_ok && ats_ok -- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes] - arity_ok = length cls_tys + 1 == classArity cls - -- Well kinded; eg not: newtype T ... deriving( ST ) - -- because ST needs *2* type params - -- Check that eta reduction is OK eta_ok = nt_eta_arity <= length rep_tc_args -- The newtype can be eta-reduced to match the number @@ -1701,13 +1724,10 @@ mkNewTypeEqn dflags tvs -- so for 'data' instance decls cant_derive_err - = vcat [ ppUnless arity_ok arity_msg - , ppUnless eta_ok eta_msg + = vcat [ ppUnless eta_ok eta_msg , ppUnless ats_ok ats_msg ] - arity_msg = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1") eta_msg = ptext (sLit "cannot eta-reduce the representation type enough") ats_msg = ptext (sLit "the class has associated types") - \end{code} Note [Recursive newtypes] @@ -2047,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 @@ -2068,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 @@ -2081,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 f3d754640f..f4c7c10063 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -3,7 +3,9 @@ % \begin{code} +{-# LANGUAGE CPP, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + module TcEnv( TyThing(..), TcTyThing(..), TcId, @@ -16,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, @@ -66,11 +68,13 @@ import TcIface import PrelNames import TysWiredIn import Id +import IdInfo( IdDetails(VanillaId) ) import Var import VarSet import RdrName import InstEnv -import DataCon +import DataCon ( DataCon ) +import PatSyn ( PatSyn ) import ConLike import TyCon import CoAxiom @@ -157,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 @@ -801,7 +812,7 @@ mkStableIdFromString str sig_ty loc occ_wrapper = do name <- mkWrapperName "stable" str let occ = mkVarOccFS name :: OccName gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name - id = mkExportedLocalId gnm sig_ty :: Id + id = mkExportedLocalId VanillaId gnm sig_ty :: Id return id mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId @@ -816,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 @@ -864,13 +875,16 @@ notFound name ptext (sLit "is not in scope during type checking, but it passed the renamer"), ptext (sLit "tcl_env of environment:") <+> ppr (tcl_env lcl_env)] -- Take case: printing the whole gbl env can - -- cause an infnite loop, in the case where we + -- cause an infinite loop, in the case where we -- are in the middle of a recursive TyCon/Class group; -- so let's just not print it! Getting a loop here is -- very unhelpful, because it hides one compiler bug with another } wrongThingErr :: String -> TcTyThing -> Name -> TcM a +-- It's important that this only calls pprTcTyThingCategory, which in +-- turn does not look at the details of the TcTyThing. +-- See Note [Placeholder PatSyn kinds] in TcBinds wrongThingErr expected thing name = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> ptext (sLit "used as a") <+> text expected) diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index df241c9596..c8f3d06997 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -1,6 +1,6 @@ \begin{code} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -48,7 +48,7 @@ import DynFlags import ListSetOps ( equivClasses ) import Data.Maybe -import Data.List ( partition, mapAccumL, zip4 ) +import Data.List ( partition, mapAccumL, zip4, nub ) \end{code} %************************************************************************ @@ -668,10 +668,11 @@ mkTyVarEqErr :: DynFlags -> ReportErrCtxt -> SDoc -> Ct -- tv1 and ty2 are already tidied mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2 | isUserSkolem ctxt tv1 -- ty2 won't be a meta-tyvar, or else the thing would - -- be oriented the other way round; see TcCanonical.reOrient + -- be oriented the other way round; + -- see TcCanonical.canEqTyVarTyVar || isSigTyVar tv1 && not (isTyVarTy ty2) = mkErrorMsg ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2 - , extraTyVarInfo ctxt ty1 ty2 + , extraTyVarInfo ctxt tv1 ty2 , extra ]) -- So tv is a meta tyvar (or started that way before we @@ -701,7 +702,7 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2 , Implic { ic_skols = skols } <- implic , tv1 `elem` skols = mkErrorMsg ctxt ct (vcat [ misMatchMsg oriented ty1 ty2 - , extraTyVarInfo ctxt ty1 ty2 + , extraTyVarInfo ctxt tv1 ty2 , extra ]) -- Check for skolem escape @@ -728,14 +729,15 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2 | (implic:_) <- cec_encl ctxt -- Get the innermost context , Implic { ic_env = env, ic_given = given, ic_info = skol_info } <- implic = do { let msg = misMatchMsg oriented ty1 ty2 - untch_extra + untch_extra = nest 2 $ sep [ quotes (ppr tv1) <+> ptext (sLit "is untouchable") , nest 2 $ ptext (sLit "inside the constraints") <+> pprEvVarTheta given , nest 2 $ ptext (sLit "bound by") <+> ppr skol_info , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ] - tv_extra = extraTyVarInfo ctxt ty1 ty2 - ; mkErrorMsg ctxt ct (vcat [msg, untch_extra, tv_extra, extra]) } + tv_extra = extraTyVarInfo ctxt tv1 ty2 + add_sig = suggestAddSig ctxt ty1 ty2 + ; mkErrorMsg ctxt ct (vcat [msg, untch_extra, tv_extra, add_sig, extra]) } | otherwise = reportEqErr ctxt extra ct oriented (mkTyVarTy tv1) ty2 @@ -792,7 +794,7 @@ misMatchOrCND ctxt ct oriented ty1 ty2 -- or there is no context, don't report the context = misMatchMsg oriented ty1 ty2 | otherwise - = couldNotDeduce givens ([mkEqPred ty1 ty2], orig) + = couldNotDeduce givens ([mkTcEqPred ty1 ty2], orig) where givens = getUserGivens ctxt orig = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 } @@ -814,30 +816,46 @@ pp_givens givens 2 (sep [ ptext (sLit "bound by") <+> ppr skol_info , ptext (sLit "at") <+> ppr loc]) -extraTyVarInfo :: ReportErrCtxt -> TcType -> TcType -> SDoc --- Add on extra info about the types themselves +extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc +-- Add on extra info about skolem constants -- NB: The types themselves are already tidied -extraTyVarInfo ctxt ty1 ty2 - = nest 2 (extra1 $$ extra2) +extraTyVarInfo ctxt tv1 ty2 + = nest 2 (tv_extra tv1 $$ ty_extra ty2) where - extra1 = tyVarExtraInfoMsg (cec_encl ctxt) ty1 - extra2 = tyVarExtraInfoMsg (cec_encl ctxt) ty2 - -tyVarExtraInfoMsg :: [Implication] -> Type -> SDoc --- Shows a bit of extra info about skolem constants -tyVarExtraInfoMsg implics ty - | Just tv <- tcGetTyVar_maybe ty - , isTcTyVar tv, isSkolemTyVar tv - , let pp_tv = quotes (ppr tv) - = case tcTyVarDetails tv of - SkolemTv {} -> pp_tv <+> pprSkol (getSkolemInfo implics tv) (getSrcLoc tv) - FlatSkol {} -> pp_tv <+> ptext (sLit "is a flattening type variable") - RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem") - MetaTv {} -> empty - - | otherwise -- Normal case - = empty - + implics = cec_encl ctxt + ty_extra ty = case tcGetTyVar_maybe ty of + Just tv -> tv_extra tv + Nothing -> empty + + tv_extra tv | isTcTyVar tv, isSkolemTyVar tv + , let pp_tv = quotes (ppr tv) + = case tcTyVarDetails tv of + SkolemTv {} -> pp_tv <+> pprSkol (getSkolemInfo implics tv) (getSrcLoc tv) + FlatSkol {} -> pp_tv <+> ptext (sLit "is a flattening type variable") + RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem") + MetaTv {} -> empty + + | otherwise -- Normal case + = empty + +suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> SDoc +-- See Note [Suggest adding a type signature] +suggestAddSig ctxt ty1 ty2 + | null inferred_bndrs + = empty + | [bndr] <- inferred_bndrs + = ptext (sLit "Possible fix: add a type signature for") <+> quotes (ppr bndr) + | otherwise + = ptext (sLit "Possible fix: add type signatures for some or all of") <+> (ppr inferred_bndrs) + where + inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2) + get_inf ty | Just tv <- tcGetTyVar_maybe ty + , isTcTyVar tv, isSkolemTyVar tv + , InferSkol prs <- getSkolemInfo (cec_encl ctxt) tv + = map fst prs + | otherwise + = [] + kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy kindErrorMsg ty1 ty2 = vcat [ ptext (sLit "Kind incompatibility when matching types:") @@ -885,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) @@ -899,14 +917,31 @@ 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} +Note [Suggest adding a type signature] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The OutsideIn algorithm rejects GADT programs that don't have a principal +type, and indeed some that do. Example: + data T a where + MkT :: Int -> T Int + + f (MkT n) = n + +Does this have type f :: T a -> a, or f :: T a -> Int? +The error that shows up tends to be an attempt to unify an +untouchable type variable. So suggestAddSig sees if the offending +type variable is bound by an *inferred* signature, and suggests +adding a declared signature instead. + +This initially came up in Trac #8968, concerning pattern synonyms. + Note [Disambiguating (X ~ X) errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See Trac #8278 @@ -1052,8 +1087,9 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell)) no_inst_msg | clas == coercibleClass = let (ty1, ty2) = getEqPredTys pred - in ptext (sLit "Could not coerce from") <+> quotes (ppr ty1) <+> - ptext (sLit "to") <+> quotes (ppr ty2) + in sep [ ptext (sLit "Could not coerce from") <+> quotes (ppr ty1) + , nest 19 (ptext (sLit "to") <+> quotes (ppr ty2)) ] + -- The nesting makes the types line up | null givens && null matches = ptext (sLit "No instance for") <+> pprParendType pred | otherwise @@ -1161,9 +1197,9 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell)) Just msg <- coercible_msg_for_tycon rdr_env tc = msg | otherwise - = nest 2 $ hsep [ ptext $ sLit "because", quotes (ppr ty1), - ptext $ sLit "and", quotes (ppr ty2), - ptext $ sLit "are different types." ] + = nest 2 $ sep [ ptext (sLit "because") <+> quotes (ppr ty1) + , nest 4 (vcat [ ptext (sLit "and") <+> quotes (ppr ty2) + , ptext (sLit "are different types.") ]) ] where (ty1, ty2) = getEqPredTys pred @@ -1253,29 +1289,51 @@ flattening any further. After all, there can be no instance declarations that match such things. And flattening under a for-all is problematic anyway; consider C (forall a. F a) +Note [Suggest -fprint-explicit-kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It can be terribly confusing to get an error message like (Trac #9171) + Couldn't match expected type ‘GetParam Base (GetParam Base Int)’ + with actual type ‘GetParam Base (GetParam Base Int)’ +The reason may be that the kinds don't match up. Typically you'll get +more useful information, but not when it's as a result of ambiguity. +This test suggests -fprint-explicit-kinds when all the ambiguous type +variables are kind variables. + \begin{code} mkAmbigMsg :: Ct -> (Bool, SDoc) mkAmbigMsg ct - | isEmptyVarSet ambig_tv_set = (False, empty) - | otherwise = (True, msg) + | null ambig_tkvs = (False, empty) + | otherwise = (True, msg) where - ambig_tv_set = filterVarSet isAmbiguousTyVar (tyVarsOfCt ct) - ambig_tvs = varSetElems ambig_tv_set - - is_or_are | isSingleton ambig_tvs = text "is" - | otherwise = text "are" - - msg | any isRuntimeUnkSkol ambig_tvs -- See Note [Runtime skolems] + ambig_tkv_set = filterVarSet isAmbiguousTyVar (tyVarsOfCt ct) + ambig_tkvs = varSetElems ambig_tkv_set + (ambig_kvs, ambig_tvs) = partition isKindVar ambig_tkvs + + msg | any isRuntimeUnkSkol ambig_tkvs -- See Note [Runtime skolems] = vcat [ ptext (sLit "Cannot resolve unknown runtime type") <> plural ambig_tvs <+> pprQuotedList ambig_tvs , ptext (sLit "Use :print or :force to determine these types")] - | otherwise - = vcat [ text "The type variable" <> plural ambig_tvs - <+> pprQuotedList ambig_tvs - <+> is_or_are <+> text "ambiguous" ] + + | not (null ambig_tvs) + = pp_ambig (ptext (sLit "type")) ambig_tvs + + | otherwise -- All ambiguous kind variabes; suggest -fprint-explicit-kinds + = vcat [ pp_ambig (ptext (sLit "kind")) ambig_kvs + , sdocWithDynFlags suggest_explicit_kinds ] + + pp_ambig what tkvs + = ptext (sLit "The") <+> what <+> ptext (sLit "variable") <> plural tkvs + <+> pprQuotedList tkvs <+> is_or_are tkvs <+> ptext (sLit "ambiguous") + + is_or_are [_] = text "is" + is_or_are _ = text "are" + + suggest_explicit_kinds dflags -- See Note [Suggest -fprint-explicit-kinds] + | gopt Opt_PrintExplicitKinds dflags = empty + | otherwise = ptext (sLit "Use -fprint-explicit-kinds to see the kind arguments") pprSkol :: SkolemInfo -> SrcLoc -> SDoc -pprSkol UnkSkol _ +pprSkol UnkSkol _ = ptext (sLit "is an unknown type variable") pprSkol skol_info tv_loc = sep [ ptext (sLit "is a rigid type variable bound by"), diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs index a31f66adaa..7fc6194b8f 100644 --- a/compiler/typecheck/TcEvidence.lhs +++ b/compiler/typecheck/TcEvidence.lhs @@ -3,6 +3,8 @@ % \begin{code} +{-# LANGUAGE CPP, DeriveDataTypeable #-} + module TcEvidence ( -- HsWrapper @@ -351,7 +353,7 @@ pprTcCo, pprParendTcCo :: TcCoercion -> SDoc pprTcCo co = ppr_co TopPrec co pprParendTcCo co = ppr_co TyConPrec co -ppr_co :: Prec -> TcCoercion -> SDoc +ppr_co :: TyPrec -> TcCoercion -> SDoc ppr_co _ (TcRefl r ty) = angleBrackets (ppr ty) <> ppr_role r ppr_co p co@(TcTyConAppCo _ tc [_,_]) @@ -404,7 +406,7 @@ ppr_role r = underscore <> pp_role Representational -> char 'R' Phantom -> char 'P' -ppr_fun_co :: Prec -> TcCoercion -> SDoc +ppr_fun_co :: TyPrec -> TcCoercion -> SDoc ppr_fun_co p co = pprArrowChain p (split co) where split :: TcCoercion -> [SDoc] @@ -413,7 +415,7 @@ ppr_fun_co p co = pprArrowChain p (split co) = ppr_co FunPrec arg : split res split co = [ppr_co TopPrec co] -ppr_forall_co :: Prec -> TcCoercion -> SDoc +ppr_forall_co :: TyPrec -> TcCoercion -> SDoc ppr_forall_co p ty = maybeParen p FunPrec $ sep [pprForAll tvs, ppr_co TopPrec rho] @@ -594,7 +596,7 @@ data EvTerm -- dictionaries, even though the former have no -- selector Id. We count up from _0_ - | EvLit EvLit -- Dictionary for KnownNat and KnownLit classes. + | EvLit EvLit -- Dictionary for KnownNat and KnownSymbol classes. -- Note [KnownNat & KnownSymbol and EvLit] deriving( Data.Data, Data.Typeable) @@ -651,7 +653,7 @@ Conclusion: a new wanted coercion variable should be made mutable. Note [KnownNat & KnownSymbol and EvLit] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A part of the type-level literals implementation are the classes -"KnownNat" and "KnownLit", which provide a "smart" constructor for +"KnownNat" and "KnownSymbol", which provide a "smart" constructor for defining singleton values. Here is the key stuff from GHC.TypeLits class KnownNat (n :: Nat) where @@ -692,7 +694,7 @@ especialy when the `KnowNat` evidence is packaged up in an existential. The story for kind `Symbol` is analogous: * class KnownSymbol - * newypte SSymbol + * newtype SSymbol * Evidence: EvLit (EvStr n) diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 3397b0836a..7e6c495506 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -5,6 +5,8 @@ c% \section[TcExpr]{Typecheck an expression} \begin{code} +{-# LANGUAGE CPP #-} + module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, tcInferRho, tcInferRhoNC, tcSyntaxOp, tcCheckId, @@ -74,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) @@ -200,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] @@ -498,7 +500,8 @@ for conditionals: to support expressions like this: ifThenElse :: Maybe a -> (a -> b) -> b -> b - ifThenElse (Just a) f _ = f a ifThenElse Nothing _ e = e + ifThenElse (Just a) f _ = f a + ifThenElse Nothing _ e = e example :: String example = if Just 2 @@ -562,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; ... } @@ -748,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)] @@ -804,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 @@ -963,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 26af2c5ebf..303391fcdd 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -12,6 +12,8 @@ is restricted to what the outside world understands (read C), and this module checks to see if a foreign declaration has got a legal type. \begin{code} +{-# LANGUAGE CPP #-} + module TcForeign ( tcForeignImports , tcForeignExports @@ -58,7 +60,6 @@ import SrcLoc import Bag import FastString import Hooks -import BasicTypes (Origin(..)) import Control.Monad \end{code} @@ -93,6 +94,20 @@ parameters. Similarly, we don't need to look in AppTy's, because nothing headed by an AppTy will be marshalable. +Note [FFI type roles] +~~~~~~~~~~~~~~~~~~~~~ +The 'go' helper function within normaliseFfiType' always produces +representational coercions. But, in the "children_only" case, we need to +use these coercions in a TyConAppCo. Accordingly, the roles on the coercions +must be twiddled to match the expectation of the enclosing TyCon. However, +we cannot easily go from an R coercion to an N one, so we forbid N roles +on FFI type constructors. Currently, only two such type constructors exist: +IO and FunPtr. Thus, this is not an onerous burden. + +If we ever want to lift this restriction, we would need to make 'go' take +the target role as a parameter. This wouldn't be hard, but it's a complication +not yet necessary and so is not yet implemented. + \begin{code} -- normaliseFfiType takes the type from an FFI declaration, and -- evaluates any type synonyms, type functions, and newtypes. However, @@ -115,7 +130,8 @@ normaliseFfiType' env ty0 = go initRecTc ty0 -- We don't want to look through the IO newtype, even if it is -- in scope, so we have a special case for it: | tc_key `elem` [ioTyConKey, funPtrTyConKey] - -- Those *must* have R roles on their parameters! + -- These *must not* have nominal roles on their parameters! + -- See Note [FFI type roles] = children_only | isNewTyCon tc -- Expand newtypes @@ -142,10 +158,14 @@ normaliseFfiType' env ty0 = go initRecTc ty0 = nothing -- see Note [Don't recur in normaliseFfiType'] where tc_key = getUnique tc - children_only + children_only = do xs <- mapM (go rec_nts) tys let (cos, tys', gres) = unzip3 xs - return ( mkTyConAppCo Representational tc cos + -- the (repeat Representational) is because 'go' always + -- returns R coercions + cos' = zipWith3 downgradeRole (tyConRoles tc) + (repeat Representational) cos + return ( mkTyConAppCo Representational tc cos' , mkTyConApp tc tys', unionManyBags gres) nt_co = mkUnbranchedAxInstCo Representational (newTyConCo tc) tys nt_rhs = newTyConInstRhs tc tys @@ -230,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' @@ -241,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. @@ -265,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 @@ -316,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" @@ -351,7 +371,7 @@ tcForeignExports' decls where combine (binds, fs, gres1) (L loc fe) = do (b, f, gres2) <- setSrcSpan loc (tcFExport fe) - return ((FromSource, b) `consBag` binds, L loc f : fs, gres1 `unionBags` gres2) + return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2) tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id, Bag GlobalRdrElt) tcFExport fo@(ForeignExport (L loc nm) hs_ty _ spec) @@ -384,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 @@ -406,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 @@ -419,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")) - -- handle safe language typecheck fail - _ | check_safe && safeLanguageOn dflags - -> addErrTc $ illegalForeignTyErr result ty $+$ safeHsErr + | 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 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 @@ -459,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 @@ -482,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 @@ -512,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 581cebc9c4..2967630da1 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -11,25 +11,14 @@ This module is nominally ``subordinate'' to @TcDeriv@, which is the This is where we do all the grimy bindings' generation. \begin{code} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP, ScopedTypeVariables #-} 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} @@ -97,10 +87,43 @@ data DerivStuff -- Please add this auxiliary stuff | DerivFamInst (FamInst) -- New type family instances -- New top-level auxiliary bindings - | DerivHsBind ((Origin, LHsBind RdrName), LSig RdrName) -- Also used for SYB + | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB | 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} %************************************************************************ %* * @@ -360,7 +383,7 @@ gen_Ord_binds loc tycon (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons - mkOrdOp :: OrdOp -> (Origin, LHsBind RdrName) + mkOrdOp :: OrdOp -> LHsBind RdrName -- Returns a binding op a b = ... compares a and b according to op .... mkOrdOp op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs op) @@ -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 @@ -1352,7 +1379,7 @@ gen_Data_binds dflags loc tycon n_cons = length data_cons one_constr = n_cons == 1 - genDataTyCon :: ((Origin, LHsBind RdrName), LSig RdrName) + genDataTyCon :: (LHsBind RdrName, LSig RdrName) genDataTyCon -- $dT = (mkHsVarBind loc rdr_name rhs, L loc (TypeSig [L loc rdr_name] sig_ty)) @@ -1364,7 +1391,7 @@ gen_Data_binds dflags loc tycon `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr tycon))) `nlHsApp` nlList constrs - genDataDataCon :: DataCon -> ((Origin, LHsBind RdrName), LSig RdrName) + genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName) genDataDataCon dc -- $cT1 etc = (mkHsVarBind loc rdr_name rhs, L loc (TypeSig [L loc rdr_name] sig_ty)) @@ -1943,7 +1970,7 @@ gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty (map (mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty) (classMethods cls)) where coerce_RDR = getRdrName coerceId - mk_bind :: Id -> Pair Type -> (Origin, LHsBind RdrName) + mk_bind :: Id -> Pair Type -> LHsBind RdrName mk_bind id (Pair tau_ty user_ty) = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch [] rhs_expr] where @@ -1978,7 +2005,7 @@ The `tags' here start at zero, hence the @fIRST_TAG@ (currently one) fiddling around. \begin{code} -genAuxBindSpec :: SrcSpan -> AuxBindSpec -> ((Origin, LHsBind RdrName), LSig RdrName) +genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName) genAuxBindSpec loc (DerivCon2Tag tycon) = (mk_FunBind loc rdr_name eqns, L loc (TypeSig [L loc rdr_name] (L loc sig_ty))) @@ -2024,7 +2051,7 @@ genAuxBindSpec loc (DerivMaxTag tycon) data_cons -> toInteger ((length data_cons) - fIRST_TAG) type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings - ( Bag ((Origin, LHsBind RdrName), LSig RdrName) + ( Bag (LHsBind RdrName, LSig RdrName) -- Extra bindings (used by Generic only) , Bag TyCon -- Extra top-level datatypes , Bag (FamInst) -- Extra family instances @@ -2079,14 +2106,14 @@ mkParentType tc \begin{code} mk_FunBind :: SrcSpan -> RdrName -> [([LPat RdrName], LHsExpr RdrName)] - -> (Origin, LHsBind RdrName) + -> LHsBind RdrName mk_FunBind loc fun pats_and_exprs = mkRdrFunBind (L loc fun) matches where matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs] -mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> (Origin, LHsBind RdrName) -mkRdrFunBind fun@(L loc fun_rdr) matches = (Generated, L loc (mkFunBind fun matches')) +mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName +mkRdrFunBind fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches') where -- Catch-all eqn looks like -- fmap = error "Void fmap" diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs index d9d92ba2ea..d4c3934053 100644 --- a/compiler/typecheck/TcGenGenerics.lhs +++ b/compiler/typecheck/TcGenGenerics.lhs @@ -6,13 +6,7 @@ The deriving code for the Generic class (equivalent to the code in TcGenDeriv, for other classes) \begin{code} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details +{-# LANGUAGE CPP, ScopedTypeVariables #-} module TcGenGenerics (canDoGenerics, canDoGenerics1, @@ -42,11 +36,12 @@ import TcEnv import MkId import TcRnMonad import HscTypes +import ErrUtils( Validity(..), andValid ) import BuildTyCl import SrcLoc import Bag import VarSet (elemVarSet) -import Outputable +import Outputable import FastString import Util @@ -64,7 +59,7 @@ import Control.Monad (mplus,forM) For the generic representation we need to generate: \begin{itemize} \item A Generic instance -\item A Rep type instance +\item A Rep type instance \item Many auxiliary datatypes and instances for them (for the meta-information) \end{itemize} @@ -90,7 +85,7 @@ genGenericMetaTyCons tc mod = mkTyCon name = ASSERT( isExternalName name ) buildAlgTyCon name [] [] Nothing [] distinctAbstractTyConRhs - NonRecursive + NonRecursive False -- Not promotable False -- Not GADT syntax NoParentTyCon @@ -121,21 +116,21 @@ metaTyConsToDerivStuff tc metaDts = cClas <- tcLookupClass constructorClassName c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ] sClas <- tcLookupClass selectorClassName - s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc - | _ <- x ] + s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc + | _ <- x ] | x <- metaS metaDts ]) fix_env <- getFixityEnv let - safeOverlap = safeLanguageOn dflags (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc - mk_inst clas tc dfun_name + mk_inst clas tc dfun_name = mkLocalInstance (mkDictFunId dfun_name [] [] clas tys) - (NoOverlap safeOverlap) + OverlapFlag { overlapMode = NoOverlap + , isSafeOverlap = safeLanguageOn dflags } [] clas tys where tys = [mkTyConTy tc] - + -- Datatype d_metaTycon = metaD metaDts d_inst = mk_inst dClas d_metaTycon d_dfun_name @@ -144,7 +139,7 @@ metaTyConsToDerivStuff tc metaDts = , ib_extensions = [] , ib_standalone_deriving = False } d_mkInst = DerivInst (InstInfo { iSpec = d_inst, iBinds = d_binds }) - + -- Constructor c_metaTycons = metaC metaDts c_insts = [ mk_inst cClas c ds @@ -156,7 +151,7 @@ metaTyConsToDerivStuff tc metaDts = | c <- cBinds ] c_mkInst = [ DerivInst (InstInfo { iSpec = is, iBinds = bs }) | (is,bs) <- myZip1 c_insts c_binds ] - + -- Selector s_metaTycons = metaS metaDts s_insts = map (map (\(s,ds) -> mk_inst sClas s ds)) @@ -169,15 +164,15 @@ metaTyConsToDerivStuff tc metaDts = s_mkInst = map (map (\(is,bs) -> DerivInst (InstInfo { iSpec = is , iBinds = bs}))) (myZip2 s_insts s_binds) - + myZip1 :: [a] -> [b] -> [(a,b)] myZip1 l1 l2 = ASSERT(length l1 == length l2) zip l1 l2 - + myZip2 :: [[a]] -> [[b]] -> [[(a,b)]] myZip2 l1 l2 = ASSERT(and (zipWith (>=) (map length l1) (map length l2))) [ zip x1 x2 | (x1,x2) <- zip l1 l2 ] - + return $ mapBag DerivTyCon (metaTyCons2TyCons metaDts) `unionBags` listToBag (d_mkInst : c_mkInst ++ concat s_mkInst) \end{code} @@ -189,14 +184,13 @@ metaTyConsToDerivStuff tc metaDts = %************************************************************************ \begin{code} -get_gen1_constrained_tys :: TyVar -> [Type] -> [Type] +get_gen1_constrained_tys :: TyVar -> Type -> [Type] -- called by TcDeriv.inferConstraints; generates a list of types, each of which -- must be a Functor in order for the Generic1 instance to work. -get_gen1_constrained_tys argVar = - concatMap $ argTyFold argVar $ ArgTyAlg { - ata_rec0 = const [], - ata_par1 = [], ata_rec1 = const [], - ata_comp = (:)} +get_gen1_constrained_tys argVar + = argTyFold argVar $ ArgTyAlg { ata_rec0 = const [] + , ata_par1 = [], ata_rec1 = const [] + , ata_comp = (:) } {- @@ -242,7 +236,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). -- @@ -254,17 +248,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 @@ -282,28 +276,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) + -- 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 } {- @@ -338,13 +332,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") @@ -352,19 +346,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 @@ -392,7 +386,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" @@ -402,13 +396,13 @@ canDoGenerics1 rep_tc tc_args = \end{code} %************************************************************************ -%* * +%* * \subsection{Generating the RHS of a generic default method} -%* * +%* * %************************************************************************ \begin{code} -type US = Int -- Local unique supply, just a plain Int +type US = Int -- Local unique supply, just a plain Int type Alt = (LPat RdrName, LHsExpr RdrName) -- GenericKind serves to mark if a datatype derives Generic (Gen0) or @@ -435,7 +429,7 @@ gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d -- Bindings for the Generic instance mkBindsRep :: GenericKind -> TyCon -> LHsBinds RdrName -mkBindsRep gk tycon = +mkBindsRep gk tycon = unitBag (mkRdrFunBind (L loc from01_RDR) from_matches) `unionBags` unitBag (mkRdrFunBind (L loc to01_RDR) to_matches) @@ -457,7 +451,7 @@ mkBindsRep gk tycon = Gen1 -> ASSERT(length tyvars >= 1) Gen1_ (last tyvars) where tyvars = tyConTyVars tycon - + -------------------------------------------------------------------------------- -- The type synonym instance and synonym -- type instance Rep (D a b) = Rep_D a b @@ -469,7 +463,7 @@ tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1 -> MetaTyCons -- Metadata datatypes to refer to -> Module -- Used as the location of the new RepTy -> TcM (FamInst) -- Generated representation0 coercion -tc_mkRepFamInsts gk tycon metaDts mod = +tc_mkRepFamInsts gk tycon metaDts mod = -- Consider the example input tycon `D`, where data D a b = D_ a -- Also consider `R:DInt`, where { data family D x y :: * -> * -- ; data instance D Int a b = D_ a } @@ -502,7 +496,7 @@ tc_mkRepFamInsts gk tycon metaDts mod = -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> * ; repTy <- tc_mkRepTy gk_ tycon metaDts - + -- `rep_name` is a name we generate for the synonym ; rep_name <- let mkGen = case gk of Gen0 -> mkGenR; Gen1 -> mkGen1R in newGlobalBinder mod (mkGen (nameOccName (tyConName tycon))) @@ -585,10 +579,10 @@ tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1 -- The type to generate representation for -> TyCon -- Metadata datatypes to refer to - -> MetaTyCons + -> MetaTyCons -- Generated representation0 type -> TcM Type -tc_mkRepTy gk_ tycon metaDts = +tc_mkRepTy gk_ tycon metaDts = do d1 <- tcLookupTyCon d1TyConName c1 <- tcLookupTyCon c1TyConName @@ -602,7 +596,7 @@ tc_mkRepTy gk_ tycon metaDts = plus <- tcLookupTyCon sumTyConName times <- tcLookupTyCon prodTyConName comp <- tcLookupTyCon compTyConName - + let mkSum' a b = mkTyConApp plus [a,b] mkProd a b = mkTyConApp times [a,b] mkComp a b = mkTyConApp comp [a,b] @@ -616,7 +610,7 @@ tc_mkRepTy gk_ tycon metaDts = mkS True _ a = mkTyConApp s1 [mkTyConTy nS1, a] -- This field has a label mkS False d a = mkTyConApp s1 [d, a] - + -- Sums and products are done in the same way for both Rep and Rep1 sumP [] = mkTyConTy v1 sumP l = ASSERT(length metaCTyCons == length l) @@ -631,9 +625,9 @@ tc_mkRepTy gk_ tycon metaDts = ASSERT(length l == length (metaSTyCons !! i)) foldBal mkProd [ arg d t b | (d,t) <- zip (metaSTyCons !! i) l ] - + arg :: Type -> Type -> Bool -> Type - arg d t b = mkS b d $ case gk_ of + arg d t b = mkS b d $ case gk_ of -- Here we previously used Par0 if t was a type variable, but we -- realized that we can't always guarantee that we are wrapping-up -- all type variables in Par0. So we decided to stop using Par0 @@ -646,40 +640,40 @@ tc_mkRepTy gk_ tycon metaDts = argPar argVar = argTyFold argVar $ ArgTyAlg {ata_rec0 = mkRec0, ata_par1 = mkPar1, ata_rec1 = mkRec1, ata_comp = mkComp} - - + + metaDTyCon = mkTyConTy (metaD metaDts) metaCTyCons = map mkTyConTy (metaC metaDts) metaSTyCons = map (map mkTyConTy) (metaS metaDts) - + return (mkD tycon) -------------------------------------------------------------------------------- -- Meta-information -------------------------------------------------------------------------------- -data MetaTyCons = MetaTyCons { -- One meta datatype per dataype +data MetaTyCons = MetaTyCons { -- One meta datatype per datatype metaD :: TyCon -- One meta datatype per constructor , metaC :: [TyCon] -- One meta datatype per selector per constructor , metaS :: [[TyCon]] } - + instance Outputable MetaTyCons where ppr (MetaTyCons d c s) = ppr d $$ vcat (map ppr c) $$ vcat (map ppr (concat s)) - + metaTyCons2TyCons :: MetaTyCons -> Bag TyCon metaTyCons2TyCons (MetaTyCons d c s) = listToBag (d : c ++ concat s) -- Bindings for Datatype, Constructor, and Selector instances -mkBindsMetaD :: FixityEnv -> TyCon +mkBindsMetaD :: FixityEnv -> TyCon -> ( LHsBinds RdrName -- Datatype instance , [LHsBinds RdrName] -- Constructor instances , [[LHsBinds RdrName]]) -- Selector instances mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds) where - mkBag l = foldr1 unionBags + mkBag l = foldr1 unionBags [ unitBag (mkRdrFunBind (L loc name) matches) | (name, matches) <- l ] dtBinds = mkBag ( [ (datatypeName_RDR, dtName_matches) @@ -717,7 +711,7 @@ mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds) dtName_matches = mkStringLHS . occNameString . nameOccName $ tyConName_user - moduleName_matches = mkStringLHS . moduleNameString . moduleName + moduleName_matches = mkStringLHS . moduleNameString . moduleName . nameModule . tyConName $ tycon isNewtype_matches = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)] @@ -778,10 +772,10 @@ mk1Sum gk_ us i n datacon = (from_alt, to_alt) us' = us + n_args datacon_rdr = getRdrName datacon - + from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs) from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E gk_ us' datacon_varTys)) - + to_alt = (mkM1_P (genLR_P i n (mkProd_P gk us' datacon_vars)), to_alt_rhs) -- These M1s are meta-information for the datatype to_alt_rhs = case gk_ of @@ -822,9 +816,9 @@ genLR_E i n e -- Build a product expression mkProd_E :: GenericKind_DC -- Generic or Generic1? - -> US -- Base for unique names + -> US -- Base for unique names -> [(RdrName, Type)] -- List of variables matched on the lhs and their types - -> LHsExpr RdrName -- Resulting product expression + -> LHsExpr RdrName -- Resulting product expression mkProd_E _ _ [] = mkM1_E (nlHsVar u1DataCon_RDR) mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars) -- These M1s are meta-information for the constructor @@ -848,9 +842,9 @@ wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $ converter ty `nlHsApp` nlHsVar v -- Build a product pattern mkProd_P :: GenericKind -- Gen0 or Gen1 - -> US -- Base for unique names - -> [RdrName] -- List of variables to match - -> LPat RdrName -- Resulting product pattern + -> US -- Base for unique names + -> [RdrName] -- List of variables to match + -> LPat RdrName -- Resulting product pattern mkProd_P _ _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR) mkProd_P gk _ vars = mkM1_P (foldBal prod appVars) -- These M1s are meta-information for the constructor diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 1c9ac57e80..f4d5cf262c 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -9,12 +9,15 @@ This module is an extension of @HsSyn@ syntax, for use in the type checker. \begin{code} +{-# LANGUAGE CPP #-} + module TcHsSyn ( mkHsConApp, mkHsDictLet, mkHsApp, hsLitType, hsLPatType, hsPatType, mkHsAppTy, mkSimpleHsAlt, nlHsIntLit, shortCutLit, hsOverLitName, + conLikeResTy, -- re-exported from TcMonad TcId, TcIdSet, @@ -38,7 +41,9 @@ import TcEvidence import TysPrim import TysWiredIn import Type +import ConLike import DataCon +import PatSyn( patSynInstResTy ) import Name import NameSet import Var @@ -80,14 +85,19 @@ hsPatType (ViewPat _ _ ty) = ty hsPatType (ListPat _ ty Nothing) = mkListTy ty hsPatType (ListPat _ _ (Just (ty,_))) = ty hsPatType (PArrPat _ ty) = mkPArrTy ty -hsPatType (TuplePat _ _ ty) = ty -hsPatType (ConPatOut { pat_ty = ty }) = ty +hsPatType (TuplePat _ bx tys) = mkTupleTy (boxityNormalTupleSort bx) tys +hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys }) + = conLikeResTy con tys hsPatType (SigPatOut _ ty) = ty hsPatType (NPat lit _ _) = overLitType lit hsPatType (NPlusKPat id _ _ _) = idType (unLoc id) hsPatType (CoPat _ _ ty) = ty hsPatType p = pprPanic "hsPatType" (ppr p) +conLikeResTy :: ConLike -> [Type] -> Type +conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys +conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys + hsLitType :: HsLit -> TcType hsLitType (HsChar _) = charTy hsLitType (HsCharPrim _) = charPrimTy @@ -405,10 +415,8 @@ warnMissingSig msg id zonkMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (LHsBinds Id) zonkMonoBinds env sig_warn binds = mapBagM (zonk_lbind env sig_warn) binds -zonk_lbind :: ZonkEnv -> SigWarn -> (Origin, LHsBind TcId) -> TcM (Origin, LHsBind Id) -zonk_lbind env sig_warn (origin, lbind) - = do { lbind' <- wrapLocM (zonk_bind env sig_warn) lbind - ; return (origin, lbind') } +zonk_lbind :: ZonkEnv -> SigWarn -> LHsBind TcId -> TcM (LHsBind Id) +zonk_lbind env sig_warn = wrapLocM (zonk_bind env sig_warn) zonk_bind :: ZonkEnv -> SigWarn -> HsBind TcId -> TcM (HsBind Id) zonk_bind env sig_warn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty}) @@ -460,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) @@ -481,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 @@ -506,11 +518,11 @@ zonkLTcSpecPrags env ps zonkMatchGroup :: ZonkEnv -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) -> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id))) -zonkMatchGroup env zBody (MG { mg_alts = ms, mg_arg_tys = arg_tys, mg_res_ty = res_ty }) +zonkMatchGroup env zBody (MG { mg_alts = ms, mg_arg_tys = arg_tys, mg_res_ty = res_ty, mg_origin = origin }) = do { ms' <- mapM (zonkMatch env zBody) ms ; arg_tys' <- zonkTcTypeToTypes env arg_tys ; res_ty' <- zonkTcTypeToType env res_ty - ; return (MG { mg_alts = ms', mg_arg_tys = arg_tys', mg_res_ty = res_ty' }) } + ; return (MG { mg_alts = ms', mg_arg_tys = arg_tys', mg_res_ty = res_ty', mg_origin = origin }) } zonkMatch :: ZonkEnv -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) @@ -1027,16 +1039,16 @@ zonk_pat env (PArrPat pats ty) ; (env', pats') <- zonkPats env pats ; return (env', PArrPat pats' ty') } -zonk_pat env (TuplePat pats boxed ty) - = do { ty' <- zonkTcTypeToType env ty +zonk_pat env (TuplePat pats boxed tys) + = do { tys' <- mapM (zonkTcTypeToType env) tys ; (env', pats') <- zonkPats env pats - ; return (env', TuplePat pats' boxed ty') } + ; return (env', TuplePat pats' boxed tys') } -zonk_pat env p@(ConPatOut { pat_ty = ty, pat_tvs = tyvars +zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars , pat_dicts = evs, pat_binds = binds , pat_args = args, pat_wrap = wrapper }) = ASSERT( all isImmutableTyVar tyvars ) - do { new_ty <- zonkTcTypeToType env ty + do { new_tys <- mapM (zonkTcTypeToType env) tys ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars -- Must zonk the existential variables, because their -- /kind/ need potential zonking. @@ -1045,7 +1057,7 @@ zonk_pat env p@(ConPatOut { pat_ty = ty, pat_tvs = tyvars ; (env2, new_binds) <- zonkTcEvBinds env1 binds ; (env3, new_wrapper) <- zonkCoFn env2 wrapper ; (env', new_args) <- zonkConStuff env3 args - ; return (env', p { pat_ty = new_ty, + ; return (env', p { pat_arg_tys = new_tys, pat_tvs = new_tyvars, pat_dicts = new_evs, pat_binds = new_binds, diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index eed906898b..39c0acf2a6 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -5,7 +5,8 @@ \section[TcMonoType]{Typechecking user-specified @MonoTypes@} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -24,7 +25,6 @@ module TcHsType ( -- Kind-checking types -- No kind generalisation, no checkValidType - KindCheckingStrategy(..), kcStrategy, kcStrategyFamDecl, kcHsTyVarBndrs, tcHsTyVarBndrs, tcHsLiftedType, tcHsOpenType, tcLHsType, tcCheckLHsType, @@ -53,6 +53,7 @@ import TcType import Type import TypeRep( Type(..) ) -- For the mkNakedXXX stuff import Kind +import RdrName( lookupLocalRdrOcc ) import Var import VarSet import TyCon @@ -72,8 +73,9 @@ import Outputable import FastString import Util +import Data.Maybe( isNothing ) import Control.Monad ( unless, when, zipWithM ) -import PrelNames( ipClassName, funTyConKey ) +import PrelNames( ipClassName, funTyConKey, allNameStrings ) \end{code} @@ -207,18 +209,22 @@ tc_inst_head hs_ty = tc_hs_type hs_ty ekConstraint ----------------- -tcHsDeriv :: HsType Name -> TcM ([TyVar], Class, [Type]) --- Like tcHsSigTypeNC, but for the ...deriving( ty ) clause -tcHsDeriv hs_ty - = do { kind <- newMetaKindVar - ; ty <- tcCheckHsTypeAndGen hs_ty kind - -- Funny newtype deriving form - -- forall a. C [a] - -- where C has arity 2. Hence any-kinded result - ; ty <- zonkSigType ty +tcHsDeriv :: HsType Name -> TcM ([TyVar], Class, [Type], Kind) +-- Like tcHsSigTypeNC, but for the ...deriving( C t1 ty2 ) clause +-- Returns the C, [ty1, ty2, and the kind of C's *next* argument +-- E.g. class C (a::*) (b::k->k) +-- data T a b = ... deriving( C Int ) +-- returns ([k], C, [k, Int], k->k) +-- Also checks that (C ty1 ty2 arg) :: Constraint +-- if arg has a suitable kind +tcHsDeriv hs_ty + = do { arg_kind <- newMetaKindVar + ; ty <- tcCheckHsTypeAndGen hs_ty (mkArrowKind arg_kind constraintKind) + ; ty <- zonkSigType ty + ; arg_kind <- zonkSigType arg_kind ; let (tvs, pred) = splitForAllTys ty ; case getClassPredTys_maybe pred of - Just (cls, tys) -> return (tvs, cls, tys) + Just (cls, tys) -> return (tvs, cls, tys, arg_kind) Nothing -> failWithTc (ptext (sLit "Illegal deriving item") <+> quotes (ppr hs_ty)) } -- Used for 'VECTORISE [SCALAR] instance' declarations @@ -389,13 +395,17 @@ tc_hs_type hs_ty@(HsAppTy ty1 ty2) exp_kind (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] --------- Foralls -tc_hs_type hs_ty@(HsForAllTy _ hs_tvs context ty) exp_kind - = tcHsTyVarBndrs hs_tvs $ \ tvs' -> +tc_hs_type hs_ty@(HsForAllTy _ hs_tvs context ty) exp_kind@(EK exp_k _) + | isConstraintKind exp_k + = failWithTc (hang (ptext (sLit "Illegal constraint:")) 2 (ppr hs_ty)) + + | otherwise + = tcHsTyVarBndrs hs_tvs $ \ tvs' -> -- Do not kind-generalise here! See Note [Kind generalisation] do { ctxt' <- tcHsContext context ; ty' <- if null (unLoc context) then -- Plain forall, no context tc_lhs_type ty exp_kind -- Why exp_kind? See Note [Body kind of forall] - else + else -- If there is a context, then this forall is really a -- _function_, so the kind of the result really is * -- The body kind (result of the function can be * or #, hence ekOpen @@ -614,7 +624,6 @@ tcTyVar :: Name -> TcM (TcType, TcKind) tcTyVar name -- Could be a tyvar, a tycon, or a datacon = do { traceTc "lk1" (ppr name) ; thing <- tcLookup name - ; traceTc "lk2" (ppr name <+> ppr thing) ; case thing of ATyVar _ tv | isKindVar tv @@ -724,17 +733,17 @@ mkNakedAppTys ty1 tys2 = foldl AppTy ty1 tys2 zonkSigType :: TcType -> TcM TcType -- Zonk the result of type-checking a user-written type signature --- It may have kind varaibles in it, but no meta type variables +-- It may have kind variables in it, but no meta type variables -- Because of knot-typing (see Note [Zonking inside the knot]) --- it may need to establish the Type invariants; +-- it may need to establish the Type invariants; -- hence the use of mkTyConApp and mkAppTy zonkSigType ty = go ty where go (TyConApp tc tys) = do tys' <- mapM go tys return (mkTyConApp tc tys') - -- Key point: establish Type invariants! - -- See Note [Zonking inside the knot] + -- Key point: establish Type invariants! + -- See Note [Zonking inside the knot] go (LitTy n) = return (LitTy n) @@ -892,181 +901,7 @@ addTypeCtxt (L _ ty) thing %* * %************************************************************************ -Note [Kind-checking strategies] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -There are three main declarations that we have to kind check carefully in the -presence of -XPolyKinds: classes, datatypes, and data/type families. They each -have a different kind-checking strategy (labeled in the parentheses above each -section). This should potentially be cleaned up in the future, but this is how -it stands now (June 2013). - -Classes (ParametricKinds): - - kind-polymorphic by default - - each un-annotated type variable is given a fresh meta kind variable - - every explicit kind variable becomes a SigTv during inference - - no generalisation is done while kind-checking the recursive group - - Taken together, this means that classes cannot participate in polymorphic - recursion. Thus, the following is not definable: - - class Fugly (a :: k) where - foo :: forall (b :: k -> *). Fugly b => b a - - But, because explicit kind variables are SigTvs, it is OK for the kind to - be forced to be the same kind that is used in a separate declaration. See - test case polykinds/T7020.hs. - -Datatypes: - Here we have two cases, whether or not a Full Kind Signature is provided. - A Full Kind Signature means that there is a top-level :: in the definition - of the datatype. For example: - - data T1 :: k -> Bool -> * where ... -- YES - data T2 (a :: k) :: Bool -> * where ... -- YES - data T3 (a :: k) (b :: Bool) :: * where ... -- YES - data T4 (a :: k) (b :: Bool) where ... -- NO - - Kind signatures are not allowed on datatypes declared in the H98 style, - so those always have no Full Kind Signature. - - Full Kind Signature (FullKindSignature): - - each un-annotated type variable defaults to * - - every explicit kind variable becomes a skolem during type inference - - these kind variables are generalised *before* kind-checking the group - - With these rules, polymorphic recursion is possible. This is essentially - because of the generalisation step before kind-checking the group -- it - gives the kind-checker enough flexibility to supply the right kind arguments - to support polymorphic recursion. - - no Full Kind Signature (ParametricKinds): - - kind-polymorphic by default - - each un-annotated type variable is given a fresh meta kind variable - - every explicit kind variable becomes a SigTv during inference - - no generalisation is done while kind-checking the recursive group - - Thus, no polymorphic recursion in this case. See also Trac #6093 & #6049. - -Type families: - Here we have three cases: open top-level families, closed top-level families, - and open associated types. (There are no closed associated types, for good - reason.) - - Open top-level families (FullKindSignature): - - All open top-level families are considered to have a Full Kind Signature - - All arguments and the result default to * - - All kind variables are skolems - - All kind variables are generalised before kind-checking the group - - This behaviour supports kind-indexed type and data families, because we - need to have generalised before kind-checking for this to work. For example: - - type family F (a :: k) - type instance F Int = Bool - type instance F Maybe = Char - type instance F (x :: * -> * -> *) = Double - - Closed top-level families (NonParametricKinds): - - kind-monomorphic by default - - each un-annotated type variable is given a fresh meta kind variable - - every explicit kind variable becomes a skolem during inference - - all such skolems are generalised before kind-checking; other kind - variables are not generalised - - all unconstrained meta kind variables are defaulted to * at the - end of kind checking - - This behaviour is to allow kind inference to occur in closed families, but - without becoming too polymorphic. For example: - - type family F a where - F Int = Bool - F Bool = Char - - We would want F to have kind * -> * from this definition, although something - like k1 -> k2 would be perfectly sound. The reason we want this restriction is - that it is better to have (F Maybe) be a kind error than simply stuck. - - The kind inference gives us also - - type family Not b where - Not False = True - Not True = False - - With an open family, the above would need kind annotations in its header. - - The tricky case is - - type family G a (b :: k) where - G Int Int = False - G Bool Maybe = True - - We want this to work. But, we also want (G Maybe Maybe) to be a kind error - (in the first argument). So, we need to generalise the skolem "k" but not - the meta kind variable associated with "a". - - Associated families (FullKindSignature): - - Kind-monomorphic by default - - Result kind defaults to * - - Each type variable is either in the class header or not: - - Type variables in the class header are given the kind inherited from - the class header (and checked against an annotation, if any) - - Un-annotated type variables default to * - - Each kind variable mentioned in the class header becomes a SigTv during - kind inference. - - Each kind variable not mentioned in the class header becomes a skolem during - kind inference. - - Only the skolem kind variables are generalised before kind checking. - - Here are some examples: - - class Foo1 a b where - type Bar1 (a :: k) (b :: k) - - The kind of Foo1 will be k -> k -> Constraint. Kind annotations on associated - type declarations propagate to the header because the type variables in Bar1's - declaration inherit the (meta) kinds of the class header. - - class Foo2 a where - type Bar2 a - - The kind of Bar2 will be k -> *. - - class Foo3 a where - type Bar3 a (b :: k) - meth :: Bar3 a Maybe -> () - - The kind of Bar3 will be k1 -> k2 -> *. This only kind-checks because the kind - of b is generalised before kind-checking. - - class Foo4 a where - type Bar4 a b - - Here, the kind of Bar4 will be k -> * -> *, because b is not mentioned in the - class header, so it defaults to *. - \begin{code} -data KindCheckingStrategy -- See Note [Kind-checking strategies] - = ParametricKinds - | NonParametricKinds - | FullKindSignature - deriving (Eq) - --- determine the appropriate strategy for a decl -kcStrategy :: TyClDecl Name -> KindCheckingStrategy -kcStrategy d@(ForeignType {}) = pprPanic "kcStrategy" (ppr d) -kcStrategy (FamDecl fam_decl) - = kcStrategyFamDecl fam_decl -kcStrategy (SynDecl {}) = ParametricKinds -kcStrategy (DataDecl { tcdDataDefn = HsDataDefn { dd_kindSig = m_ksig }}) - | Just _ <- m_ksig = FullKindSignature - | otherwise = ParametricKinds -kcStrategy (ClassDecl {}) = ParametricKinds - --- if the ClosedTypeFamily has no equations, do the defaulting to *, etc. -kcStrategyFamDecl :: FamilyDecl Name -> KindCheckingStrategy -kcStrategyFamDecl (FamilyDecl { fdInfo = ClosedTypeFamily (_:_) }) = NonParametricKinds -kcStrategyFamDecl _ = FullKindSignature mkKindSigVar :: Name -> TcM KindVar -- Use the specified name; don't clone it @@ -1087,13 +922,17 @@ kcScopedKindVars kv_ns thing_inside -- NB: use mutable signature variables ; tcExtendTyVarEnv2 (kv_ns `zip` kvs) thing_inside } -kcHsTyVarBndrs :: KindCheckingStrategy +-- | Kind-check a 'LHsTyVarBndrs'. If the decl under consideration has a complete, +-- user-supplied kind signature (CUSK), generalise the result. Used in 'getInitialKind' +-- and in kind-checking. See also Note [Complete user-supplied kind signatures] in +-- HsDecls. +kcHsTyVarBndrs :: Bool -- ^ True <=> the decl being checked has a CUSK -> LHsTyVarBndrs Name - -> TcM (Kind, r) -- the result kind, possibly with other info - -> TcM (Kind, r) --- Used in getInitialKind -kcHsTyVarBndrs strat (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside - = do { kvs <- if skolem_kvs + -> TcM (Kind, r) -- ^ the result kind, possibly with other info + -> TcM (Kind, r) -- ^ The full kind of the thing being declared, + -- with the other info +kcHsTyVarBndrs cusk (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside + = do { kvs <- if cusk then mapM mkKindSigVar kv_ns else mapM (\n -> newSigTyVar n superKind) kv_ns ; tcExtendTyVarEnv2 (kv_ns `zip` kvs) $ @@ -1102,24 +941,18 @@ kcHsTyVarBndrs strat (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside ; let full_kind = mkArrowKinds (map snd nks) res_kind kvs = filter (not . isMetaTyVar) $ varSetElems $ tyVarsOfType full_kind - gen_kind = if generalise + gen_kind = if cusk then mkForAllTys kvs full_kind else full_kind ; return (gen_kind, stuff) } } where - -- See Note [Kind-checking strategies] - (skolem_kvs, default_to_star, generalise) = case strat of - ParametricKinds -> (False, False, False) - NonParametricKinds -> (True, False, True) - FullKindSignature -> (True, True, True) - kc_hs_tv :: HsTyVarBndr Name -> TcM (Name, TcKind) kc_hs_tv (UserTyVar n) = do { mb_thing <- tcLookupLcl_maybe n ; kind <- case mb_thing of - Just (AThing k) -> return k - _ | default_to_star -> return liftedTypeKind - | otherwise -> newMetaKindVar + Just (AThing k) -> return k + _ | cusk -> return liftedTypeKind + | otherwise -> newMetaKindVar ; return (n, kind) } kc_hs_tv (KindedTyVar n k) = do { kind <- tcLHsKind k @@ -1249,7 +1082,11 @@ kcTyClTyVars :: Name -> LHsTyVarBndrs Name -> TcM a -> TcM a kcTyClTyVars name (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside = kcScopedKindVars kvs $ do { tc_kind <- kcLookupKind name - ; let (arg_ks, _res_k) = splitKindFunTysN (length hs_tvs) tc_kind + ; let (_, mono_kind) = splitForAllTys tc_kind + -- if we have a FullKindSignature, the tc_kind may already + -- be generalized. The kvs get matched up while kind-checking + -- the types in kc_tv, below + (arg_ks, _res_k) = splitKindFunTysN (length hs_tvs) mono_kind -- There should be enough arrows, because -- getInitialKinds used the tcdTyVars ; name_ks <- zipWithM kc_tv hs_tvs arg_ks @@ -1297,6 +1134,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 @@ -1313,21 +1155,20 @@ tcDataKindSig kind = do { checkTc (isLiftedTypeKind res_kind) (badKindSig kind) ; span <- getSrcSpanM ; us <- newUniqueSupply + ; rdr_env <- getLocalRdrEnv ; let uniqs = uniqsFromSupply us - ; return [ mk_tv span uniq str kind - | ((kind, str), uniq) <- arg_kinds `zip` dnames `zip` uniqs ] } + occs = [ occ | str <- allNameStrings + , let occ = mkOccName tvName str + , isNothing (lookupLocalRdrOcc rdr_env occ) ] + -- Note [Avoid name clashes for associated data types] + + ; return [ mk_tv span uniq occ kind + | ((kind, occ), uniq) <- arg_kinds `zip` occs `zip` uniqs ] } where (arg_kinds, res_kind) = splitKindFunTys kind - mk_tv loc uniq str kind = mkTyVar name kind - where - name = mkInternalName uniq occ loc - occ = mkOccName tvName str + mk_tv loc uniq occ kind + = mkTyVar (mkInternalName uniq occ loc) kind - dnames = map ('$' :) names -- Note [Avoid name clashes for associated data types] - - names :: [String] - names = [ c:cs | cs <- "" : names, c <- ['a'..'z'] ] - badKindSig :: Kind -> SDoc badKindSig kind = hang (ptext (sLit "Kind signature on data type declaration has non-* return kind")) @@ -1338,19 +1179,17 @@ Note [Avoid name clashes for associated data types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider class C a b where data D b :: * -> * -When typechecking the decl for D, we'll invent an extra type variable for D, -to fill out its kind. We *don't* want this type variable to be 'a', because -in an .hi file we'd get +When typechecking the decl for D, we'll invent an extra type variable +for D, to fill out its kind. Ideally we don't want this type variable +to be 'a', because when pretty printing we'll get class C a b where - data D b a -which makes it look as if there are *two* type indices. But there aren't! -So we use $a instead, which cannot clash with a user-written type variable. -Remember that type variable binders in interface files are just FastStrings, -not proper Names. - -(The tidying phase can't help here because we don't tidy TyCons. Another -alternative would be to record the number of indexing parameters in the -interface file.) + data D b a0 +(NB: the tidying happens in the conversion to IfaceSyn, which happens +as part of pretty-printing a TyThing.) + +That's why we look in the LocalRdrEnv to see what's in scope. This is +important only to get nice-looking output when doing ":info C" in GHCi. +It isn't essential for correctness. %************************************************************************ diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index f701b30db8..2b123ffab6 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -6,7 +6,8 @@ TcInstDecls: Typechecking instance declarations \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -37,6 +38,7 @@ import TcDeriv import TcEnv import TcHsType import TcUnify +import Coercion ( pprCoAxiom ) import MkCore ( nO_METHOD_BINDING_ERROR_ID ) import Type import TcEvidence @@ -49,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 @@ -68,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 @@ -412,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 @@ -439,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:")) @@ -504,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) $ @@ -525,44 +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 $ \(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' = varSetElems tv_set' - ; rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys' - ; let axiom = mkSingleCoAxiom rep_tc_name tvs' fam_tc pat_tys' rhs' - ; ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' ) - newFamInst SynFamilyInst 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) @@ -577,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 @@ -625,24 +661,22 @@ 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 - ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) - ; checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc) - ; checkTc (isOpenSynFamilyTyCon fam_tc) - (notOpenFamily fam_tc) + ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) + ; checkTc (isSynFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) + ; 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 } @@ -665,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 @@ -680,7 +714,7 @@ tcDataFamInstDecl mb_clsinfo ; checkTc (isLiftedTypeKind res_kind) $ tooFewParmsErr (tyConArity fam_tc) ; stupid_theta <- tcHsContext ctxt - ; h98_syntax <- dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta cons + ; gadt_syntax <- dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta cons -- Construct representation tycon ; rep_tc_name <- newFamInstTyConName fam_tc_name pats' @@ -703,7 +737,7 @@ tcDataFamInstDecl mb_clsinfo rep_tc = buildAlgTyCon rep_tc_name tvs' roles cType stupid_theta tc_rhs Recursive False -- No promotable to the kind level - h98_syntax parent + gadt_syntax parent -- We always assume that indexed types are recursive. Why? -- (1) Due to their open nature, we can never be sure that a -- further instance might not introduce a new recursive @@ -888,9 +922,9 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) , abs_ev_vars = dfun_ev_vars , abs_exports = [export] , abs_ev_binds = sc_binds - , abs_binds = unitBag (Generated, dict_bind) } + , abs_binds = unitBag dict_bind } - ; return (unitBag (Generated, L loc main_bind) `unionBags` + ; return (unitBag (L loc main_bind) `unionBags` listToBag meth_binds) } where @@ -1169,7 +1203,7 @@ tcInstanceMethods :: DFunId -> Class -> [TcTyVar] -> ([Located TcSpecPrag], PragFun) -> [(Id, DefMeth)] -> InstBindings Name - -> TcM ([Id], [(Origin, LHsBind Id)]) + -> TcM ([Id], [LHsBind Id]) -- The returned inst_meth_ids all have types starting -- forall tvs. theta => ... tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys @@ -1188,7 +1222,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys set_exts es thing = foldr setXOptM thing es ---------------------- - tc_item :: HsSigFun -> (Id, DefMeth) -> TcM (Id, (Origin, LHsBind Id)) + tc_item :: HsSigFun -> (Id, DefMeth) -> TcM (Id, LHsBind Id) tc_item sig_fn (sel_id, dm_info) = case findMethodBind (idName sel_id) binds of Just (user_bind, bndr_loc) @@ -1197,10 +1231,10 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ; tc_default sig_fn sel_id dm_info } ---------------------- - tc_body :: HsSigFun -> Id -> Bool -> (Origin, LHsBind Name) - -> SrcSpan -> TcM (TcId, (Origin, LHsBind Id)) + tc_body :: HsSigFun -> Id -> Bool -> LHsBind Name + -> SrcSpan -> TcM (TcId, LHsBind Id) tc_body sig_fn sel_id generated_code rn_bind bndr_loc - = add_meth_ctxt sel_id generated_code (snd rn_bind) $ + = add_meth_ctxt sel_id generated_code rn_bind $ do { traceTc "tc_item" (ppr sel_id <+> ppr (idType sel_id)) ; (meth_id, local_meth_sig) <- setSrcSpan bndr_loc $ mkMethIds sig_fn clas tyvars dfun_ev_vars @@ -1216,12 +1250,12 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ; return (meth_id1, bind) } ---------------------- - tc_default :: HsSigFun -> Id -> DefMeth -> TcM (TcId, (Origin, LHsBind Id)) + tc_default :: HsSigFun -> Id -> DefMeth -> TcM (TcId, LHsBind Id) tc_default sig_fn sel_id (GenDefMeth dm_name) = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name ; tc_body sig_fn sel_id False {- Not generated code? -} - (Generated, meth_bind) inst_loc } + meth_bind inst_loc } tc_default sig_fn sel_id NoDefMeth -- No default method at all = do { traceTc "tc_def: warn" (ppr sel_id) @@ -1229,8 +1263,8 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys inst_tys sel_id ; dflags <- getDynFlags ; return (meth_id, - (Generated, mkVarBind meth_id $ - mkLHsWrap lam_wrapper (error_rhs dflags))) } + mkVarBind meth_id $ + mkLHsWrap lam_wrapper (error_rhs dflags)) } where error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags) error_fun = L inst_loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID @@ -1272,13 +1306,13 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars , abs_exports = [export] , abs_ev_binds = EvBinds (unitBag self_ev_bind) - , abs_binds = unitBag (Generated, meth_bind) } + , abs_binds = unitBag meth_bind } -- Default methods in an instance declaration can't have their own -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but -- currently they are rejected with -- "INLINE pragma lacks an accompanying binding" - ; return (meth_id1, (Generated, L inst_loc bind)) } + ; return (meth_id1, L inst_loc bind) } ---------------------- mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags @@ -1329,7 +1363,7 @@ mkGenericDefMethBind clas inst_tys sel_id dm_name (vcat [ppr clas <+> ppr inst_tys, nest 2 (ppr sel_id <+> equals <+> ppr rhs)])) - ; return (noLoc $ mkTopFunBind (noLoc (idName sel_id)) + ; return (noLoc $ mkTopFunBind Generated (noLoc (idName sel_id)) [mkSimpleMatch [] rhs]) } where rhs = nlHsVar dm_name diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 75835ad30a..33249f4b04 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -1,4 +1,6 @@ \begin{code} +{-# LANGUAGE CPP #-} + module TcInteract ( solveInteractGiven, -- Solves [EvVar],GivenLoc solveInteract, -- Solves Cts @@ -101,6 +103,7 @@ solveInteractGiven loc old_fsks givens , ctev_loc = loc } | ev_id <- givens ] + -- See Note [Given flatten-skolems] in TcSMonad fsk_bag = listToBag [ mkNonCanonical $ CtGiven { ctev_evtm = EvCoercion (mkTcNomReflCo tv_ty) , ctev_pred = pred , ctev_loc = loc } @@ -750,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] @@ -1478,7 +1485,9 @@ doTopReactDict inerts fl cls xis = do { instEnvs <- getInstEnvs ; let fd_eqns = improveFromInstEnv instEnvs pred ; fd_work <- rewriteWithFunDeps fd_eqns loc - ; unless (null fd_work) (updWorkListTcS (extendWorkListEqs fd_work)) + ; unless (null fd_work) $ + do { traceTcS "Addig FD work" (ppr pred $$ vcat (map pprEquation fd_eqns) $$ ppr fd_work) + ; updWorkListTcS (extendWorkListEqs fd_work) } ; return NoTopInt } -------------------- @@ -1830,7 +1839,7 @@ matchClassInst _ clas [ ty ] _ matchClassInst _ clas [ _k, ty1, ty2 ] loc | clas == coercibleClass = do - traceTcS "matchClassInst for" $ ppr clas <+> ppr ty1 <+> ppr ty2 <+> text "at depth" <+> ppr (ctLocDepth loc) + traceTcS "matchClassInst for" $ quotes (pprClassPred clas [ty1,ty2]) <+> text "at depth" <+> ppr (ctLocDepth loc) ev <- getCoercibleInst loc ty1 ty2 traceTcS "matchClassInst returned" $ ppr ev return ev @@ -1926,6 +1935,8 @@ getCoercibleInst loc ty1 ty2 = do where go :: FamInstEnvs -> GlobalRdrEnv -> TcS LookupInstResult go famenv rdr_env + -- Also see [Order of Coercible Instances] + -- Coercible a a (see case 1 in [Coercible Instances]) | ty1 `tcEqType` ty2 = do return $ GenInst [] @@ -1941,7 +1952,31 @@ getCoercibleInst loc ty1 ty2 = do ev_term <- deferTcSForAllEq Representational loc (tvs1,body1) (tvs2,body2) return $ GenInst [] ev_term - -- Coercible (D ty1 ty2) (D ty1' ty2') (see case 3 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 + = do markDataConsAsUsed rdr_env tc + ct_ev <- requestCoercible loc concTy ty2 + local_var <- mkSysLocalM (fsLit "coev") $ mkCoerciblePred concTy ty2 + let binds = EvBinds (unitBag (EvBind local_var (getEvTerm ct_ev))) + tcCo = TcLetCo binds $ + coercionToTcCoercion ntCo `mkTcTransCo` mkTcCoVarCo local_var + return $ GenInst (freshGoals [ct_ev]) (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) + + -- 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, @@ -1972,30 +2007,6 @@ getCoercibleInst loc ty1 ty2 = do tcCo = TcLetCo binds (mkTcTyConAppCo Representational tc1 arg_cos) return $ GenInst (catMaybes arg_new) (EvCoercion tcCo) - -- Coercible NT a (see case 4 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 - = do markDataConsAsUsed rdr_env tc - ct_ev <- requestCoercible loc concTy ty2 - local_var <- mkSysLocalM (fsLit "coev") $ mkCoerciblePred concTy ty2 - let binds = EvBinds (unitBag (EvBind local_var (getEvTerm ct_ev))) - tcCo = TcLetCo binds $ - coercionToTcCoercion ntCo `mkTcTransCo` mkTcCoVarCo local_var - return $ GenInst (freshGoals [ct_ev]) (EvCoercion tcCo) - - -- Coercible a NT (see case 4 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 @@ -2035,7 +2046,7 @@ Note [Coercible Instances] The class Coercible is special: There are no regular instances, and the user cannot even define them (it is listed as an `abstractClass` in TcValidity). Instead, the type checker will create instances and their evidence out of thin -air, in getCoercibleInst. The following “instances” are present: +air, in getCoercibleInst. The following "instances" are present: 1. instance Coercible a a for any type a at any kind k. @@ -2044,26 +2055,14 @@ air, in getCoercibleInst. The following “instances” are present: (which would be illegal to write like that in the source code, but we have it nevertheless). - - 3. instance (Coercible t1_r t1'_r, Coercible t2_r t2_r',...) => - Coercible (C t1_r t2_r ... t1_p t2_p ... t1_n t2_n ...) - (C t1_r' t2_r' ... t1_p' t2_p' ... t1_n t2_n ...) - for a type constructor C where - * the nominal type arguments are not changed, - * the phantom type arguments may change arbitrarily - * the representational type arguments are again Coercible - - The type constructor can be used undersaturated; then the Coercible - instance is at a higher kind. This does not cause problems. - - 4. instance Coercible r b => Coercible (NT t1 t2 ...) b + 3. instance Coercible r b => Coercible (NT t1 t2 ...) b instance Coercible a r => Coercible a (NT t1 t2 ...) for a newtype constructor NT (or data family instance that resolves to a newtype) where * r is the concrete type of NT, instantiated with the arguments t1 t2 ... - * the constructor of NT are in scope. + * the constructor of NT is in scope. - Again, the newtype TyCon can appear undersaturated, but only if it has + The newtype TyCon can appear undersaturated, but only if it has enough arguments to apply the newtype coercion (which is eta-reduced). Examples: newtype NT a = NT (Either a Int) Coercible (NT Int) (Either Int Int) -- ok @@ -2071,12 +2070,24 @@ air, in getCoercibleInst. The following “instances” are present: newtype NT3 a b = NT3 (b -> a) Coercible (NT2 Int) (NT3 Int) -- cannot be derived + 4. instance (Coercible t1_r t1'_r, Coercible t2_r t2_r',...) => + Coercible (C t1_r t2_r ... t1_p t2_p ... t1_n t2_n ...) + (C t1_r' t2_r' ... t1_p' t2_p' ... t1_n t2_n ...) + for a type constructor C where + * the nominal type arguments are not changed, + * the phantom type arguments may change arbitrarily + * the representational type arguments are again Coercible + + The type constructor can be used undersaturated; then the Coercible + instance is at a higher kind. This does not cause problems. + + The type checker generates evidence in the form of EvCoercion, but the TcCoercion therein has role Representational, which are turned into Core coercions by dsEvTerm in DsBinds. -The evidence for the first three instance is generated here by -getCoercibleInst, for the second instance deferTcSForAllEq is used. +The evidence for the second case is created by deferTcSForAllEq, for the other +cases by getCoercibleInst. When the constraint cannot be solved, it is treated as any other unsolved constraint, i.e. it can turn up in an inferred type signature, or reported to @@ -2085,6 +2096,33 @@ coercible_msg in TcErrors gives additional explanations of why GHC could not find a Coercible instance, so it duplicates some of the logic from getCoercibleInst (in negated form). +Note [Order of Coercible Instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At first glance, the order of the various coercible instances doesn't matter, as +incoherence is no issue here: We do not care how the evidence is constructed, +as long as it is. + +But because of role annotations, the order *can* matter: + + newtype T a = MkT [a] + type role T nominal + + type family F a + type instance F Int = Bool + +Here T's declared role is more restrictive than its inferred role +(representational) would be. If MkT is not in scope, so that the +newtype-unwrapping instance is not available, then this coercible +instance would fail: + Coercible (T Bool) (T (F Int) +But MkT was in scope, *and* if we used it before decomposing on T, +we'd unwrap the newtype (on both sides) to get + Coercible Bool (F Int) +whic succeeds. + +So our current decision is to apply case 3 (newtype-unwrapping) first, +followed by decomposition (case 4). This is strictly more powerful +if the newtype constructor is in scope. See Trac #9117 for a discussion. Note [Instance and Given overlap] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index b9f3d259fc..65bc0b7653 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -9,7 +9,8 @@ This module contains monadic operations over types that contain mutable type variables \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -385,34 +386,34 @@ writeMetaTyVar tyvar ty -------------------- writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM () --- Here the tyvar is for error checking only; +-- Here the tyvar is for error checking only; -- the ref cell must be for the same tyvar writeMetaTyVarRef tyvar ref ty - | not debugIsOn + | not debugIsOn = do { traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty) ; writeMutVar ref (Indirect ty) } -- Everything from here on only happens if DEBUG is on | otherwise - = do { meta_details <- readMutVar ref; + = do { meta_details <- readMutVar ref; -- Zonk kinds to allow the error check to work - ; zonked_tv_kind <- zonkTcKind tv_kind + ; zonked_tv_kind <- zonkTcKind tv_kind ; zonked_ty_kind <- zonkTcKind ty_kind -- Check for double updates - ; ASSERT2( isFlexi meta_details, + ; ASSERT2( isFlexi meta_details, hang (text "Double update of meta tyvar") 2 (ppr tyvar $$ ppr meta_details) ) traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty) - ; writeMutVar ref (Indirect ty) - ; when ( not (isPredTy tv_kind) + ; writeMutVar ref (Indirect ty) + ; when ( not (isPredTy tv_kind) -- Don't check kinds for updates to coercion variables && not (zonked_ty_kind `tcIsSubKind` zonked_tv_kind)) $ WARN( True, hang (text "Ill-kinded update to meta tyvar") - 2 ( ppr tyvar <+> text "::" <+> ppr tv_kind - <+> text ":=" - <+> ppr ty <+> text "::" <+> ppr ty_kind) ) + 2 ( ppr tyvar <+> text "::" <+> (ppr tv_kind $$ ppr zonked_tv_kind) + <+> text ":=" + <+> ppr ty <+> text "::" <+> (ppr ty_kind $$ ppr zonked_ty_kind) ) ) (return ()) } where tv_kind = tyVarKind tyvar diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index 08ce7745d3..32b6d1e326 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -6,7 +6,8 @@ TcMatches: Typecheck some @Matches@ \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# LANGUAGE CPP, 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 @@ -109,7 +110,7 @@ tcMatchesCase :: (Outputable (body Name)) => tcMatchesCase ctxt scrut_ty matches res_ty | isEmptyMatchGroup matches -- Allow empty case expressions - = return (MG { mg_alts = [], mg_arg_tys = [scrut_ty], mg_res_ty = res_ty }) + = return (MG { mg_alts = [], mg_arg_tys = [scrut_ty], mg_res_ty = res_ty, mg_origin = mg_origin matches }) | otherwise = tcMatches ctxt [scrut_ty] res_ty matches @@ -180,10 +181,10 @@ data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module -> TcRhoType -> TcM (Located (body TcId)) } -tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = matches }) +tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = matches, mg_origin = origin }) = ASSERT( not (null matches) ) -- Ensure that rhs_ty is filled in do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches - ; return (MG { mg_alts = matches', mg_arg_tys = pat_tys, mg_res_ty = rhs_ty }) } + ; return (MG { mg_alts = matches', mg_arg_tys = pat_tys, mg_res_ty = rhs_ty, mg_origin = origin }) } ------------- tcMatch :: (Outputable (body Name)) => TcMatchCtxt body diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 0c8c09d54a..cfc76d6538 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -6,7 +6,8 @@ TcPat: Typechecking patterns \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# LANGUAGE CPP, 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 @@ -531,9 +532,9 @@ tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside -- so that we can experiment with lazy tuple-matching. -- This is a pretty odd place to make the switch, but -- it was easy to do. - ; let pat_ty' = mkTyConApp tc arg_tys - -- pat_ty /= pat_ty iff coi /= IdCo - unmangled_result = TuplePat pats' boxity pat_ty' + ; let + unmangled_result = TuplePat pats' boxity arg_tys + -- pat_ty /= pat_ty iff coi /= IdCo possibly_mangled_result | gopt Opt_IrrefutableTuples dflags && isBoxed boxity = LazyPat (noLoc unmangled_result) @@ -730,13 +731,14 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside (zipTopTvSubst univ_tvs ctxt_res_tys) ex_tvs -- Get location from monad, not from ex_tvs - ; let pat_ty' = mkTyConApp tycon ctxt_res_tys + ; let -- pat_ty' = mkTyConApp tycon ctxt_res_tys -- pat_ty' is type of the actual constructor application -- pat_ty' /= pat_ty iff coi /= IdCo - + arg_tys' = substTys tenv arg_tys - ; traceTc "tcConPat" (ppr con_name $$ ppr ex_tvs' $$ ppr pat_ty' $$ ppr arg_tys') + ; traceTc "tcConPat" (vcat [ ppr con_name, ppr univ_tvs, ppr ex_tvs, ppr eq_spec + , ppr ex_tvs', ppr ctxt_res_tys, ppr arg_tys' ]) ; if null ex_tvs && null eq_spec && null theta then do { -- The common case; no class bindings etc -- (see Note [Arrows and patterns]) @@ -746,7 +748,7 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside pat_tvs = [], pat_dicts = [], pat_binds = emptyTcEvBinds, pat_args = arg_pats', - pat_ty = pat_ty', + pat_arg_tys = ctxt_res_tys, pat_wrap = idHsWrapper } ; return (mkHsWrapPat wrap res_pat pat_ty, res) } @@ -779,7 +781,7 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside pat_dicts = given, pat_binds = ev_binds, pat_args = arg_pats', - pat_ty = pat_ty', + pat_arg_tys = ctxt_res_tys, pat_wrap = idHsWrapper } ; return (mkHsWrapPat wrap res_pat pat_ty, res) } } @@ -789,11 +791,9 @@ tcPatSynPat :: PatEnv -> Located Name -> PatSyn -> HsConPatDetails Name -> TcM a -> TcM (Pat TcId, a) tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside - = do { let (univ_tvs, ex_tvs, (prov_theta, req_theta)) = patSynSig pat_syn - arg_tys = patSynArgTys pat_syn - ty = patSynType pat_syn + = do { let (univ_tvs, ex_tvs, prov_theta, req_theta, arg_tys, ty) = patSynSig pat_syn - ; (_univ_tvs', inst_tys, subst) <- tcInstTyVars univ_tvs + ; (univ_tvs', inst_tys, subst) <- tcInstTyVars univ_tvs ; checkExistentials ex_tvs penv ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs @@ -813,14 +813,12 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside ; prov_dicts' <- newEvVars prov_theta' - {- + -- Using a pattern synonym requires the PatternSynonyms + -- language flag to keep consistent with #2905 ; patsyns_on <- xoptM Opt_PatternSynonyms ; checkTc patsyns_on (ptext (sLit "A pattern match on a pattern synonym requires PatternSynonyms")) - -- Trac #2905 decided that a *pattern-match* of a GADT - -- should require the GADT language flag. - -- Re TypeFamilies see also #7156 --} + ; let skol_info = case pe_ctxt penv of LamPat mc -> PatSkol (PatSynCon pat_syn) mc LetPat {} -> UnkSkol -- Doesn't matter @@ -839,7 +837,7 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside pat_dicts = prov_dicts', pat_binds = ev_binds, pat_args = arg_pats', - pat_ty = ty', + pat_arg_tys = mkTyVarTys univ_tvs', pat_wrap = req_wrap } ; return (mkHsWrapPat wrap res_pat pat_ty, res) } diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs index 94ee199d30..b5fbc295f5 100644 --- a/compiler/typecheck/TcPatSyn.lhs +++ b/compiler/typecheck/TcPatSyn.lhs @@ -5,7 +5,9 @@ \section[TcPatSyn]{Typechecking pattern synonym declarations} \begin{code} -module TcPatSyn (tcPatSynDecl) where +{-# LANGUAGE CPP #-} + +module TcPatSyn (tcPatSynDecl, tcPatSynWrapper) where import HsSyn import TcPat @@ -16,13 +18,13 @@ import TysPrim import Name import SrcLoc import PatSyn -import Maybes import NameSet import Panic import Outputable import FastString import Var import Id +import IdInfo( IdDetails( VanillaId ) ) import TcBinds import BasicTypes import TcSimplify @@ -32,43 +34,43 @@ import Data.Monoid import Bag import TcEvidence import BuildTyCl +import TypeRep #include "HsVersions.h" \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 ; let (arg_names, is_infix) = case details of - PrefixPatSyn names -> (map unLoc names, False) + PrefixPatSyn names -> (map unLoc names, False) InfixPatSyn name1 name2 -> (map unLoc [name1, name2], True) - ; ((lpat', args), wanted) <- captureConstraints $ - tcPat PatSyn lpat pat_ty $ mapM tcLookupId arg_names + ; ((lpat', args), wanted) <- captureConstraints $ + tcPat PatSyn lpat pat_ty $ + mapM tcLookupId arg_names ; let named_taus = (name, pat_ty):map (\arg -> (getName arg, varType arg)) args ; traceTc "tcPatSynDecl::wanted" (ppr named_taus $$ ppr wanted) - ; (qtvs, given_dicts, _mr_bites, ev_binds) <- simplifyInfer True False named_taus wanted - ; let req_dicts = given_dicts + ; (qtvs, req_dicts, _mr_bites, ev_binds) <- simplifyInfer True False named_taus wanted ; (ex_vars, prov_dicts) <- tcCollectEx lpat' - ; let univ_tvs = filter (not . (`elemVarSet` ex_vars)) qtvs - ex_tvs = varSetElems ex_vars - - ; pat_ty <- zonkTcType pat_ty - ; args <- mapM zonkId args + ; let univ_tvs = filter (not . (`elemVarSet` ex_vars)) qtvs + ex_tvs = varSetElems ex_vars + prov_theta = map evVarPred prov_dicts + req_theta = map evVarPred req_dicts - ; univ_tvs <- mapM zonkQuantifiedTyVar univ_tvs - ; let prov_theta = map evVarPred prov_dicts - req_theta = map evVarPred req_dicts + ; univ_tvs <- mapM zonkQuantifiedTyVar univ_tvs + ; ex_tvs <- mapM zonkQuantifiedTyVar ex_tvs ; prov_theta <- zonkTcThetaType prov_theta - ; req_theta <- zonkTcThetaType req_theta + ; req_theta <- zonkTcThetaType req_theta + ; pat_ty <- zonkTcType pat_ty + ; args <- mapM zonkId args ; traceTc "tcPatSynDecl: ex" (ppr ex_tvs $$ ppr prov_theta $$ @@ -91,19 +93,24 @@ 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 - args + (map varType args) 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} + +\begin{code} tcPatSynMatcher :: Located Name -> LPat Id -> [Var] @@ -113,12 +120,18 @@ tcPatSynMatcher :: Located Name -> ThetaType -> ThetaType -> TcType -> TcM (Id, LHsBinds Id) +-- See Note [Matchers and wrappers for pattern synonyms] in PatSyn tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_dicts prov_theta req_theta pat_ty = do { res_tv <- zonkQuantifiedTyVar =<< newFlexiTyVar liftedTypeKind - ; (matcher_id, res_ty, cont_ty) <- mkPatSynMatcherId name args - univ_tvs ex_tvs - prov_theta req_theta - pat_ty res_tv + ; matcher_name <- newImplicitBinder name mkMatcherOcc + ; let res_ty = TyVarTy res_tv + cont_ty = mkSigmaTy ex_tvs prov_theta $ + mkFunTys (map varType args) res_ty + + ; let matcher_tau = mkFunTys [pat_ty, cont_ty, res_ty] res_ty + matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau + matcher_id = mkExportedLocalId VanillaId matcher_name matcher_sigma + ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id)) ; let matcher_lid = L loc matcher_id @@ -141,18 +154,21 @@ tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_d MG{ mg_alts = cases , mg_arg_tys = [pat_ty] , mg_res_ty = res_ty + , mg_origin = Generated } body' = noLoc $ HsLam $ MG{ mg_alts = [mkSimpleMatch args body] , mg_arg_tys = [pat_ty, cont_ty, res_ty] , mg_res_ty = res_ty + , mg_origin = Generated } match = mkMatch [] (mkHsLams (res_tv:univ_tvs) req_dicts body') EmptyLocalBinds mg = MG{ mg_alts = [match] , mg_arg_tys = [] , mg_res_ty = res_ty + , mg_origin = Generated } ; let bind = FunBind{ fun_id = matcher_lid @@ -161,7 +177,7 @@ tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_d , fun_co_fn = idHsWrapper , bind_fvs = emptyNameSet , fun_tick = Nothing } - matcher_bind = unitBag (Generated, noLoc bind) + matcher_bind = unitBag (noLoc bind) ; traceTc "tcPatSynMatcher" (ppr matcher_bind) @@ -171,115 +187,182 @@ 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)) -tcPatSynWrapper lname lpat dir args univ_tvs ex_tvs theta pat_ty - = do { let argNames = mkNameSet (map Var.varName args) - ; m_expr <- runMaybeT $ tcPatToExpr argNames lpat - ; case (dir, m_expr) 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 +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 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, qtvs') <- tcInstSkolTyVars qtvs - ; let theta' = substTheta subst theta + ; (subst, wrapper_tvs) <- tcInstSkolTyVars qtvs + ; let wrapper_theta = substTheta subst theta pat_ty' = substTy subst pat_ty args' = map (\arg -> setVarType arg $ substTy subst (varType arg)) args - - ; wrapper_id <- mkPatSynWrapperId name args qtvs theta pat_ty - ; let wrapper_name = getName wrapper_id - wrapper_lname = L loc wrapper_name - -- (wrapper_tvs, wrapper_theta, wrapper_tau) = tcSplitSigmaTy (idType wrapper_id) - wrapper_tvs = qtvs' - wrapper_theta = theta' wrapper_tau = mkFunTys (map varType args') pat_ty' + wrapper_sigma = mkSigmaTy wrapper_tvs wrapper_theta wrapper_tau + + ; wrapper_name <- newImplicitBinder name mkDataConWrapperOcc + ; return $ mkExportedLocalId VanillaId wrapper_name wrapper_sigma } - ; let wrapper_args = map (noLoc . VarPat . Var.varName) args' - wrapper_match = mkMatch wrapper_args lexpr EmptyLocalBinds - bind = mkTopFunBind 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 (Generated, lbind) +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} + +Note [As-patterns in pattern synonym definitions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcNothing :: MaybeT TcM a -tcNothing = MaybeT (return Nothing) +The rationale for rejecting as-patterns in pattern synonym definitions +is that an as-pattern would introduce nonindependent pattern synonym +arguments, e.g. given a pattern synonym like: -withLoc :: (a -> MaybeT TcM b) -> Located a -> MaybeT TcM (Located b) -withLoc fn (L loc x) = MaybeT $ setSrcSpan loc $ - do { y <- runMaybeT $ fn x - ; return (fmap (L loc) y) } + pattern K x y = x@(Just y) -tcPatToExpr :: NameSet -> LPat Name -> MaybeT TcM (LHsExpr Name) +one could write a nonsensical function like + + f (K Nothing x) = ... + +or + g (K (Just True) False) = ... + +\begin{code} +tcCheckPatSynPat :: LPat Name -> TcM () +tcCheckPatSynPat = go + where + go :: LPat Name -> TcM () + go = addLocM go1 + + go1 :: Pat Name -> TcM () + go1 (ConPatIn _ info) = mapM_ go (hsConPatArgs info) + go1 VarPat{} = return () + go1 WildPat{} = return () + go1 p@(AsPat _ _) = asPatInPatSynErr p + go1 (LazyPat pat) = go pat + go1 (ParPat pat) = go pat + go1 (BangPat pat) = go pat + go1 (PArrPat pats _) = mapM_ go pats + go1 (ListPat pats _ _) = mapM_ go pats + go1 (TuplePat pats _ _) = mapM_ go pats + go1 LitPat{} = return () + go1 NPat{} = return () + go1 (SigPatIn pat _) = go pat + go1 (ViewPat _ pat _) = go pat + go1 p@SplicePat{} = thInPatSynErr p + go1 p@QuasiQuotePat{} = thInPatSynErr p + go1 p@NPlusKPat{} = nPlusKPatInPatSynErr p + go1 ConPatOut{} = panic "ConPatOut in output of renamer" + go1 SigPatOut{} = panic "SigPatOut in output of renamer" + go1 CoPat{} = panic "CoPat in output of renamer" + +asPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a +asPatInPatSynErr pat + = failWithTc $ + hang (ptext (sLit "Pattern synonym definition cannot contain as-patterns (@):")) + 2 (ppr pat) + +thInPatSynErr :: OutputableBndr name => Pat name -> TcM a +thInPatSynErr pat + = failWithTc $ + hang (ptext (sLit "Pattern synonym definition cannot contain Template Haskell:")) + 2 (ppr pat) + +nPlusKPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a +nPlusKPatInPatSynErr pat + = failWithTc $ + hang (ptext (sLit "Pattern synonym definition cannot contain n+k-pattern:")) + 2 (ppr pat) + +tcPatToExpr :: NameSet -> LPat Name -> Maybe (LHsExpr Name) tcPatToExpr lhsVars = go where - go :: LPat Name -> MaybeT TcM (LHsExpr Name) + go :: LPat Name -> Maybe (LHsExpr Name) go (L loc (ConPatIn conName info)) - = MaybeT . setSrcSpan loc . runMaybeT $ do + = do { let con = L loc (HsVar (unLoc conName)) ; exprs <- mapM go (hsConPatArgs info) ; return $ foldl (\x y -> L loc (HsApp x y)) con exprs } - go p = withLoc go1 p + go (L loc p) = fmap (L loc) $ go1 p - go1 :: Pat Name -> MaybeT TcM (HsExpr Name) + go1 :: Pat Name -> Maybe (HsExpr Name) go1 (VarPat var) - | var `elemNameSet` lhsVars = return (HsVar var) - | otherwise = tcNothing - go1 p@(AsPat _ _) = asPatInPatSynErr p - go1 (LazyPat pat) = fmap HsPar (go pat) - go1 (ParPat pat) = fmap HsPar (go pat) - go1 (BangPat pat) = fmap HsPar (go pat) + | var `elemNameSet` lhsVars = return $ HsVar var + | otherwise = Nothing + go1 (LazyPat pat) = fmap HsPar $ go pat + go1 (ParPat pat) = fmap HsPar $ go pat + go1 (BangPat pat) = fmap HsPar $ go pat go1 (PArrPat pats ptt) = do { exprs <- mapM go pats - ; return (ExplicitPArr ptt exprs) } + ; return $ ExplicitPArr ptt exprs } go1 (ListPat pats ptt reb) = do { exprs <- mapM go pats - ; return (ExplicitList ptt (fmap snd reb) exprs) } + ; return $ ExplicitList ptt (fmap snd reb) exprs } go1 (TuplePat pats box _) = do { exprs <- mapM go pats ; return (ExplicitTuple (map Present exprs) box) } - go1 (LitPat lit) = return (HsLit lit) - go1 (NPat n Nothing _) = return (HsOverLit n) - go1 (NPat n (Just neg) _) = return (noLoc neg `HsApp` noLoc (HsOverLit n)) + go1 (LitPat lit) = return $ HsLit lit + go1 (NPat n Nothing _) = return $ HsOverLit n + go1 (NPat n (Just neg) _) = return $ noLoc neg `HsApp` noLoc (HsOverLit n) go1 (SigPatIn pat (HsWB ty _ _)) = do { expr <- go pat - ; return (ExprWithTySig expr ty) } + ; return $ ExprWithTySig expr ty } go1 (ConPatOut{}) = panic "ConPatOut in output of renamer" go1 (SigPatOut{}) = panic "SigPatOut in output of renamer" go1 (CoPat{}) = panic "CoPat in output of renamer" - go1 _ = tcNothing - -asPatInPatSynErr :: OutputableBndr name => Pat name -> MaybeT TcM a -asPatInPatSynErr pat - = MaybeT . failWithTc $ - hang (ptext (sLit "Pattern synonym definition cannot contain as-patterns (@):")) - 2 (ppr pat) + go1 _ = Nothing cannotInvertPatSynErr :: OutputableBndr name => LPat name -> TcM a cannotInvertPatSynErr (L loc pat) @@ -287,6 +370,12 @@ cannotInvertPatSynErr (L loc pat) hang (ptext (sLit "Right-hand side of bidirectional pattern synonym cannot be used as an expression")) 2 (ppr pat) +-- Walk the whole pattern and for all ConPatOuts, collect the +-- existentially-bound type variables and evidence binding variables. +-- +-- These are used in computing the type of a pattern synonym and also +-- in generating matcher functions, since success continuations need +-- to be passed these pattern-bound evidences. tcCollectEx :: LPat Id -> TcM (TyVarSet, [EvVar]) tcCollectEx = return . go where 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 90d7151c69..cd27e9d044 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -5,6 +5,8 @@ \section[TcMovectle]{Typechecking a whole module} \begin{code} +{-# LANGUAGE CPP, NondecreasingIndentation #-} + module TcRnDriver ( #ifdef GHCI tcRnStmt, tcRnExpr, tcRnType, @@ -18,8 +20,7 @@ module TcRnDriver ( tcRnLookupName, tcRnGetInfo, tcRnModule, tcRnModuleTcRnM, - tcTopSrcDecls, - tcRnExtCore + tcTopSrcDecls ) where #ifdef GHCI @@ -58,10 +59,9 @@ import LoadIface import RnNames import RnEnv import RnSource -import PprCore -import CoreSyn import ErrUtils import Id +import IdInfo( IdDetails( VanillaId ) ) import VarEnv import Module import UniqFM @@ -79,14 +79,11 @@ import DataCon import Type import Class import CoAxiom -import Inst ( tcGetInstEnvs, tcGetInsts ) +import Inst ( tcGetInstEnvs ) import Annotations import Data.List ( sortBy ) -import Data.IORef ( readIORef ) import Data.Ord -#ifndef GHCI -import BasicTypes ( Origin(..) ) -#else +#ifdef GHCI import BasicTypes hiding( SuccessFlag(..) ) import TcType ( isUnitTy, isTauTy ) import TcHsType @@ -308,107 +305,6 @@ tcRnImports hsc_env import_decls %************************************************************************ %* * - Type-checking external-core modules -%* * -%************************************************************************ - -\begin{code} -tcRnExtCore :: HscEnv - -> HsExtCore RdrName - -> IO (Messages, Maybe ModGuts) - -- Nothing => some error occurred - -tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) - -- The decls are IfaceDecls; all names are original names - = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; - - initTc hsc_env ExtCoreFile False this_mod $ do { - - let { ldecls = map noLoc decls } ; - - -- Bring the type and class decls into scope - -- ToDo: check that this doesn't need to extract the val binds. - -- It seems that only the type and class decls need to be in scope below because - -- (a) tcTyAndClassDecls doesn't need the val binds, and - -- (b) tcExtCoreBindings doesn't need anything - -- (in fact, it might not even need to be in the scope of - -- this tcg_env at all) - (tc_envs, _bndrs) <- getLocalNonValBinders emptyFsEnv {- no fixity decls -} - (mkFakeGroup ldecls) ; - setEnvs tc_envs $ do { - - (rn_decls, _fvs) <- checkNoErrs $ rnTyClDecls [] [mkTyClGroup ldecls] ; - -- The empty list is for extra dependencies coming from .hs-boot files - -- See Note [Extra dependencies from .hs-boot files] in RnSource - - -- Dump trace of renaming part - rnDump (ppr rn_decls) ; - - -- Typecheck them all together so that - -- any mutually recursive types are done right - -- Just discard the auxiliary bindings; they are generated - -- only for Haskell source code, and should already be in Core - tcg_env <- tcTyAndClassDecls emptyModDetails rn_decls ; - safe_mode <- liftIO $ finalSafeMode (hsc_dflags hsc_env) tcg_env ; - dep_files <- liftIO $ readIORef (tcg_dependent_files tcg_env) ; - - setGblEnv tcg_env $ do { - -- Make the new type env available to stuff slurped from interface files - - -- Now the core bindings - core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ; - - - -- Wrap up - let { - bndrs = bindersOfBinds core_binds ; - my_exports = map (Avail . idName) bndrs ; - -- ToDo: export the data types also? - - mod_guts = ModGuts { mg_module = this_mod, - mg_boot = False, - mg_used_names = emptyNameSet, -- ToDo: compute usage - mg_used_th = False, - mg_dir_imps = emptyModuleEnv, -- ?? - mg_deps = noDependencies, -- ?? - mg_exports = my_exports, - mg_tcs = tcg_tcs tcg_env, - mg_insts = tcg_insts tcg_env, - mg_fam_insts = tcg_fam_insts tcg_env, - mg_inst_env = tcg_inst_env tcg_env, - mg_fam_inst_env = tcg_fam_inst_env tcg_env, - mg_patsyns = [], -- TODO - mg_rules = [], - mg_vect_decls = [], - mg_anns = [], - mg_binds = core_binds, - - -- Stubs - mg_rdr_env = emptyGlobalRdrEnv, - mg_fix_env = emptyFixityEnv, - mg_warns = NoWarnings, - mg_foreign = NoStubs, - mg_hpc_info = emptyHpcInfo False, - mg_modBreaks = emptyModBreaks, - mg_vect_info = noVectInfo, - mg_safe_haskell = safe_mode, - mg_trust_pkg = False, - mg_dependent_files = dep_files - } } ; - - tcCoreDump mod_guts ; - - return mod_guts - }}}} - -mkFakeGroup :: [LTyClDecl a] -> HsGroup a -mkFakeGroup decls -- Rather clumsy; lots of unused fields - = emptyRdrGroup { hs_tyclds = [mkTyClGroup decls] } -\end{code} - - -%************************************************************************ -%* * Type-checking the top level of a module %* * %************************************************************************ @@ -649,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] @@ -671,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 [ (Generated, 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 () @@ -737,7 +648,7 @@ checkHiBootIface where boot_dfun = instanceDFunId boot_inst boot_inst_ty = idType boot_dfun - local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty + local_boot_dfun = Id.mkExportedLocalId VanillaId (idName boot_dfun) boot_inst_ty -- This has to compare the TyThing from the .hi-boot file to the TyThing @@ -785,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) && @@ -941,218 +849,6 @@ rnTopSrcDecls extra_deps group %************************************************************************ %* * - AMP warnings - The functions defined here issue warnings according to - the 2013 Applicative-Monad proposal. (Trac #8004) -%* * -%************************************************************************ - -Note [No AMP warning with NoImplicitPrelude] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If you have -XNoImplicitPrelude, then we suppress the AMP warnings. -The AMP warnings need access to Monad, Applicative, etc, and they -are defined in 'base'. If, when compiling package 'ghc-prim' (say), -you try to load Monad (from 'base'), chaos results because 'base' -depends on 'ghc-prim'. See Note [Home module load error] in LoadIface, -and Trac #8320. - -Using -XNoImplicitPrelude is a proxy for ensuring that all the -'base' modules are below the home module in the dependency tree. - -\begin{code} --- | Main entry point for generating AMP warnings -tcAmpWarn :: TcM () -tcAmpWarn = - do { implicit_prel <- xoptM Opt_ImplicitPrelude - ; warnFlag <- woptM Opt_WarnAMP - ; when (warnFlag && implicit_prel) $ do { - -- See Note [No AMP warning with NoImplicitPrelude] - - -- Monad without Applicative - ; tcAmpMissingParentClassWarn monadClassName - applicativeClassName - - -- MonadPlus without Alternative - ; tcAmpMissingParentClassWarn monadPlusClassName - alternativeClassName - - -- Custom local definitions of join/pure/<*> - ; mapM_ tcAmpFunctionWarn [joinMName, apAName, pureAName] - }} - - - --- | Warn on local definitions of names that would clash with Prelude versions, --- i.e. join/pure/<*> --- --- A name clashes if the following criteria are met: --- 1. It would is imported (unqualified) from Prelude --- 2. It is locally defined in the current module --- 3. It has the same literal name as the reference function --- 4. It is not identical to the reference function -tcAmpFunctionWarn :: Name -- ^ Name to check, e.g. joinMName for join - -> TcM () -tcAmpFunctionWarn name = do - { traceTc "tcAmpFunctionWarn/wouldBeImported" empty - -- Is the name imported (unqualified) from Prelude? (Point 4 above) - ; rnImports <- fmap (map unLoc . tcg_rn_imports) getGblEnv - -- (Note that this automatically handles -XNoImplicitPrelude, as Prelude - -- will not appear in rnImports automatically if it is set.) - - -- Continue only the name is imported from Prelude - ; when (tcAmpImportViaPrelude name rnImports) $ do - -- Handle 2.-4. - { rdrElts <- fmap (concat . occEnvElts . tcg_rdr_env) getGblEnv - - ; let clashes :: GlobalRdrElt -> Bool - clashes x = and [ gre_prov x == LocalDef - , nameOccName (gre_name x) == nameOccName name - , gre_name x /= name - ] - - -- List of all offending definitions - clashingElts :: [GlobalRdrElt] - clashingElts = filter clashes rdrElts - - ; traceTc "tcAmpFunctionWarn/amp_prelude_functions" - (hang (ppr name) 4 (sep [ppr clashingElts])) - - ; let warn_msg x = addWarnAt (nameSrcSpan $ gre_name x) . hsep $ - [ ptext (sLit "Local definition of") - , quotes . ppr . nameOccName $ gre_name x - , ptext (sLit "clashes with a future Prelude name") - , ptext (sLit "- this will become an error in GHC 7.10,") - , ptext (sLit "under the Applicative-Monad Proposal.") - ] - ; mapM_ warn_msg clashingElts - }} - --- | Is the given name imported via Prelude? --- --- This function makes sure that e.g. "import Prelude (map)" should silence --- AMP warnings about "join" even when they are locally defined. --- --- Possible scenarios: --- a) Prelude is imported implicitly, issue warnings. --- b) Prelude is imported explicitly, but without mentioning the name in --- question. Issue no warnings. --- c) Prelude is imported hiding the name in question. Issue no warnings. --- d) Qualified import of Prelude, no warnings. -tcAmpImportViaPrelude :: Name - -> [ImportDecl Name] - -> Bool -tcAmpImportViaPrelude name = any importViaPrelude - where - isPrelude :: ImportDecl Name -> Bool - isPrelude imp = unLoc (ideclName imp) == pRELUDE_NAME - - -- Implicit (Prelude) import? - isImplicit :: ImportDecl Name -> Bool - isImplicit = ideclImplicit - - -- Unqualified import? - isUnqualified :: ImportDecl Name -> Bool - isUnqualified = not . ideclQualified - - second :: (a -> b) -> (x, a) -> (x, b) - second f (x, y) = (x, f y) - - -- List of explicitly imported (or hidden) Names from a single import. - -- Nothing -> No explicit imports - -- Just (False, <names>) -> Explicit import list of <names> - -- Just (True , <names>) -> Explicit hiding of <names> - importList :: ImportDecl Name -> Maybe (Bool, [Name]) - importList = fmap (second (map (ieName . unLoc))) . ideclHiding - - -- Check whether the given name would be imported (unqualified) from - -- an import declaration. - importViaPrelude :: ImportDecl Name -> Bool - importViaPrelude x = isPrelude x && isUnqualified x && or [ - -- Whole Prelude imported -> potential clash - isImplicit x - -- Explicit import/hiding list, if applicable - , case importList x of - Just (False, explicit) -> nameOccName name `elem` map nameOccName explicit - Just (True , hidden ) -> nameOccName name `notElem` map nameOccName hidden - Nothing -> False - ] - --- | Issue a warning for instance definitions lacking a should-be parent class. --- Used for Monad without Applicative and MonadPlus without Alternative. -tcAmpMissingParentClassWarn :: Name -- ^ Class instance is defined for - -> Name -- ^ Class it should also be instance of - -> TcM () - --- Notation: is* is for classes the type is an instance of, should* for those --- that it should also be an instance of based on the corresponding --- is*. --- Example: in case of Applicative/Monad: is = Monad, --- should = Applicative -tcAmpMissingParentClassWarn isName shouldName - = do { isClass' <- tcLookupClass_maybe isName - ; shouldClass' <- tcLookupClass_maybe shouldName - ; case (isClass', shouldClass') of - (Just isClass, Just shouldClass) -> do - { localInstances <- tcGetInsts - ; let isInstance m = is_cls m == isClass - isInsts = filter isInstance localInstances - ; traceTc "tcAmpMissingParentClassWarn/isInsts" (ppr isInsts) - ; forM_ isInsts $ checkShouldInst isClass shouldClass - } - _ -> return () - } - where - -- Checks whether the desired superclass exists in a given environment. - checkShouldInst :: Class -- ^ Class of existing instance - -> Class -- ^ Class there should be an instance of - -> ClsInst -- ^ Existing instance - -> TcM () - checkShouldInst isClass shouldClass isInst - = do { instEnv <- tcGetInstEnvs - ; let (instanceMatches, shouldInsts, _) - = lookupInstEnv instEnv shouldClass (is_tys isInst) - - ; traceTc "tcAmpMissingParentClassWarn/checkShouldInst" - (hang (ppr isInst) 4 - (sep [ppr instanceMatches, ppr shouldInsts])) - - -- "<location>: Warning: <type> is an instance of <is> but not <should>" - -- e.g. "Foo is an instance of Monad but not Applicative" - ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst - warnMsg (Just name:_) = - addWarnAt instLoc . hsep $ - [ quotes (ppr $ nameOccName name) - , ptext (sLit "is an instance of") - , ppr . nameOccName $ className isClass - , ptext (sLit "but not") - , ppr . nameOccName $ className shouldClass - , ptext (sLit "- this will become an error in GHC 7.10,") - , ptext (sLit "under the Applicative-Monad Proposal.") - ] - warnMsg _ = return () - ; when (null shouldInsts && null instanceMatches) $ - warnMsg (is_tcs isInst) - } - - --- | Looks up a class, returning Nothing on failure. Similar to --- TcEnv.tcLookupClass, but does not issue any error messages. --- --- In particular, it may be called by the AMP check on, say, --- Control.Applicative.Applicative, well before Control.Applicative --- has been compiled. In this case we just return Nothing, and the --- AMP test is silently dropped. -tcLookupClass_maybe :: Name -> TcM (Maybe Class) -tcLookupClass_maybe name - = do { mb_thing <- tcLookupImported_maybe name - ; case mb_thing of - Succeeded (ATyCon tc) | Just cls <- tyConClass_maybe tc -> return (Just cls) - _ -> return Nothing } -\end{code} - - -%************************************************************************ -%* * tcTopSrcDecls %* * %************************************************************************ @@ -1184,7 +880,6 @@ tcTopSrcDecls boot_details -- Generate Applicative/Monad proposal (AMP) warnings traceTc "Tc3b" empty ; - tcAmpWarn ; -- Foreign import declarations next. traceTc "Tc4" empty ; @@ -1363,7 +1058,7 @@ check_main dflags tcg_env ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN (mkVarOccFS (fsLit "main")) (getSrcSpan main_name) - ; root_main_id = Id.mkExportedLocalId root_main_name + ; root_main_id = Id.mkExportedLocalId VanillaId root_main_name (mkTyConApp ioTyCon [res_ty]) ; co = mkWpTyApps [res_ty] ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr @@ -1371,7 +1066,7 @@ check_main dflags tcg_env ; return (tcg_env { tcg_main = Just main_name, tcg_binds = tcg_binds tcg_env - `snocBag` (Generated, main_bind), + `snocBag` main_bind, tcg_dus = tcg_dus tcg_env `plusDU` usesOnly (unitFV main_name) -- Record the use of 'main', so that we don't @@ -1606,14 +1301,14 @@ tcUserStmt (L loc (BodyStmt expr _ _ _)) ; let fresh_it = itName uniq loc matches = [mkMatch [] rn_expr emptyLocalBinds] -- [it = expr] - the_bind = L loc $ (mkTopFunBind (L loc fresh_it) matches) { bind_fvs = fvs } + the_bind = L loc $ (mkTopFunBind FromSource (L loc fresh_it) matches) { bind_fvs = fvs } -- Care here! In GHCi the expression might have -- free variables, and they in turn may have free type variables -- (if we are at a breakpoint, say). We must put those free vars -- [let it = expr] let_stmt = L loc $ LetStmt $ HsValBinds $ - ValBindsOut [(NonRecursive,unitBag (FromSource, the_bind))] [] + ValBindsOut [(NonRecursive,unitBag the_bind)] [] -- [it <- e] bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it)) @@ -2043,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 @@ -2079,17 +1774,6 @@ tcDump env -- NB: foreign x-d's have undefined's in their types; -- hence can't show the tc_fords -tcCoreDump :: ModGuts -> TcM () -tcCoreDump mod_guts - = do { dflags <- getDynFlags ; - when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) - (dumpTcRn (pprModGuts mod_guts)) ; - - -- Dump bindings if -ddump-tc - dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) } - where - full_dump = pprCoreBindings (mg_binds mod_guts) - -- It's unpleasant having both pprModGuts and pprModDetails here pprTcGblEnv :: TcGblEnv -> SDoc pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, @@ -2107,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) @@ -2115,12 +1799,6 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, `thenCmp` (is_boot1 `compare` is_boot2) -pprModGuts :: ModGuts -> SDoc -pprModGuts (ModGuts { mg_tcs = tcs - , mg_rules = rules }) - = vcat [ ppr_types [] (mkTypeEnv (map ATyCon tcs)), - ppr_rules rules ] - ppr_types :: [ClsInst] -> TypeEnv -> SDoc ppr_types insts type_env = text "TYPE SIGNATURES" $$ nest 2 (ppr_sigs ids) @@ -2171,13 +1849,5 @@ ppr_tydecls tycons -- Print type constructor info; sort by OccName = vcat (map ppr_tycon (sortBy (comparing getOccName) tycons)) where - ppr_tycon tycon = vcat [ ppr (tyConName tycon) <+> dcolon <+> ppr (tyConKind tycon) - -- Temporarily print the kind signature too - , ppr (tyThingToIfaceDecl (ATyCon tycon)) ] - -ppr_rules :: [CoreRule] -> SDoc -ppr_rules [] = empty -ppr_rules rs = vcat [ptext (sLit "{-# RULES"), - nest 2 (pprRules rs), - ptext (sLit "#-}")] + ppr_tycon tycon = vcat [ ppr (tyThingToIfaceDecl (ATyCon tycon)) ] \end{code} diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index b3d37f6178..9dbc4206a5 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -5,7 +5,9 @@ Functions for working with the typechecker environment (setters, getters...). \begin{code} +{-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + module TcRnMonad( module TcRnMonad, module TcRnTypes, @@ -24,7 +26,6 @@ import Module import RdrName import Name import Type -import Kind ( isSuperKind ) import TcType import InstEnv @@ -49,7 +50,7 @@ import FastString import Panic import Util import Annotations -import BasicTypes( TopLevelFlag, Origin ) +import BasicTypes( TopLevelFlag ) import Control.Exception import Data.IORef @@ -588,11 +589,6 @@ addLocM fn (L loc a) = setSrcSpan loc $ fn a wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b) -wrapOriginLocM :: (a -> TcM r) -> (Origin, Located a) -> TcM (Origin, Located r) -wrapOriginLocM fn (origin, lbind) - = do { lbind' <- wrapLocM fn lbind - ; return (origin, lbind') } - wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c) wrapLocFstM fn (L loc a) = setSrcSpan loc $ do @@ -1136,10 +1132,6 @@ setUntouchables untch thing_inside isTouchableTcM :: TcTyVar -> TcM Bool isTouchableTcM tv - -- Kind variables are always touchable - | isSuperKind (tyVarKind tv) - = return False - | otherwise = do { env <- getLclEnv ; return (isTouchableMetaTyVar (tcl_untch env) tv) } @@ -1213,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} @@ -1255,17 +1248,6 @@ initIfaceTcRn thing_inside ; get_type_env = readTcRef (tcg_type_env_var tcg_env) } ; setEnvs (if_env, ()) thing_inside } -initIfaceExtCore :: IfL a -> TcRn a -initIfaceExtCore thing_inside - = do { tcg_env <- getGblEnv - ; let { mod = tcg_mod tcg_env - ; doc = ptext (sLit "External Core file for") <+> quotes (ppr mod) - ; if_env = IfGblEnv { - if_rec_types = Just (mod, return (tcg_type_env tcg_env)) } - ; if_lenv = mkIfLclEnv mod doc - } - ; setEnvs (if_env, if_lenv) thing_inside } - initIfaceCheck :: HscEnv -> IfG a -> IO a -- Used when checking the up-to-date-ness of the old Iface -- Initialise the environment with no useful info at all diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 44dc3faa1e..f46bdfd2d9 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -16,6 +16,8 @@ For state that is global and should be returned at the end (e.g not part of the stack mechanism), you should use an TcRef (= IORef) to store them. \begin{code} +{-# LANGUAGE CPP #-} + module TcRnTypes( TcRnIf, TcRn, TcM, RnM, IfM, IfL, IfG, -- The monad is opaque outside this module TcRef, @@ -92,7 +94,7 @@ import Class ( Class ) import TyCon ( TyCon ) import ConLike ( ConLike(..) ) import DataCon ( DataCon, dataConUserType, dataConOrigArgTys ) -import PatSyn ( PatSyn, patSynId ) +import PatSyn ( PatSyn, patSynType ) import TcType import Annotations import InstEnv @@ -294,7 +296,7 @@ data TcGblEnv -- ^ Allows us to choose unique DFun names. -- The next fields accumulate the payload of the module - -- The binds, rules and foreign-decl fiels are collected + -- The binds, rules and foreign-decl fields are collected -- initially in un-zonked form and are finally zonked in tcRnSrcDecls tcg_rn_exports :: Maybe [Located (IE Name)], @@ -323,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 @@ -804,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. @@ -1282,6 +1287,8 @@ data Implication ic_fsks :: [TcTyVar], -- Extra flatten-skolems introduced by -- by flattening the givens + -- See Note [Given flatten-skolems] + ic_no_eqs :: Bool, -- True <=> ic_givens have no equalities, for sure -- False <=> ic_givens might have equalities @@ -1741,11 +1748,14 @@ pprSkolInfo ArrowSkol = ptext (sLit "the arrow form") pprSkolInfo (PatSkol cl mc) = case cl of RealDataCon dc -> sep [ ptext (sLit "a pattern with constructor") , nest 2 $ ppr dc <+> dcolon - <+> ppr (dataConUserType dc) <> comma + <+> pprType (dataConUserType dc) <> comma + -- pprType prints forall's regardless of -fprint-explict-foralls + -- which is what we want here, since we might be saying + -- type variable 't' is bound by ... , ptext (sLit "in") <+> pprMatchContext mc ] PatSynCon ps -> sep [ ptext (sLit "a pattern with pattern synonym") , nest 2 $ ppr ps <+> dcolon - <+> ppr (varType (patSynId ps)) <> comma + <+> pprType (patSynType ps) <> comma , ptext (sLit "in") <+> pprMatchContext mc ] pprSkolInfo (InferSkol ids) = sep [ ptext (sLit "the inferred type of") , vcat [ ppr name <+> dcolon <+> ppr ty @@ -1850,9 +1860,9 @@ pprO (DerivOriginDC dc n) = hsep [ ptext (sLit "the"), speakNth n, parens (ptext (sLit "type") <+> quotes (ppr ty)) ] where ty = dataConOrigArgTys dc !! (n-1) pprO (DerivOriginCoerce meth ty1 ty2) - = fsep [ ptext (sLit "the coercion"), ptext (sLit "of the method") - , quotes (ppr meth), ptext (sLit "from type"), quotes (ppr ty1) - , ptext (sLit "to type"), quotes (ppr ty2) ] + = sep [ ptext (sLit "the coercion of the method") <+> quotes (ppr meth) + , ptext (sLit "from type") <+> quotes (ppr ty1) + , nest 2 (ptext (sLit "to type") <+> quotes (ppr ty2)) ] pprO StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration") pprO DefaultOrigin = ptext (sLit "a 'default' declaration") pprO DoOrigin = ptext (sLit "a do statement") diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs index c2f3b6b302..47b38f114b 100644 --- a/compiler/typecheck/TcRules.lhs +++ b/compiler/typecheck/TcRules.lhs @@ -6,7 +6,7 @@ TcRules: Typechecking transformation rules \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index b7faf153ca..9891f77795 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -1,4 +1,6 @@ \begin{code} +{-# LANGUAGE CPP, TypeFamilies #-} + -- Type definitions for the constraint solver module TcSMonad ( @@ -457,6 +459,7 @@ data InertSet , inert_fsks :: [TcTyVar] -- Rigid flatten-skolems (arising from givens) -- allocated in this local scope + -- See Note [Given flatten-skolems] , inert_solved_funeqs :: FunEqMap (CtEvidence, TcType) -- See Note [Type family equations] @@ -474,8 +477,29 @@ data InertSet -- - Stored not necessarily as fully rewritten -- (ToDo: rewrite lazily when we lookup) } +\end{code} +Note [Given flatten-skolems] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we simplify the implication + forall b. C (F a) b => (C (F a) beta, blah) +We'll flatten the givens, introducing a flatten-skolem, so the +givens effectively look like + (C fsk b, F a ~ fsk) +Then we simplify the wanteds, transforming (C (F a) beta) to (C fsk beta). +Now, if we don't solve that wanted, we'll put it back into the residual +implication. But where is fsk bound? + +We solve this by recording the given flatten-skolems in the implication +(the ic_fsks field), so it's as if we change the implication to + forall b, fsk. (C fsk b, F a ~ fsk) => (C fsk beta, blah) + +We don't need to explicitly record the (F a ~ fsk) constraint in the implication +because we can recover it from inside the fsk TyVar itself. But we do need +to treat that (F a ~ fsk) as a new given. See the fsk_bag stuff in +TcInteract.solveInteractGiven. +\begin{code} instance Outputable InertCans where ppr ics = vcat [ ptext (sLit "Equalities:") <+> vcat (map ppr (varEnvElts (inert_eqs ics))) @@ -502,9 +526,9 @@ emptyInert , inert_funeqs = emptyFunEqs , inert_irreds = emptyCts , inert_insols = emptyCts - , inert_no_eqs = True + , inert_no_eqs = True -- See Note [inert_fsks and inert_no_eqs] } - , inert_fsks = [] + , inert_fsks = [] -- See Note [inert_fsks and inert_no_eqs] , inert_flat_cache = emptyFunEqs , inert_solved_funeqs = emptyFunEqs , inert_solved_dicts = emptyDictMap } @@ -517,10 +541,12 @@ addInertCan ics item@(CTyEqCan { cc_ev = ev }) (inert_eqs ics) (cc_tyvar item) [item] , inert_no_eqs = isFlatSkolEv ev && inert_no_eqs ics } + -- See Note [When does an implication have given equalities?] in TcSimplify addInertCan ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys, cc_ev = ev }) = ics { inert_funeqs = addFunEq (inert_funeqs ics) tc tys item , inert_no_eqs = isFlatSkolEv ev && inert_no_eqs ics } + -- See Note [When does an implication have given equalities?] in TcSimplify addInertCan ics item@(CIrredEvCan {}) = ics { inert_irreds = inert_irreds ics `Bag.snocBag` item @@ -597,7 +623,7 @@ prepareInertsForImplications is , inert_irreds = Bag.filterBag isGivenCt irreds , inert_dicts = filterDicts isGivenCt dicts , inert_insols = emptyCts - , inert_no_eqs = True -- Ready for each implication + , inert_no_eqs = True -- See Note [inert_fsks and inert_no_eqs] } is_given_eq :: [Ct] -> Bool @@ -1121,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 $ @@ -1150,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 @@ -1169,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 @@ -1253,19 +1279,35 @@ getUntouchables :: TcS Untouchables getUntouchables = wrapTcS TcM.getUntouchables getGivenInfo :: TcS a -> TcS (Bool, [TcTyVar], a) --- Run thing_inside, returning info on --- a) whether we got any new equalities --- b) which new (given) flatten skolems were generated +-- See Note [inert_fsks and inert_no_eqs] getGivenInfo thing_inside - = do { updInertTcS reset_vars - ; res <- thing_inside - ; is <- getTcSInerts + = 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) } where reset_vars :: InertSet -> InertSet reset_vars is = is { inert_cans = (inert_cans is) { inert_no_eqs = True } , inert_fsks = [] } +\end{code} +Note [inert_fsks and inert_no_eqs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The function getGivenInfo runs thing_inside to see what new flatten-skolems +and equalities are generated by thing_inside. To that end, + * it initialises inert_fsks, inert_no_eqs + * runs thing_inside + * reads out inert_fsks, inert_no_eqs +This is the only place where it matters what inert_fsks and inert_no_eqs +are initialised to. In other places (eg emptyIntert), we need to set them +to something (because they are strict) but they will never be looked at. + +See Note [When does an implication have given equalities?] in TcSimplify +for more details about inert_no_eqs. + +See Note [Given flatten-skolems] for more details about inert_fsks. + +\begin{code} getTcSTyBinds :: TcS (IORef (Bool, TyVarEnv (TcTyVar, TcType))) getTcSTyBinds = TcS (return . tcs_ty_binds) @@ -1350,7 +1392,7 @@ checkWellStagedDFun pred dfun_id loc bind_lvl = TcM.topIdLvl dfun_id pprEq :: TcType -> TcType -> SDoc -pprEq ty1 ty2 = pprType $ mkEqPred ty1 ty2 +pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2 isTouchableMetaTyVarTcS :: TcTyVar -> TcS Bool isTouchableMetaTyVarTcS tv @@ -1516,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 @@ -1602,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 @@ -1671,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] @@ -1790,7 +1834,7 @@ rewriteEqEvidence :: CtEvidence -- Old evidence :: olhs ~ orhs (not swap -- It's all a form of rewwriteEvidence, specialised for equalities rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co | CtDerived { ctev_loc = loc } <- old_ev - = newDerived loc (mkEqPred nlhs nrhs) + = newDerived loc (mkTcEqPred nlhs nrhs) | NotSwapped <- swapped , isTcReflCo lhs_co -- See Note [Rewriting with Refl] @@ -1817,7 +1861,7 @@ rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co | otherwise = panic "rewriteEvidence" where - new_pred = mkEqPred nlhs nrhs + new_pred = mkTcEqPred nlhs nrhs maybeSym :: SwapFlag -> TcCoercion -> TcCoercion maybeSym IsSwapped co = mkTcSymCo co diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index c4308f6cc5..dde5902ccc 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -1,4 +1,6 @@ \begin{code} +{-# LANGUAGE CPP #-} + module TcSimplify( simplifyInfer, quantifyPred, simplifyAmbiguityCheck, @@ -16,7 +18,7 @@ import TcMType as TcM import TcType import TcSMonad as TcS import TcInteract -import Kind ( defaultKind_maybe ) +import Kind ( isKind, defaultKind_maybe ) import Inst import FunDeps ( growThetaTyVars ) import Type ( classifyPredType, PredTree(..), getClassPredTys_maybe ) @@ -95,10 +97,9 @@ simpl_top wanteds try_class_defaulting :: WantedConstraints -> TcS WantedConstraints try_class_defaulting wc - | isEmptyWC wc || insolubleWC wc - = return wc -- Don't do type-class defaulting if there are insolubles - -- Doing so is not going to solve the insolubles - | otherwise + | isEmptyWC wc + = return wc + | otherwise -- See Note [When to do type-class defaulting] = do { something_happened <- applyDefaultingRules (approximateWC wc) -- See Note [Top-level Defaulting Plan] ; if something_happened @@ -107,6 +108,33 @@ simpl_top wanteds else return wc } \end{code} +Note [When to do type-class defaulting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In GHC 7.6 and 7.8.2, we did type-class defaulting only if insolubleWC +was false, on the grounds that defaulting can't help solve insoluble +constraints. But if we *don't* do defaulting we may report a whole +lot of errors that would be solved by defaulting; these errors are +quite spurious because fixing the single insoluble error means that +defaulting happens again, which makes all the other errors go away. +This is jolly confusing: Trac #9033. + +So it seems better to always do type-class defaulting. + +However, always doing defaulting does mean that we'll do it in +situations like this (Trac #5934): + run :: (forall s. GenST s) -> Int + run = fromInteger 0 +We don't unify the return type of fromInteger with the given function +type, because the latter involves foralls. So we're left with + (Num alpha, alpha ~ (forall s. GenST s) -> Int) +Now we do defaulting, get alpha := Integer, and report that we can't +match Integer with (forall s. GenST s) -> Int. That's not totally +stupid, but perhaps a little strange. + +Another potential alternative would be to suppress *all* non-insoluble +errors if there are *any* insoluble errors, anywhere, but that seems +too drastic. + Note [Must simplify after defaulting] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We may have a deeply buried constraint @@ -815,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 @@ -1008,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 @@ -1053,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 @@ -1096,118 +1216,97 @@ An alternative we considered was to equalities mentions any of the ic_givens of this implication. 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 htink it does, and it's simple and efficient. - +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] +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 - type family F a :: * +Some notes - h :: F Int -> () - h = 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. - data TEx where - TEx :: a -> TEx + (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. - 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'. +* 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 -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. +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. ********************************************************************************* @@ -1249,16 +1348,22 @@ findDefaultableGroups -> Cts -- Unsolved (wanted or derived) -> [[(Ct,Class,TcTyVar)]] findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds - | null default_tys = [] - | otherwise = filter is_defaultable_group (equivClasses cmp_tv unaries) + | null default_tys = [] + | otherwise = defaultable_groups where + defaultable_groups = filter is_defaultable_group groups + groups = equivClasses cmp_tv unaries unaries :: [(Ct, Class, TcTyVar)] -- (C tv) constraints non_unaries :: [Ct] -- and *other* constraints (unaries, non_unaries) = partitionWith find_unary (bagToList wanteds) -- Finds unary type-class constraints + -- But take account of polykinded classes like Typeable, + -- which may look like (Typeable * (a:*)) (Trac #8931) find_unary cc - | Just (cls,[ty]) <- getClassPredTys_maybe (ctPred cc) + | Just (cls,tys) <- getClassPredTys_maybe (ctPred cc) + , Just (kinds, ty) <- snocView tys + , all isKind kinds , Just tv <- tcGetTyVar_maybe ty , isMetaTyVar tv -- We might have runtime-skolems in GHCi, and -- we definitely don't want to try to assign to those! diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 2f4687d7cc..bb6af8cb95 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -7,8 +7,9 @@ TcSplice: Template Haskell splices \begin{code} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP, FlexibleInstances, MagicHash, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + module TcSplice( -- These functions are defined in stage1 and stage2 -- The raise civilised errors in stage1 @@ -70,7 +71,7 @@ import Class import Inst import TyCon import CoAxiom -import PatSyn ( patSynId ) +import PatSyn ( patSynName ) import ConLike import DataCon import TcEvidence( TcEvBinds(..) ) @@ -845,6 +846,12 @@ like that. Here's how it's processed: (qReport True s) by using addErr to add an error message to the bag of errors. The 'fail' in TcM raises an IOEnvFailure exception + * 'qReport' forces the message to ensure any exception hidden in unevaluated + thunk doesn't get into the bag of errors. Otherwise the following splice + will triger panic (Trac #8987): + $(fail undefined) + See also Note [Concealed TH exceptions] + * So, when running a splice, we catch all exceptions; then for - an IOEnvFailure exception, we assume the error is already in the error-bag (above) @@ -875,8 +882,10 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where ; let i = getKey u ; return (TH.mkNameU s i) } - qReport True msg = addErr (text msg) - qReport False msg = addWarn (text msg) + -- 'msg' is forced to ensure exceptions don't escape, + -- see Note [Exceptions in TH] + qReport True msg = seqList msg $ addErr (text msg) + qReport False msg = seqList msg $ addWarn (text msg) qLocation = do { m <- getModule ; l <- getSrcSpanM @@ -886,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) }) } @@ -1175,7 +1184,7 @@ reifyThing (AGlobal (AConLike (RealDataCon dc))) (reifyName (dataConOrigTyCon dc)) fix) } reifyThing (AGlobal (AConLike (PatSynCon ps))) - = noTH (sLit "pattern synonyms") (ppr $ patSynId ps) + = noTH (sLit "pattern synonyms") (ppr $ patSynName ps) reifyThing (ATcId {tct_id = id}) = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even @@ -1463,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 @@ -1496,26 +1505,27 @@ 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_nm - = do { name <- lookupThAnnLookup th_nm - ; eps <- getEps +reifyAnnotations th_name + = do { name <- lookupThAnnLookup th_name + ; topEnv <- getTopEnv + ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing ; tcg <- getGblEnv - ; let epsAnns = findAnns deserializeWithData (eps_ann_env eps) name - ; let envAnns = findAnns deserializeWithData (tcg_ann_env tcg) name - ; return (envAnns ++ epsAnns) } + ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name + ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name + ; return (selectedEpsHptAnns ++ selectedTcgAnns) } ------------------------------ 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 @@ -1525,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 c496aed798..fd19dee7da 100644 --- a/compiler/typecheck/TcSplice.lhs-boot +++ b/compiler/typecheck/TcSplice.lhs-boot @@ -1,9 +1,10 @@ \begin{code} +{-# LANGUAGE CPP #-} + 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 ) @@ -11,6 +12,7 @@ import TcType ( TcRhoType ) import Annotations ( Annotation, CoreAnnTarget ) #ifdef GHCI +import Id ( Id ) import qualified Language.Haskell.TH as TH #endif @@ -26,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 d0f7814abf..6dcbaffef8 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -6,7 +6,7 @@ TcTyClsDecls: Typecheck type and class declarations \begin{code} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP, TupleSections #-} module TcTyClsDecls ( tcTyAndClassDecls, tcAddImplicits, @@ -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 @@ -354,7 +354,6 @@ getInitialKinds decls do { pairss <- mapM (addLocM getInitialKind) decls ; return (concat pairss) } --- See Note [Kind-checking strategies] in TcHsType getInitialKind :: TyClDecl Name -> TcM [(Name, TcTyThing)] -- Allocate a fresh kind variable for each TyCon and Class -- For each tycon, return (tc, AThing k) @@ -375,7 +374,7 @@ getInitialKind :: TyClDecl Name -> TcM [(Name, TcTyThing)] getInitialKind decl@(ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs = ats }) = do { (cl_kind, inner_prs) <- - kcHsTyVarBndrs (kcStrategy decl) ktvs $ + kcHsTyVarBndrs (hsDeclHasCusk decl) ktvs $ do { inner_prs <- getFamDeclInitialKinds ats ; return (constraintKind, inner_prs) } ; let main_pr = (name, AThing cl_kind) @@ -386,7 +385,7 @@ getInitialKind decl@(DataDecl { tcdLName = L _ name , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig , dd_cons = cons } }) = do { (decl_kind, _) <- - kcHsTyVarBndrs (kcStrategy decl) ktvs $ + kcHsTyVarBndrs (hsDeclHasCusk decl) ktvs $ do { res_k <- case m_sig of Just ksig -> tcLHsKind ksig Nothing -> return liftedTypeKind @@ -418,16 +417,14 @@ getFamDeclInitialKind decl@(FamilyDecl { fdLName = L _ name , fdTyVars = ktvs , fdKindSig = ksig }) = do { (fam_kind, _) <- - kcHsTyVarBndrs (kcStrategyFamDecl decl) ktvs $ + kcHsTyVarBndrs (famDeclHasCusk decl) ktvs $ do { res_k <- case ksig of Just k -> tcLHsKind k Nothing - | defaultResToStar -> return liftedTypeKind - | otherwise -> newMetaKindVar + | famDeclHasCusk decl -> return liftedTypeKind + | otherwise -> newMetaKindVar ; return (res_k, ()) } ; return [ (name, AThing fam_kind) ] } - where - defaultResToStar = (kcStrategyFamDecl decl == FullKindSignature) ---------------- kcSynDecls :: [SCC (LTyClDecl Name)] @@ -451,7 +448,7 @@ kcSynDecl decl@(SynDecl { tcdTyVars = hs_tvs, tcdLName = L _ name -- Returns a possibly-unzonked kind = tcAddDeclCtxt decl $ do { (syn_kind, _) <- - kcHsTyVarBndrs (kcStrategy decl) hs_tvs $ + kcHsTyVarBndrs (hsDeclHasCusk decl) hs_tvs $ do { traceTc "kcd1" (ppr name <+> brackets (ppr hs_tvs)) ; (_, rhs_kind) <- tcLHsType rhs ; traceTc "kcd2" (ppr name) @@ -502,10 +499,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 () ------------------- @@ -514,7 +513,10 @@ kcConDecl (ConDecl { con_name = name, con_qvars = ex_tvs , con_cxt = ex_ctxt, con_details = details , con_res = res }) = addErrCtxt (dataConCtxt name) $ - do { _ <- kcHsTyVarBndrs ParametricKinds ex_tvs $ + -- the 'False' says that the existentials don't have a CUSK, as the + -- concept doesn't really apply here. We just need to bring the variables + -- into scope! + do { _ <- kcHsTyVarBndrs False ex_tvs $ do { _ <- tcHsContext ex_ctxt ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys details) ; _ <- tcConRes res @@ -638,13 +640,13 @@ tcTyClDecl1 _parent rec_info ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths ; at_stuff <- tcClassATs class_name (AssocFamilyTyCon clas) ats at_defs ; mindef <- tcClassMinimalDef class_name sigs sig_stuff - ; clas <- buildClass False {- Must include unfoldings for selectors -} + ; clas <- buildClass class_name tvs' roles ctxt' fds' at_stuff sig_stuff mindef tc_isrec ; traceTc "tcClassDecl" (ppr fundeps $$ ppr tvs' $$ ppr fds') ; return (clas, tvs', gen_dm_env) } - ; let { gen_dm_ids = [ AnId (mkExportedLocalId gen_dm_name gen_dm_ty) + ; let { gen_dm_ids = [ AnId (mkExportedLocalId VanillaId gen_dm_name gen_dm_ty) | (sel_id, GenDefMeth gen_dm_name) <- classOpItems clas , let gen_dm_tau = expectJust "tcTyClDecl1" $ lookupNameEnv gen_dm_env (idName sel_id) @@ -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. @@ -780,7 +779,8 @@ tcDataDefn rec_info tc_name tvs kind = do { extra_tvs <- tcDataKindSig kind ; let final_tvs = tvs ++ extra_tvs roles = rti_roles rec_info tc_name - ; stupid_theta <- tcHsContext ctxt + ; stupid_tc_theta <- tcHsContext ctxt + ; stupid_theta <- zonkTcTypeToTypes emptyZonkEnv stupid_tc_theta ; kind_signatures <- xoptM Opt_KindSignatures ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? @@ -792,7 +792,7 @@ tcDataDefn rec_info tc_name tvs kind ; checkKind kind tc_kind ; return () } - ; h98_syntax <- dataDeclChecks tc_name new_or_data stupid_theta cons + ; gadt_syntax <- dataDeclChecks tc_name new_or_data stupid_theta cons ; tycon <- fixM $ \ tycon -> do { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs) @@ -807,7 +807,7 @@ tcDataDefn rec_info tc_name tvs kind ; return (buildAlgTyCon tc_name final_tvs roles cType stupid_theta tc_rhs (rti_is_rec rec_info tc_name) (rti_promotable rec_info) - (not h98_syntax) NoParentTyCon) } + gadt_syntax NoParentTyCon) } ; return [ATyCon tycon] } \end{code} @@ -835,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 (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc) - ; tcTyFamInstEqn (tyConName fam_tc) (tyConKind fam_tc) eqn } - --- Checks to make sure that all the names in an instance group are the same -tcSynFamInstNames :: Located Name -> [Located Name] -> TcM () -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 @@ -946,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 @@ -960,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> @@ -981,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 @@ -993,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 @@ -1010,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 @@ -1039,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' } @@ -1100,11 +1128,11 @@ dataDeclChecks :: Name -> NewOrData -> ThetaType -> [LConDecl Name] -> TcM Bool dataDeclChecks tc_name new_or_data stupid_theta cons = do { -- Check that we don't use GADT syntax in H98 world gadtSyntax_ok <- xoptM Opt_GADTSyntax - ; let h98_syntax = consUseH98Syntax cons - ; checkTc (gadtSyntax_ok || h98_syntax) (badGadtDecl tc_name) + ; let gadt_syntax = consUseGadtSyntax cons + ; checkTc (gadtSyntax_ok || not gadt_syntax) (badGadtDecl tc_name) -- Check that the stupid theta is empty for a GADT-style declaration - ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name) + ; checkTc (null stupid_theta || not gadt_syntax) (badStupidTheta tc_name) -- Check that a newtype has exactly one constructor -- Do this before checking for empty data decls, so that @@ -1118,13 +1146,13 @@ dataDeclChecks tc_name new_or_data stupid_theta cons ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? ; checkTc (not (null cons) || empty_data_decls || is_boot) (emptyConDeclsErr tc_name) - ; return h98_syntax } + ; return gadt_syntax } ----------------------------------- -consUseH98Syntax :: [LConDecl a] -> Bool -consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False -consUseH98Syntax _ = True +consUseGadtSyntax :: [LConDecl a] -> Bool +consUseGadtSyntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = True +consUseGadtSyntax _ = False -- All constructors have same shape ----------------------------------- @@ -1341,10 +1369,24 @@ since GADTs are not kind indexed. Validity checking is done once the mutually-recursive knot has been tied, so we can look at things freely. +Note [Abort when superclass cycle is detected] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must avoid doing the ambiguity check when there are already errors accumulated. +This is because one of the errors may be a superclass cycle, and superclass cycles +cause canonicalization to loop. Here is a representative example: + + class D a => C a where + meth :: D a => () + class C a => D a + +This fixes Trac #9415. + \begin{code} checkClassCycleErrs :: Class -> TcM () checkClassCycleErrs cls - = unless (null cls_cycles) $ mapM_ recClsErr cls_cycles + = unless (null cls_cycles) $ + do { mapM_ recClsErr cls_cycles + ; failM } -- See Note [Abort when superclass cycle is detected] where cls_cycles = calcClassCycles cls checkValidTyCl :: TyThing -> TcM () @@ -1465,8 +1507,8 @@ checkValidClosedCoAxiom (CoAxiom { co_ax_branches = branches, co_ax_tc = tc }) -- ones and hence is inaccessible check_accessibility prev_branches cur_branch = do { when (cur_branch `isDominatedBy` prev_branches) $ - setSrcSpan (coAxBranchSpan cur_branch) $ - addErrTc $ inaccessibleCoAxBranch tc cur_branch + addWarnAt (coAxBranchSpan cur_branch) $ + inaccessibleCoAxBranch tc cur_branch ; return (cur_branch : prev_branches) } checkFieldCompat :: Name -> DataCon -> DataCon -> TyVarSet @@ -1483,16 +1525,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)) @@ -1580,16 +1625,19 @@ checkValidClass cls ; nullary_type_classes <- xoptM Opt_NullaryTypeClasses ; fundep_classes <- xoptM Opt_FunctionalDependencies - -- Check that the class is unary, unless multiparameter or - -- nullary type classes are enabled - ; checkTc (nullary_type_classes || notNull tyvars) (nullaryClassErr cls) - ; checkTc (multi_param_type_classes || arity <= 1) (classArityErr cls) + -- Check that the class is unary, unless multiparameter type classes + -- 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) -- Check the super-classes ; checkValidTheta (ClassSCCtxt (className cls)) theta -- Now check for cyclic superclasses + -- If there are superclass cycles, checkClassCycleErrs bails. ; checkClassCycleErrs cls -- Check the class operations @@ -1620,7 +1668,7 @@ checkValidClass cls -- since there is no possible ambiguity ; let grown_tyvars = growThetaTyVars theta (mkVarSet tyvars) ; checkTc (arity == 0 || tyVarsOfType tau `intersectsVarSet` grown_tyvars) - (noClassTyVarErr cls sel_id) + (noClassTyVarErr cls (ptext (sLit "class method") <+> quotes (ppr sel_id))) ; case dm of GenDefMeth dm_name -> do { dm_id <- tcLookupId dm_name @@ -1642,11 +1690,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) - = tcAddDefaultAssocDeclCtxt (tyConName fam_tc) $ - mapM_ (checkValidTyFamInst mb_clsinfo fam_tc) defs - - mb_clsinfo = Just (cls, mkVarEnv [ (tv, mkTyVarTy tv) | tv <- tyvars ]) + 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))) } checkFamFlag :: Name -> TcM () -- Check that we don't use families without -XTypeFamilies @@ -1671,9 +1718,9 @@ checkValidRoleAnnots :: RoleAnnots -> TyThing -> TcM () checkValidRoleAnnots role_annots thing = case thing of { ATyCon tc - | isSynTyCon tc -> check_no_roles - | isFamilyTyCon tc -> check_no_roles - | isAlgTyCon tc -> check_roles + | isTypeSynonymTyCon tc -> check_no_roles + | isFamilyTyCon tc -> check_no_roles + | isAlgTyCon tc -> check_roles where name = tyConName tc @@ -1797,7 +1844,7 @@ checkValidRoles tc mkDefaultMethodIds :: [TyThing] -> [Id] -- See Note [Default method Ids and Template Haskell] mkDefaultMethodIds things - = [ mkExportedLocalId dm_name (idType sel_id) + = [ mkExportedLocalId VanillaId dm_name (idType sel_id) | ATyCon tc <- things , Just cls <- [tyConClass_maybe tc] , (sel_id, DefMeth dm_name) <- classOpItems cls ] @@ -1834,11 +1881,10 @@ mkRecSelBinds tycons mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name) mkRecSelBind (tycon, sel_name) - = (L loc (IdSig sel_id), unitBag (Generated, L loc sel_bind)) + = (L loc (IdSig sel_id), unitBag (L loc sel_bind)) where loc = getSrcSpan sel_name - sel_id = Var.mkExportedLocalVar rec_details sel_name - sel_ty vanillaIdInfo + sel_id = mkExportedLocalId rec_details sel_name sel_ty rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty } -- Find a representative constructor, con1 @@ -1863,8 +1909,10 @@ mkRecSelBind (tycon, sel_name) -- Make the binding: sel (C2 { fld = x }) = x -- sel (C7 { fld = x }) = x -- where cons_w_field = [C2,C7] - sel_bind | is_naughty = mkTopFunBind sel_lname [mkSimpleMatch [] unit_rhs] - | otherwise = mkTopFunBind sel_lname (map mk_match cons_w_field ++ deflt) + sel_bind = mkTopFunBind Generated sel_lname alts + where + alts | is_naughty = [mkSimpleMatch [] unit_rhs] + | otherwise = map mk_match cons_w_field ++ deflt mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)] (L loc (HsVar field_var)) mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields) @@ -2002,13 +2050,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) @@ -2051,26 +2092,26 @@ classOpCtxt :: Var -> Type -> SDoc classOpCtxt sel_id tau = sep [ptext (sLit "When checking the class method:"), nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)] -nullaryClassErr :: Class -> SDoc -nullaryClassErr cls - = vcat [ptext (sLit "No parameters for class") <+> quotes (ppr cls), - parens (ptext (sLit "Use NullaryTypeClasses to allow no-parameter classes"))] - -classArityErr :: Class -> SDoc -classArityErr cls - = vcat [ptext (sLit "Too many parameters for class") <+> quotes (ppr cls), - parens (ptext (sLit "Use MultiParamTypeClasses to allow multi-parameter classes"))] +classArityErr :: Int -> Class -> SDoc +classArityErr n cls + | n == 0 = mkErr "No" "no-parameter" + | otherwise = mkErr "Too many" "multi-parameter" + where + mkErr howMany allowWhat = + vcat [ptext (sLit $ howMany ++ " parameters for class") <+> quotes (ppr cls), + parens (ptext (sLit $ "Use MultiParamTypeClasses to allow " + ++ allowWhat ++ " classes"))] classFunDepsErr :: Class -> SDoc classFunDepsErr cls = vcat [ptext (sLit "Fundeps in class") <+> quotes (ppr cls), parens (ptext (sLit "Use FunctionalDependencies to allow fundeps"))] -noClassTyVarErr :: Class -> Var -> SDoc -noClassTyVarErr clas op - = sep [ptext (sLit "The class method") <+> quotes (ppr op), - ptext (sLit "mentions none of the type variables of the class") <+> - ppr clas <+> hsep (map ppr (classTyVars clas))] +noClassTyVarErr :: Class -> SDoc -> SDoc +noClassTyVarErr clas what + = sep [ptext (sLit "The") <+> what, + ptext (sLit "mentions none of the type or kind variables of the class") <+> + quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))] recSynErr :: [LTyClDecl Name] -> TcRn () recSynErr syn_decls @@ -2149,20 +2190,20 @@ 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 - = ptext (sLit "Inaccessible family instance equation:") $$ + = ptext (sLit "Overlapped type family instance equation:") $$ (pprCoAxBranch tc fi) badRoleAnnot :: Name -> Role -> Role -> SDoc @@ -2203,12 +2244,12 @@ addTyThingCtxt thing name = getName thing flav = case thing of ATyCon tc - | isClassTyCon tc -> ptext (sLit "class") - | isSynFamilyTyCon tc -> ptext (sLit "type family") - | isDataFamilyTyCon tc -> ptext (sLit "data family") - | isSynTyCon tc -> ptext (sLit "type") - | isNewTyCon tc -> ptext (sLit "newtype") - | isDataTyCon tc -> ptext (sLit "data") + | isClassTyCon tc -> ptext (sLit "class") + | isSynFamilyTyCon tc -> ptext (sLit "type family") + | isDataFamilyTyCon tc -> ptext (sLit "data family") + | isTypeSynonymTyCon tc -> ptext (sLit "type") + | isNewTyCon tc -> ptext (sLit "newtype") + | isDataTyCon tc -> ptext (sLit "data") _ -> pprTrace "addTyThingCtxt strange" (ppr thing) empty diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index a75618b75e..262aa519b3 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -9,7 +9,8 @@ This stuff is only used for source-code decls; it's recorded in interface files for imported data types. \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -120,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 @@ -263,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 @@ -672,10 +673,10 @@ initialRoleEnv is_boot annots = extendNameEnvList emptyNameEnv . initialRoleEnv1 :: Bool -> RoleAnnots -> TyCon -> (Name, [Role]) initialRoleEnv1 is_boot annots_env tc - | isFamilyTyCon tc = (name, map (const Nominal) tyvars) - | isAlgTyCon tc - || isSynTyCon tc = (name, default_roles) - | otherwise = pprPanic "initialRoleEnv1" (ppr tc) + | isFamilyTyCon tc = (name, map (const Nominal) tyvars) + | isAlgTyCon tc = (name, default_roles) + | isTypeSynonymTyCon tc = (name, default_roles) + | otherwise = pprPanic "initialRoleEnv1" (ppr tc) where name = tyConName tc tyvars = tyConTyVars tc (kvs, tvs) = span isKindVar tyvars @@ -709,6 +710,8 @@ irTyCon tc ; unless (all (== Nominal) old_roles) $ -- also catches data families, -- which don't want or need role inference do { whenIsJust (tyConClass_maybe tc) (irClass tc_name) + ; addRoleInferenceInfo tc_name (tyConTyVars tc) $ + mapM_ (irType emptyVarSet) (tyConStupidTheta tc) -- See #8958 ; mapM_ (irDataCon tc_name) (visibleDataCons $ algTyConRhs tc) }} | Just (SynonymTyCon ty) <- synTyConRhs_maybe tc @@ -778,7 +781,7 @@ lookupRoles tc Just roles -> return roles Nothing -> return $ tyConRoles tc } --- tries to update a role; won't even update a role "downwards" +-- tries to update a role; won't ever update a role "downwards" updateRole :: Role -> TyVar -> RoleM () updateRole role tv = do { var_ns <- getVarNs diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 08c7a627ce..f12ec9d6d5 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -15,6 +15,8 @@ The "tc" prefix is for "TypeChecker", because the type checker is the principal client. \begin{code} +{-# LANGUAGE CPP #-} + module TcType ( -------------------------------- -- Types @@ -93,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 @@ -173,6 +173,7 @@ import Maybes import ListSetOps import Outputable import FastString +import ErrUtils( Validity(..), isValid ) import Data.IORef import Control.Monad (liftM, ap) @@ -478,7 +479,7 @@ pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_untch = untch }) pprUserTypeCtxt :: UserTypeCtxt -> SDoc pprUserTypeCtxt (InfSigCtxt n) = ptext (sLit "the inferred type for") <+> quotes (ppr n) pprUserTypeCtxt (FunSigCtxt n) = ptext (sLit "the type signature for") <+> quotes (ppr n) -pprUserTypeCtxt (RuleSigCtxt n) = ptext (sLit "a RULE for") <+> quotes (ppr n) +pprUserTypeCtxt (RuleSigCtxt n) = ptext (sLit "a RULE for") <+> quotes (ppr n) pprUserTypeCtxt ExprSigCtxt = ptext (sLit "an expression type signature") pprUserTypeCtxt (ConArgCtxt c) = ptext (sLit "the type of the constructor") <+> quotes (ppr c) pprUserTypeCtxt (TySynCtxt c) = ptext (sLit "the RHS of the type synonym") <+> quotes (ppr c) @@ -734,7 +735,7 @@ mkTcEqPred :: TcType -> TcType -> Type mkTcEqPred ty1 ty2 = mkTyConApp eqTyCon [k, ty1, ty2] where - k = defaultKind (typeKind ty1) + k = typeKind ty1 \end{code} @isTauTy@ tests for nested for-alls. It should not be called on a boxy type. @@ -961,7 +962,7 @@ tcInstHeadTyNotSynonym :: Type -> Bool -- are transparent, so we need a special function here tcInstHeadTyNotSynonym ty = case ty of - TyConApp tc _ -> not (isSynTyCon tc) + TyConApp tc _ -> not (isTypeSynonymTyCon tc) _ -> True tcInstHeadTyAppAllTyVars :: Type -> Bool @@ -1418,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 @@ -1448,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] @@ -1548,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 @@ -1572,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/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 94b6aebeb5..ef06ddd263 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -6,7 +6,8 @@ Type subsumption and unification \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -824,8 +825,8 @@ uUnfilledVars origin swapped tv1 details1 tv2 details2 -- k1 = k2, so we are free to update either way (EQ, MetaTv { mtv_info = i1, mtv_ref = ref1 }, MetaTv { mtv_info = i2, mtv_ref = ref2 }) - | nicer_to_update_tv1 i1 i2 -> updateMeta tv1 ref1 ty2 - | otherwise -> updateMeta tv2 ref2 ty1 + | nicer_to_update_tv1 tv1 i1 i2 -> updateMeta tv1 ref1 ty2 + | otherwise -> updateMeta tv2 ref2 ty1 (EQ, MetaTv { mtv_ref = ref1 }, _) -> updateMeta tv1 ref1 ty2 (EQ, _, MetaTv { mtv_ref = ref2 }) -> updateMeta tv2 ref2 ty1 @@ -838,9 +839,10 @@ uUnfilledVars origin swapped tv1 details1 tv2 details2 ty1 = mkTyVarTy tv1 ty2 = mkTyVarTy tv2 - nicer_to_update_tv1 _ SigTv = True - nicer_to_update_tv1 SigTv _ = False - nicer_to_update_tv1 _ _ = isSystemName (Var.varName tv1) +nicer_to_update_tv1 :: TcTyVar -> MetaInfo -> MetaInfo -> Bool +nicer_to_update_tv1 _ _ SigTv = True +nicer_to_update_tv1 _ SigTv _ = False +nicer_to_update_tv1 tv1 _ _ = isSystemName (Var.varName tv1) -- Try not to update SigTvs; and try to update sys-y type -- variables in preference to ones gotten (say) by -- instantiating a polymorphic function with a user-written @@ -1069,6 +1071,31 @@ one of argTypeKind or openTypeKind. The situation is different in the core of the compiler, where we are perfectly happy to have types of kind Constraint on either end of an arrow. +Note [Kind variables can be untouchable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must use the careful function lookupTcTyVar to see if a kind +variable is filled or unifiable. It checks for touchablity, and kind +variables can certainly be untouchable --- for example the variable +might be bound outside an enclosing existental pattern match that +binds an inner kind variable, which we don't want ot escape outside. + +This, or something closely related, was teh cause of Trac #8985. + +Note [Unifying kind variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Rather hackily, kind variables can be TyVars not just TcTyVars. +Main reason is in + data instance T (D (x :: k)) = ...con-decls... +Here we bring into scope a kind variable 'k', and use it in the +con-decls. BUT the con-decls will be finished and frozen, and +are not amenable to subsequent substitution, so it makes sense +to have the *final* kind-variable (a KindVar, not a TcKindVar) in +scope. So at least during kind unification we can encounter a +KindVar. + +Hence the isTcTyVar tests before calling lookupTcTyVar. + + \begin{code} matchExpectedFunKind :: TcKind -> TcM (Maybe (TcKind, TcKind)) -- Like unifyFunTy, but does not fail; instead just returns Nothing @@ -1117,37 +1144,66 @@ unifyKindX (TyConApp kc1 []) (TyConApp kc2 []) unifyKindX k1 k2 = unifyKindEq k1 k2 -- In all other cases, let unifyKindEq do the work +------------------- uKVar :: SwapFlag -> (TcKind -> TcKind -> TcM (Maybe Ordering)) -> MetaKindVar -> TcKind -> TcM (Maybe Ordering) uKVar swapped unify_kind kv1 k2 - | isTcTyVar kv1, isMetaTyVar kv1 -- See Note [Unifying kind variables] - = do { mb_k1 <- readMetaTyVar kv1 - ; case mb_k1 of - Flexi -> uUnboundKVar kv1 k2 - Indirect k1 -> unSwap swapped unify_kind k1 k2 } - | TyVarTy kv2 <- k2, kv1 == kv2 + | isTcTyVar kv1 + = do { lookup_res <- lookupTcTyVar kv1 -- See Note [Kind variables can be untouchable] + ; case lookup_res of + Filled k1 -> unSwap swapped unify_kind k1 k2 + Unfilled ds1 -> uUnfilledKVar kv1 ds1 k2 } + + | otherwise -- See Note [Unifying kind variables] + = uUnfilledKVar kv1 vanillaSkolemTv k2 + +------------------- +uUnfilledKVar :: MetaKindVar -> TcTyVarDetails -> TcKind -> TcM (Maybe Ordering) +uUnfilledKVar kv1 ds1 (TyVarTy kv2) + | kv1 == kv2 = return (Just EQ) - | TyVarTy kv2 <- k2, isTcTyVar kv2, isMetaTyVar kv2 - = uKVar (flipSwap swapped) unify_kind kv2 (TyVarTy kv1) + | isTcTyVar kv2 + = do { lookup_res <- lookupTcTyVar kv2 + ; case lookup_res of + Filled k2 -> uUnfilledKVar kv1 ds1 k2 + Unfilled ds2 -> uUnfilledKVars kv1 ds1 kv2 ds2 } - | otherwise - = return Nothing + | otherwise -- See Note [Unifying kind variables] + = uUnfilledKVars kv1 ds1 kv2 vanillaSkolemTv -{- Note [Unifying kind variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Rather hackily, kind variables can be TyVars not just TcTyVars. -Main reason is in - data instance T (D (x :: k)) = ...con-decls... -Here we bring into scope a kind variable 'k', and use it in the -con-decls. BUT the con-decls will be finished and frozen, and -are not amenable to subsequent substitution, so it makes sense -to have the *final* kind-variable (a KindVar, not a TcKindVar) in -scope. So at least during kind unification we can encounter a -KindVar. - -Hence the isTcTyVar tests before using isMetaTyVar. --} +uUnfilledKVar kv1 ds1 non_var_k2 + = case ds1 of + MetaTv { mtv_info = SigTv } + -> return Nothing + MetaTv { mtv_ref = ref1 } + -> do { k2a <- zonkTcKind non_var_k2 + ; let k2b = defaultKind k2a + -- MetaKindVars must be bound only to simple kinds + + ; dflags <- getDynFlags + ; case occurCheckExpand dflags kv1 k2b of + OC_OK k2c -> do { writeMetaTyVarRef kv1 ref1 k2c; return (Just EQ) } + _ -> return Nothing } + _ -> return Nothing + +------------------- +uUnfilledKVars :: MetaKindVar -> TcTyVarDetails + -> MetaKindVar -> TcTyVarDetails + -> TcM (Maybe Ordering) +-- kv1 /= kv2 +uUnfilledKVars kv1 ds1 kv2 ds2 + = case (ds1, ds2) of + (MetaTv { mtv_info = i1, mtv_ref = r1 }, + MetaTv { mtv_info = i2, mtv_ref = r2 }) + | nicer_to_update_tv1 kv1 i1 i2 -> do_update kv1 r1 kv2 + | otherwise -> do_update kv2 r2 kv1 + (MetaTv { mtv_ref = r1 }, _) -> do_update kv1 r1 kv2 + (_, MetaTv { mtv_ref = r2 }) -> do_update kv2 r2 kv1 + _ -> return Nothing + where + do_update kv1 r1 kv2 + = do { writeMetaTyVarRef kv1 r1 (mkTyVarTy kv2); return (Just EQ) } --------------------------- unifyKindEq :: TcKind -> TcKind -> TcM (Maybe Ordering) @@ -1159,41 +1215,16 @@ unifyKindEq k1 (TyVarTy kv2) = uKVar IsSwapped unifyKindEq kv2 k1 unifyKindEq (FunTy a1 r1) (FunTy a2 r2) = do { mb1 <- unifyKindEq a1 a2; mb2 <- unifyKindEq r1 r2 ; return (if isJust mb1 && isJust mb2 then Just EQ else Nothing) } - + unifyKindEq (TyConApp kc1 k1s) (TyConApp kc2 k2s) | kc1 == kc2 = ASSERT(length k1s == length k2s) - -- Should succeed since the kind constructors are the same, + -- Should succeed since the kind constructors are the same, -- and the kinds are sort-checked, thus fully applied do { mb_eqs <- zipWithM unifyKindEq k1s k2s - ; return (if all isJust mb_eqs - then Just EQ + ; return (if all isJust mb_eqs + then Just EQ else Nothing) } unifyKindEq _ _ = return Nothing - ----------------- -uUnboundKVar :: MetaKindVar -> TcKind -> TcM (Maybe Ordering) -uUnboundKVar kv1 k2@(TyVarTy kv2) - | kv1 == kv2 = return (Just EQ) - | isTcTyVar kv2, isMetaTyVar kv2 -- Distinct kind variables - = do { mb_k2 <- readMetaTyVar kv2 - ; case mb_k2 of - Indirect k2 -> uUnboundKVar kv1 k2 - Flexi -> do { writeMetaTyVar kv1 k2; return (Just EQ) } } - | otherwise - = do { writeMetaTyVar kv1 k2; return (Just EQ) } - -uUnboundKVar kv1 non_var_k2 - | isSigTyVar kv1 - = return Nothing - | otherwise - = do { k2a <- zonkTcKind non_var_k2 - ; let k2b = defaultKind k2a - -- MetaKindVars must be bound only to simple kinds - - ; dflags <- getDynFlags - ; case occurCheckExpand dflags kv1 k2b of - OC_OK k2c -> do { writeMetaTyVar kv1 k2c; return (Just EQ) } - _ -> return Nothing } \end{code} diff --git a/compiler/typecheck/TcValidity.lhs b/compiler/typecheck/TcValidity.lhs index 84453eb700..f8357825a7 100644 --- a/compiler/typecheck/TcValidity.lhs +++ b/compiler/typecheck/TcValidity.lhs @@ -4,6 +4,8 @@ % \begin{code} +{-# LANGUAGE CPP #-} + module TcValidity ( Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType, expectedKindInCtxt, @@ -44,7 +46,6 @@ import ListSetOps import SrcLoc import Outputable import FastString -import BasicTypes ( Arity ) import Control.Monad import Data.Maybe @@ -67,13 +68,21 @@ checkAmbiguity ctxt ty -- Then :k T should work in GHCi, not complain that -- (T k) is ambiguous! + | InfSigCtxt {} <- ctxt -- See Note [Validity of inferred types] in TcBinds + = return () + | otherwise = do { traceTc "Ambiguity check for" (ppr ty) - ; (subst, _tvs) <- tcInstSkolTyVars (varSetElems (tyVarsOfType ty)) + ; let free_tkvs = varSetElemsKvsFirst (closeOverKinds (tyVarsOfType ty)) + ; (subst, _tvs) <- tcInstSkolTyVars free_tkvs ; let ty' = substTy subst ty - -- The type might have free TyVars, - -- so we skolemise them as TcTyVars + -- The type might have free TyVars, esp when the ambiguity check + -- happens during a call to checkValidType, + -- so we skolemise them as TcTyVars. -- Tiresome; but the type inference engine expects TcTyVars + -- NB: The free tyvar might be (a::k), so k is also free + -- and we must skolemise it as well. Hence closeOverKinds. + -- (Trac #9222) -- Solve the constraints eagerly because an ambiguous type -- can cause a cascade of further errors. Since the free @@ -285,7 +294,7 @@ check_type ctxt rank (AppTy ty1 ty2) ; check_arg_type ctxt rank ty2 } check_type ctxt rank ty@(TyConApp tc tys) - | isSynTyCon tc = check_syn_tc_app ctxt rank ty tc tys + | isTypeSynonymTyCon tc = check_syn_tc_app ctxt rank ty tc tys | isUnboxedTupleTyCon tc = check_ubx_tuple ctxt ty tys | otherwise = mapM_ (check_arg_type ctxt rank) tys @@ -506,7 +515,7 @@ okIPCtxt (SpecInstCtxt {}) = False okIPCtxt _ = True badIPPred :: PredType -> SDoc -badIPPred pred = ptext (sLit "Illegal implict parameter") <+> quotes (ppr pred) +badIPPred pred = ptext (sLit "Illegal implicit parameter") <+> quotes (ppr pred) check_eq_pred :: DynFlags -> UserTypeCtxt -> PredType -> TcType -> TcType -> TcM () @@ -650,7 +659,7 @@ unambiguous. See Note [Impedence matching] in TcBinds. This test is very conveniently implemented by calling tcSubType <type> <type> This neatly takes account of the functional dependecy stuff above, -and implict parameter (see Note [Implicit parameters and ambiguity]). +and implicit parameter (see Note [Implicit parameters and ambiguity]). What about this, though? g :: C [a] => Int @@ -765,11 +774,10 @@ checkValidInstHead ctxt clas cls_args ; checkTc (xopt Opt_FlexibleInstances dflags || all tcInstHeadTyAppAllTyVars ty_args) (instTypeErr clas cls_args head_type_args_tyvars_msg) - ; checkTc (xopt Opt_NullaryTypeClasses dflags || - not (null ty_args)) - (instTypeErr clas cls_args head_no_type_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 @@ -799,11 +807,7 @@ checkValidInstHead ctxt clas cls_args head_one_type_msg = parens ( text "Only one type can be given in an instance head." $$ - text "Use MultiParamTypeClasses if you want to allow more.") - - head_no_type_msg = parens ( - text "No parameters in the instance head." $$ - text "Use NullaryTypeClasses if you want to allow this.") + text "Use MultiParamTypeClasses if you want to allow more, or zero.") abstract_class_msg = text "The class is abstract, manual instances are not permitted." @@ -875,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) } @@ -1110,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 @@ -1160,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 2d145683bf..9863b8d98f 100644 --- a/compiler/types/Class.lhs +++ b/compiler/types/Class.lhs @@ -6,7 +6,8 @@ The @Class@ datatype \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# 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 @@ -16,7 +17,7 @@ The @Class@ datatype module Class ( Class, ClassOpItem, DefMeth (..), - ClassATItem, + ClassATItem(..), ClassMinimalDef, defMethSpecOfDefMeth, @@ -31,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 @@ -99,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 @@ -114,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} @@ -197,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/CoAxiom.lhs b/compiler/types/CoAxiom.lhs index d6122b21e6..06b74a43f0 100644 --- a/compiler/types/CoAxiom.lhs +++ b/compiler/types/CoAxiom.lhs @@ -4,7 +4,7 @@ \begin{code} -{-# LANGUAGE GADTs, ScopedTypeVariables #-} +{-# LANGUAGE CPP, DeriveDataTypeable, GADTs, ScopedTypeVariables #-} -- | Module for coercion axioms, used to represent type family instances -- and newtypes diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index af2b2fa483..38f38ed50b 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -3,6 +3,8 @@ % \begin{code} +{-# LANGUAGE CPP, DeriveDataTypeable #-} + -- | Module for (a) type kinds and (b) type coercions, -- as used in System FC. See 'CoreSyn.Expr' for -- more on System FC and how coercions fit into it. @@ -16,7 +18,7 @@ module Coercion ( -- ** Functions over coercions coVarKind, coVarRole, coercionType, coercionKind, coercionKinds, isReflCo, - isReflCo_maybe, coercionRole, + isReflCo_maybe, coercionRole, coercionKindRole, mkCoercionType, -- ** Constructing coercions @@ -27,7 +29,7 @@ module Coercion ( mkSymCo, mkTransCo, mkNthCo, mkNthCoRole, mkLRCo, mkInstCo, mkAppCo, mkAppCoFlexible, mkTyConAppCo, mkFunCo, mkForAllCo, mkUnsafeCo, mkUnivCo, mkSubCo, mkPhantomCo, - mkNewTypeCo, maybeSubCo, maybeSubCo2, + mkNewTypeCo, downgradeRole, mkAxiomRuleCo, -- ** Decomposition @@ -38,7 +40,7 @@ module Coercion ( splitAppCo_maybe, splitForAllCo_maybe, nthRole, tyConRolesX, - nextRole, + nextRole, setNominalRole_maybe, -- ** Coercion variables mkCoVar, isCoVar, isCoVarType, coVarName, setCoVarName, setCoVarUnique, @@ -102,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} %************************************************************************ @@ -632,7 +636,7 @@ pprCo, pprParendCo :: Coercion -> SDoc pprCo co = ppr_co TopPrec co pprParendCo co = ppr_co TyConPrec co -ppr_co :: Prec -> Coercion -> SDoc +ppr_co :: TyPrec -> Coercion -> SDoc ppr_co _ (Refl r ty) = angleBrackets (ppr ty) <> ppr_role r ppr_co p co@(TyConAppCo _ tc [_,_]) @@ -695,7 +699,7 @@ instance Outputable LeftOrRight where ppr CLeft = ptext (sLit "Left") ppr CRight = ptext (sLit "Right") -ppr_fun_co :: Prec -> Coercion -> SDoc +ppr_fun_co :: TyPrec -> Coercion -> SDoc ppr_fun_co p co = pprArrowChain p (split co) where split :: Coercion -> [SDoc] @@ -704,7 +708,7 @@ ppr_fun_co p co = pprArrowChain p (split co) = ppr_co FunPrec arg : split res split co = [ppr_co TopPrec co] -ppr_forall_co :: Prec -> Coercion -> SDoc +ppr_forall_co :: TyPrec -> Coercion -> SDoc ppr_forall_co p ty = maybeParen p FunPrec $ sep [pprForAll tvs, ppr_co TopPrec rho] @@ -724,7 +728,7 @@ pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc pprCoAxBranch fam_tc (CoAxBranch { cab_tvs = tvs , cab_lhs = lhs , cab_rhs = rhs }) - = hang (ifPprDebug (pprForAll tvs)) + = hang (pprUserForAll tvs) 2 (hang (pprTypeApp fam_tc lhs) 2 (equals <+> (ppr rhs))) pprCoAxBranchHdr :: CoAxiom br -> BranchIndex -> SDoc @@ -770,7 +774,7 @@ splitAppCo_maybe (AppCo co1 co2) = Just (co1, co2) splitAppCo_maybe (TyConAppCo r tc cos) | isDecomposableTyCon tc || cos `lengthExceeds` tyConArity tc , Just (cos', co') <- snocView cos - , Just co'' <- unSubCo_maybe co' + , Just co'' <- setNominalRole_maybe co' = Just (mkTyConAppCo r tc cos', co'') -- Never create unsaturated type family apps! -- Use mkTyConAppCo to preserve the invariant -- that identity coercions are always represented by Refl @@ -829,6 +833,55 @@ isReflCo_maybe _ = Nothing %* * %************************************************************************ +Note [Role twiddling functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are a plethora of functions for twiddling roles: + +mkSubCo: Requires a nominal input coercion and always produces a +representational output. This is used when you (the programmer) are sure you +know exactly that role you have and what you want. + +setRole_maybe: This function takes both the input role and the output role +as parameters. (The *output* role comes first!) It can only *downgrade* a +role -- that is, change it from N to R or P, or from R to P. This one-way +behavior is why there is the "_maybe". If an upgrade is requested, this +function produces Nothing. This is used when you need to change the role of a +coercion, but you're not sure (as you're writing the code) of which roles are +involved. + +This function could have been written using coercionRole to ascertain the role +of the input. But, that function is recursive, and the caller of setRole_maybe +often knows the input role. So, this is more efficient. + +downgradeRole: This is just like setRole_maybe, but it panics if the conversion +isn't a downgrade. + +setNominalRole_maybe: This is the only function that can *upgrade* a coercion. The result +(if it exists) is always Nominal. The input can be at any role. It works on a +"best effort" basis, as it should never be strictly necessary to upgrade a coercion +during compilation. It is currently only used within GHC in splitAppCo_maybe. In order +to be a proper inverse of mkAppCo, the second coercion that splitAppCo_maybe returns +must be nominal. But, it's conceivable that splitAppCo_maybe is operating over a +TyConAppCo that uses a representational coercion. Hence the need for setNominalRole_maybe. +splitAppCo_maybe, in turn, is used only within coercion optimization -- thus, it is +not absolutely critical that setNominalRole_maybe be complete. + +Note that setNominalRole_maybe will never upgrade a phantom UnivCo. Phantom +UnivCos are perfectly type-safe, whereas representational and nominal ones are +not. Indeed, `unsafeCoerce` is implemented via a representational UnivCo. +(Nominal ones are no worse than representational ones, so this function *will* +change a UnivCo Representational to a UnivCo Nominal.) + +Conal Elliott also came across a need for this function while working with the GHC +API, as he was decomposing Core casts. The Core casts use representational coercions, +as they must, but his use case required nominal coercions (he was building a GADT). +So, that's why this function is exported from this module. + +One might ask: shouldn't setRole_maybe just use setNominalRole_maybe as appropriate? +I (Richard E.) have decided not to do this, because upgrading a role is bizarre and +a caller should have to ask for this behavior explicitly. + \begin{code} mkCoVarCo :: CoVar -> Coercion -- cv :: s ~# t @@ -845,9 +898,9 @@ mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> Coercion -- mkAxInstCo can legitimately be called over-staturated; -- i.e. with more type arguments than the coercion requires mkAxInstCo role ax index tys - | arity == n_tys = maybeSubCo2 role ax_role $ AxiomInstCo ax_br index rtys + | arity == n_tys = downgradeRole role ax_role $ AxiomInstCo ax_br index rtys | otherwise = ASSERT( arity < n_tys ) - maybeSubCo2 role ax_role $ + downgradeRole role ax_role $ foldl AppCo (AxiomInstCo ax_br index (take arity rtys)) (drop arity rtys) where @@ -899,10 +952,12 @@ mkAppCo co1 co2 = mkAppCoFlexible co1 Nominal co2 mkAppCoFlexible :: Coercion -> Role -> Coercion -> Coercion mkAppCoFlexible (Refl r ty1) _ (Refl _ ty2) = Refl r (mkAppTy ty1 ty2) -mkAppCoFlexible (Refl r (TyConApp tc tys)) r2 co2 +mkAppCoFlexible (Refl r ty1) r2 co2 + | Just (tc, tys) <- splitTyConApp_maybe ty1 + -- Expand type synonyms; a TyConAppCo can't have a type synonym (Trac #9102) = TyConAppCo r tc (zip_roles (tyConRolesX r tc) tys) where - zip_roles (r1:_) [] = [maybeSubCo2 r1 r2 co2] + zip_roles (r1:_) [] = [downgradeRole r1 r2 co2] zip_roles (r1:rs) (ty1:tys) = mkReflCo r1 ty1 : zip_roles rs tys zip_roles _ _ = panic "zip_roles" -- but the roles are infinite... mkAppCoFlexible (TyConAppCo r tc cos) r2 co @@ -911,7 +966,7 @@ mkAppCoFlexible (TyConAppCo r tc cos) r2 co TyConAppCo Nominal tc (cos ++ [co]) Representational -> TyConAppCo Representational tc (cos ++ [co']) where new_role = (tyConRolesX Representational tc) !! (length cos) - co' = maybeSubCo2 new_role r2 co + co' = downgradeRole new_role r2 co Phantom -> TyConAppCo Phantom tc (cos ++ [mkPhantomCo co]) mkAppCoFlexible co1 _r2 co2 = ASSERT( _r2 == Nominal ) @@ -970,7 +1025,7 @@ mkTransCo co1 co2 = TransCo co1 co2 -- sure this request is reasonable mkNthCoRole :: Role -> Int -> Coercion -> Coercion mkNthCoRole role n co - = maybeSubCo2 role nth_role $ nth_co + = downgradeRole role nth_role $ nth_co where nth_co = mkNthCo n co nth_role = coercionRole nth_co @@ -999,10 +1054,9 @@ ok_tc_app ty n = case splitTyConApp_maybe ty of mkInstCo :: Coercion -> Type -> Coercion mkInstCo co ty = InstCo co ty --- | Manufacture a coercion from thin air. Needless to say, this is --- not usually safe, but it is used when we know we are dealing with --- bottom, which is one case in which it is safe. This is also used --- to implement the @unsafeCoerce#@ primitive. Optimise by pushing +-- | Manufacture an unsafe coercion from thin air. +-- Currently (May 14) this is used only to implement the +-- @unsafeCoerce#@ primitive. Optimise by pushing -- down through type constructors. mkUnsafeCo :: Type -> Type -> Coercion mkUnsafeCo = mkUnivCo Representational @@ -1015,7 +1069,7 @@ mkUnivCo role ty1 ty2 mkAxiomRuleCo :: CoAxiomRule -> [Type] -> [Coercion] -> Coercion mkAxiomRuleCo = AxiomRuleCo --- input coercion is Nominal +-- input coercion is Nominal; see also Note [Role twiddling functions] mkSubCo :: Coercion -> Coercion mkSubCo (Refl Nominal ty) = Refl Representational ty mkSubCo (TyConAppCo Nominal tc cos) @@ -1024,44 +1078,51 @@ mkSubCo (UnivCo Nominal ty1 ty2) = UnivCo Representational ty1 ty2 mkSubCo co = ASSERT2( coercionRole co == Nominal, ppr co <+> ppr (coercionRole co) ) SubCo co - --- takes a Nominal coercion and possibly casts it into a Representational one -maybeSubCo :: Role -> Coercion -> Coercion -maybeSubCo Nominal = id -maybeSubCo Representational = mkSubCo -maybeSubCo Phantom = pprPanic "maybeSubCo Phantom" . ppr - -maybeSubCo2_maybe :: Role -- desired role - -> Role -- current role - -> Coercion -> Maybe Coercion -maybeSubCo2_maybe Representational Nominal = Just . mkSubCo -maybeSubCo2_maybe Nominal Representational = const Nothing -maybeSubCo2_maybe Phantom Phantom = Just -maybeSubCo2_maybe Phantom _ = Just . mkPhantomCo -maybeSubCo2_maybe _ Phantom = const Nothing -maybeSubCo2_maybe _ _ = Just - -maybeSubCo2 :: Role -- desired role - -> Role -- current role - -> Coercion -> Coercion -maybeSubCo2 r1 r2 co - = case maybeSubCo2_maybe r1 r2 co of +-- only *downgrades* a role. See Note [Role twiddling functions] +setRole_maybe :: Role -- desired role + -> Role -- current role + -> Coercion -> Maybe Coercion +setRole_maybe Representational Nominal = Just . mkSubCo +setRole_maybe Nominal Representational = const Nothing +setRole_maybe Phantom Phantom = Just +setRole_maybe Phantom _ = Just . mkPhantomCo +setRole_maybe _ Phantom = const Nothing +setRole_maybe _ _ = Just + +-- panics if the requested conversion is not a downgrade. +-- See also Note [Role twiddling functions] +downgradeRole :: Role -- desired role + -> Role -- current role + -> Coercion -> Coercion +downgradeRole r1 r2 co + = case setRole_maybe r1 r2 co of Just co' -> co' - Nothing -> pprPanic "maybeSubCo2" (ppr co) - --- if co is Nominal, returns it; otherwise, unwraps a SubCo; otherwise, fails -unSubCo_maybe :: Coercion -> Maybe Coercion -unSubCo_maybe (SubCo co) = Just co -unSubCo_maybe (Refl _ ty) = Just $ Refl Nominal ty -unSubCo_maybe (TyConAppCo Representational tc cos) - = do { cos' <- mapM unSubCo_maybe cos + Nothing -> pprPanic "downgradeRole" (ppr co) + +-- Converts a coercion to be nominal, if possible. +-- See also Note [Role twiddling functions] +setNominalRole_maybe :: Coercion -> Maybe Coercion +setNominalRole_maybe co + | Nominal <- coercionRole co = Just co +setNominalRole_maybe (SubCo co) = Just co +setNominalRole_maybe (Refl _ ty) = Just $ Refl Nominal ty +setNominalRole_maybe (TyConAppCo Representational tc coes) + = do { cos' <- mapM setNominalRole_maybe coes ; return $ TyConAppCo Nominal tc cos' } -unSubCo_maybe (UnivCo Representational ty1 ty2) = Just $ UnivCo Nominal ty1 ty2 +setNominalRole_maybe (UnivCo Representational ty1 ty2) = Just $ UnivCo Nominal ty1 ty2 -- We do *not* promote UnivCo Phantom, as that's unsafe. -- UnivCo Nominal is no more unsafe than UnivCo Representational -unSubCo_maybe co - | Nominal <- coercionRole co = Just co -unSubCo_maybe _ = Nothing +setNominalRole_maybe (TransCo co1 co2) + = TransCo <$> setNominalRole_maybe co1 <*> setNominalRole_maybe co2 +setNominalRole_maybe (AppCo co1 co2) + = AppCo <$> setNominalRole_maybe co1 <*> pure co2 +setNominalRole_maybe (ForAllCo tv co) + = ForAllCo tv <$> setNominalRole_maybe co +setNominalRole_maybe (NthCo n co) + = NthCo n <$> setNominalRole_maybe co +setNominalRole_maybe (InstCo co ty) + = InstCo <$> setNominalRole_maybe co <*> pure ty +setNominalRole_maybe _ = Nothing -- takes any coercion and turns it into a Phantom coercion mkPhantomCo :: Coercion -> Coercion @@ -1556,7 +1617,7 @@ failing for reason 2) is fine. matchAxiom is trying to find a set of coercions that match, but it may fail, and this is healthy behavior. Bottom line: if you find that liftCoSubst is doing weird things (like leaving out-of-scope variables lying around), disable coercion optimization (bypassing matchAxiom) -and use maybeSubCo2 instead of maybeSubCo2_maybe. The panic will then happen, +and use downgradeRole instead of setRole_maybe. The panic will then happen, and you may learn something useful. \begin{code} @@ -1566,7 +1627,7 @@ liftCoSubstTyVar (LCS _ cenv) r tv = do { co <- lookupVarEnv cenv tv ; let co_role = coercionRole co -- could theoretically take this as -- a parameter, but painful - ; maybeSubCo2_maybe r co_role co } -- see Note [liftCoSubstTyVar] + ; setRole_maybe r co_role co } -- see Note [liftCoSubstTyVar] liftCoSubstTyVarBndr :: LiftCoSubst -> TyVar -> (LiftCoSubst, TyVar) liftCoSubstTyVarBndr subst@(LCS in_scope cenv) old_var @@ -1733,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 @@ -1768,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] @@ -1783,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 50ced7d323..1308984f4f 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -5,13 +5,12 @@ FamInstEnv: Type checked family instance declarations \begin{code} - -{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP, GADTs #-} module FamInstEnv ( FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS, famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon, - pprFamInst, pprFamInstHdr, pprFamInsts, + pprFamInst, pprFamInsts, mkImportedFamInst, FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, @@ -47,7 +46,6 @@ import Coercion import CoAxiom import VarSet import VarEnv -import Module( isInteractiveModule ) import Name import UniqFM import Outputable @@ -167,12 +165,13 @@ instance Outputable FamInst where ppr = pprFamInst -- Prints the FamInst as a family instance declaration +-- NB: FamInstEnv.pprFamInst is used only for internal, debug printing +-- See pprTyThing.pprFamInst for printing for the user pprFamInst :: FamInst -> SDoc pprFamInst famInst = hang (pprFamInstHdr famInst) 2 (vcat [ ifPprDebug (ptext (sLit "Coercion axiom:") <+> ppr ax) - , ifPprDebug (ptext (sLit "RHS:") <+> ppr (famInstRHS famInst)) - , ptext (sLit "--") <+> pprDefinedAt (getName famInst)]) + , ifPprDebug (ptext (sLit "RHS:") <+> ppr (famInstRHS famInst)) ]) where ax = fi_axiom famInst @@ -199,6 +198,9 @@ pprFamInstHdr fi@(FamInst {fi_flavor = flavor}) else pprTypeApp fam_tc (etad_lhs_tys ++ mkTyVarTys extra_tvs) -- Without -dppr-debug, eta-expand -- See Trac #8674 + -- (This is probably over the top now that we use this + -- only for internal debug printing; PprTyThing.pprFamInst + -- is used for user-level printing.) | otherwise = vanilla_pp_head @@ -378,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} %************************************************************************ @@ -641,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] @@ -669,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 @@ -729,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} @@ -747,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 826537db17..708fef1cfe 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -7,13 +7,16 @@ The bits common to TcInstDcls and TcDeriv. \begin{code} +{-# 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 @@ -157,22 +160,21 @@ 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 -- Prints the ClsInst as an instance declaration pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun }) = getPprStyle $ \ sty -> - let theta_to_print - | debugStyle sty = theta - | otherwise = drop (dfunNSilent dfun) theta + let dfun_ty = idType dfun + (tvs, theta, res_ty) = tcSplitSigmaTy dfun_ty + theta_to_print = drop (dfunNSilent dfun) theta -- See Note [Silent superclass arguments] in TcInstDcls - in ptext (sLit "instance") <+> ppr flag - <+> sep [pprThetaArrowTy theta_to_print, ppr res_ty] - where - (_, theta, res_ty) = tcSplitSigmaTy (idType dfun) - -- Print without the for-all, which the programmer doesn't write + ty_to_print | debugStyle sty = dfun_ty + | otherwise = mkSigmaTy tvs theta_to_print res_ty + in ptext (sLit "instance") <+> ppr flag <+> pprSigmaType ty_to_print pprInstances :: [ClsInst] -> SDoc pprInstances ispecs = vcat (map pprInstance ispecs) @@ -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 793aa4a761..04982825ac 100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@ -3,19 +3,13 @@ % \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - +{-# LANGUAGE CPP #-} module Kind ( -- * Main data type SuperKind, Kind, typeKind, - -- Kinds - anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind, + -- Kinds + anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind, mkArrowKind, mkArrowKinds, -- Kind constructors... @@ -23,9 +17,9 @@ module Kind ( unliftedTypeKindTyCon, constraintKindTyCon, -- Super Kinds - superKind, superKindTyCon, - - pprKind, pprParendKind, + superKind, superKindTyCon, + + pprKind, pprParendKind, -- ** Deconstructing Kinds kindAppResult, synTyConResKind, @@ -41,7 +35,7 @@ module Kind ( okArrowArgKind, okArrowResultKind, isSubOpenTypeKind, isSubOpenTypeKindKey, - isSubKind, isSubKindCon, + isSubKind, isSubKindCon, tcIsSubKind, tcIsSubKindCon, defaultKind, defaultKind_maybe, @@ -62,48 +56,54 @@ import PrelNames import Outputable import Maybes( orElse ) import Util +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} -- | Essentially 'funResultTy' on kinds handling pi-types too -kindFunResult :: Kind -> KindOrType -> Kind -kindFunResult (FunTy _ res) _ = res -kindFunResult (ForAllTy kv res) arg = substKiWith [kv] [arg] res -kindFunResult k _ = pprPanic "kindFunResult" (ppr k) - -kindAppResult :: Kind -> [Type] -> Kind -kindAppResult k [] = k -kindAppResult k (a:as) = kindAppResult (kindFunResult k a) as +kindFunResult :: SDoc -> Kind -> KindOrType -> Kind +kindFunResult _ (FunTy _ res) _ = res +kindFunResult _ (ForAllTy kv res) arg = substKiWith [kv] [arg] res +#ifdef DEBUG +kindFunResult doc k _ = pprPanic "kindFunResult" (ppr k $$ doc) +#else +-- Without DEBUG, doc becomes an unsed arg, and will be optimised away +kindFunResult _ _ _ = panic "kindFunResult" +#endif + +kindAppResult :: SDoc -> Kind -> [Type] -> Kind +kindAppResult _ k [] = k +kindAppResult doc k (a:as) = kindAppResult doc (kindFunResult doc k a) as -- | Essentially 'splitFunTys' on kinds splitKindFunTys :: Kind -> ([Kind],Kind) @@ -122,12 +122,13 @@ 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 (tyConKind tycon) (map mkTyVarTy (tyConTyVars tycon)) +synTyConResKind tycon = kindAppResult (ptext (sLit "synTyConResKind") <+> ppr tycon) + (tyConKind tycon) (map mkTyVarTy (tyConTyVars tycon)) -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's isOpenTypeKind, isUnliftedTypeKind, @@ -204,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 @@ -235,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 *] @@ -279,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 bb2b9f888b..6eccf42588 100644 --- a/compiler/types/OptCoercion.lhs +++ b/compiler/types/OptCoercion.lhs @@ -3,7 +3,8 @@ % \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -26,7 +27,6 @@ import VarEnv import StaticFlags ( opt_NoOptCoercion ) import Outputable import Pair -import Maybes import FastString import Util import Unify @@ -58,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: @@ -75,20 +91,24 @@ 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) $ co1 `seq` pprTrace "opt_co done }" (ppr co1) $ - (WARN( not same_co_kind, ppr co <+> dcolon <+> pprEqPred (Pair s1 t1) - $$ ppr co1 <+> dcolon <+> pprEqPred (Pair s2 t2) ) + (WARN( not same_co_kind, ppr co <+> dcolon <+> ppr (coercionType co) + $$ ppr co1 <+> dcolon <+> ppr (coercionType co1) ) WARN( not (coreEqCoercion co1 simple_result), (text "env=" <+> ppr env) $$ (text "input=" <+> ppr co) $$ @@ -107,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 @@ -220,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 @@ -262,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) @@ -426,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 @@ -493,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 = maybeSubCo2 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 @@ -569,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 bb489b33e1..65b5645d74 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -6,6 +6,7 @@ The @TyCon@ datatype \begin{code} +{-# LANGUAGE CPP, DeriveDataTypeable #-} module TyCon( -- * Main TyCon data types @@ -34,14 +35,13 @@ module TyCon( isFunTyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, - isSynTyCon, + isSynTyCon, isTypeSynonymTyCon, isDecomposableTyCon, isForeignTyCon, isPromotedDataCon, isPromotedTyCon, isPromotedDataCon_maybe, isPromotedTyCon_maybe, promotableTyCon_maybe, promoteTyCon, - isInjectiveTyCon, isDataTyCon, isProductTyCon, isDataProductTyCon_maybe, isEnumerationTyCon, isNewTyCon, isAbstractTyCon, @@ -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 @@ -1187,11 +1193,17 @@ isDataProductTyCon_maybe (TupleTyCon { dataCon = con }) = Just con isDataProductTyCon_maybe _ = Nothing --- | Is this a 'TyCon' representing a type synonym (@type@)? +-- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)? +isTypeSynonymTyCon :: TyCon -> Bool +isTypeSynonymTyCon (SynTyCon { synTcRhs = SynonymTyCon {} }) = True +isTypeSynonymTyCon _ = False + +-- | Is this 'TyCon' a type synonym or type family? isSynTyCon :: TyCon -> Bool isSynTyCon (SynTyCon {}) = True isSynTyCon _ = False + -- As for newtypes, it is in some contexts important to distinguish between -- closed synonyms and synonym families, as synonym families have no unique -- right hand side to which a synonym family application can expand. @@ -1199,7 +1211,14 @@ isSynTyCon _ = False isDecomposableTyCon :: TyCon -> Bool -- True iff we can decompose (T a b c) into ((T a b) c) +-- I.e. is it injective? -- Specifically NOT true of synonyms (open and otherwise) +-- Ultimately we may have injective associated types +-- in which case this test will become more interesting +-- +-- 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 isDecomposableTyCon _other = True @@ -1259,17 +1278,6 @@ isDataFamilyTyCon :: TyCon -> Bool isDataFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = True isDataFamilyTyCon _ = False --- | Injective 'TyCon's can be decomposed, so that --- T ty1 ~ T ty2 => ty1 ~ ty2 -isInjectiveTyCon :: TyCon -> Bool -isInjectiveTyCon tc = not (isSynTyCon tc) - -- 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 - -- type synonym, because you should probably have expanded it first - -- But regardless, it's not injective! - -- | Are we able to extract informationa 'TyVar' to class argument list -- mappping from a given 'TyCon'? isTyConAssoc :: TyCon -> Bool @@ -1370,13 +1378,15 @@ isPromotedDataCon_maybe _ = Nothing -- * Family instances are /not/ implicit as they represent the instance body -- (similar to a @dfun@ does that for a class instance). isImplicitTyCon :: TyCon -> Bool -isImplicitTyCon tycon - | isTyConAssoc tycon = True - | isSynTyCon tycon = False - | isAlgTyCon tycon = isTupleTyCon tycon - | otherwise = True - -- 'otherwise' catches: FunTyCon, PrimTyCon, - -- PromotedDataCon, PomotedTypeTyCon +isImplicitTyCon (FunTyCon {}) = True +isImplicitTyCon (TupleTyCon {}) = True +isImplicitTyCon (PrimTyCon {}) = True +isImplicitTyCon (PromotedDataCon {}) = True +isImplicitTyCon (PromotedTyCon {}) = True +isImplicitTyCon (AlgTyCon { algTcParent = AssocFamilyTyCon {} }) = True +isImplicitTyCon (AlgTyCon {}) = False +isImplicitTyCon (SynTyCon { synTcParent = AssocFamilyTyCon {} }) = True +isImplicitTyCon (SynTyCon {}) = False tyConCType_maybe :: TyCon -> Maybe CType tyConCType_maybe tc@(AlgTyCon {}) = tyConCType tc diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 88054ce38b..ad9e8b517c 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -6,6 +6,7 @@ Type - public interface \begin{code} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Main functions for manipulating types and type-related things @@ -35,7 +36,7 @@ module Type ( mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, mkPiKinds, mkPiType, mkPiTypes, - applyTy, applyTys, applyTysD, isForAllTy, dropForAlls, + applyTy, applyTys, applyTysD, dropForAlls, mkNumLitTy, isNumLitTy, mkStrLitTy, isStrLitTy, @@ -50,7 +51,7 @@ module Type ( isDictLikeTy, mkEqPred, mkCoerciblePred, mkPrimEqPred, mkReprPrimEqPred, mkClassPred, - noParenPred, isClassPred, isEqPred, + isClassPred, isEqPred, isIPPred, isIPPred_maybe, isIPTyCon, isIPClass, -- Deconstructing predicate types @@ -62,7 +63,7 @@ module Type ( funTyCon, -- ** Predicates on types - isTypeVar, isKindVar, + isTypeVar, isKindVar, allDistinctTyVars, isForAllTy, isTyVarTy, isFunTy, isDictTy, isPredTy, isVoidTy, -- (Lifting and boxity) @@ -128,9 +129,10 @@ module Type ( -- * Pretty-printing pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, - pprTvBndr, pprTvBndrs, pprForAll, pprSigmaType, - pprEqPred, pprTheta, pprThetaArrowTy, pprClassPred, + pprTvBndr, pprTvBndrs, pprForAll, pprUserForAll, pprSigmaType, + pprTheta, pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, pprSourceTyCon, + TyPrec(..), maybeParen, -- * Tidying type related things up for printing tidyType, tidyTypes, @@ -321,6 +323,15 @@ getTyVar_maybe ty | Just ty' <- coreView ty = getTyVar_maybe ty' getTyVar_maybe (TyVarTy tv) = Just tv getTyVar_maybe _ = Nothing +allDistinctTyVars :: [KindOrType] -> Bool +allDistinctTyVars tkvs = go emptyVarSet tkvs + where + go _ [] = True + go so_far (ty : tys) + = case getTyVar_maybe ty of + Nothing -> False + Just tv | tv `elemVarSet` so_far -> False + | otherwise -> go (so_far `extendVarSet` tv) tys \end{code} @@ -813,7 +824,7 @@ applyTysD doc orig_fun_ty arg_tys = substTyWith (take n_args tvs) arg_tys (mkForAllTys (drop n_args tvs) rho_ty) | otherwise -- Too many type args - = ASSERT2( n_tvs > 0, doc $$ ppr orig_fun_ty ) -- Zero case gives infnite loop! + = ASSERT2( n_tvs > 0, doc $$ ppr orig_fun_ty ) -- Zero case gives infinite loop! applyTysD doc (substTyWith tvs (take n_tvs arg_tys) rho_ty) (drop n_tvs arg_tys) where @@ -832,13 +843,6 @@ applyTysD doc orig_fun_ty arg_tys Predicates on PredType \begin{code} -noParenPred :: PredType -> Bool --- A predicate that can appear without parens before a "=>" --- C a => a -> a --- a~b => a -> b --- But (?x::Int) => Int -> Int -noParenPred p = not (isIPPred p) && isClassPred p || isEqPred p - isPredTy :: Type -> Bool -- NB: isPredTy is used when printing types, which can happen in debug printing -- during type checking of not-fully-zonked types. So it's not cool to say @@ -1635,26 +1639,31 @@ type SimpleKind = Kind \begin{code} typeKind :: Type -> Kind -typeKind (TyConApp tc tys) - | isPromotedTyCon tc - = ASSERT( tyConArity tc == length tys ) superKind - | otherwise - = kindAppResult (tyConKind tc) tys - -typeKind (AppTy fun arg) = kindAppResult (typeKind fun) [arg] -typeKind (LitTy l) = typeLiteralKind l -typeKind (ForAllTy _ ty) = typeKind ty -typeKind (TyVarTy tyvar) = tyVarKind tyvar -typeKind _ty@(FunTy _arg res) - -- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*), - -- not unliftedTypKind (#) - -- The only things that can be after a function arrow are - -- (a) types (of kind openTypeKind or its sub-kinds) - -- (b) kinds (of super-kind TY) (e.g. * -> (* -> *)) - | isSuperKind k = k - | otherwise = ASSERT2( isSubOpenTypeKind k, ppr _ty $$ ppr k ) liftedTypeKind - where - k = typeKind res +typeKind orig_ty = go orig_ty + where + + go ty@(TyConApp tc tys) + | isPromotedTyCon tc + = ASSERT( tyConArity tc == length tys ) superKind + | otherwise + = kindAppResult (ptext (sLit "typeKind 1") <+> ppr ty $$ ppr orig_ty) + (tyConKind tc) tys + + go ty@(AppTy fun arg) = kindAppResult (ptext (sLit "typeKind 2") <+> ppr ty $$ ppr orig_ty) + (go fun) [arg] + go (LitTy l) = typeLiteralKind l + go (ForAllTy _ ty) = go ty + go (TyVarTy tyvar) = tyVarKind tyvar + go _ty@(FunTy _arg res) + -- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*), + -- not unliftedTypeKind (#) + -- The only things that can be after a function arrow are + -- (a) types (of kind openTypeKind or its sub-kinds) + -- (b) kinds (of super-kind TY) (e.g. * -> (* -> *)) + | isSuperKind k = k + | otherwise = ASSERT2( isSubOpenTypeKind k, ppr _ty $$ ppr k ) liftedTypeKind + where + k = go res typeLiteralKind :: TyLit -> Kind typeLiteralKind l = diff --git a/compiler/types/Type.lhs-boot b/compiler/types/Type.lhs-boot index c2d2dec093..ff9db3e28c 100644 --- a/compiler/types/Type.lhs-boot +++ b/compiler/types/Type.lhs-boot @@ -3,7 +3,6 @@ module Type where import {-# SOURCE #-} TypeRep( Type, Kind ) import Var -noParenPred :: Type -> Bool isPredTy :: Type -> Bool typeKind :: Type -> Kind diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index bea67b4e3b..c8b20e8d93 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -15,16 +15,16 @@ Note [The Type-related module hierarchy] Coercion imports Type \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# 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 - --- We expose the relevant stuff from this module via the Type module {-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +-- We expose the relevant stuff from this module via the Type module + module TypeRep ( TyThing(..), Type(..), @@ -39,9 +39,10 @@ module TypeRep ( -- Pretty-printing pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs, pprTyThing, pprTyThingCategory, pprSigmaType, - pprEqPred, pprTheta, pprForAll, pprThetaArrowTy, pprClassPred, + pprTheta, pprForAll, pprUserForAll, + pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, pprTyLit, suppressKinds, - Prec(..), maybeParen, pprTcApp, + TyPrec(..), maybeParen, pprTcApp, pprPrefixApp, pprArrowChain, ppr_type, -- Free variables @@ -65,7 +66,7 @@ module TypeRep ( import {-# SOURCE #-} DataCon( dataConTyCon ) import ConLike ( ConLike(..) ) -import {-# SOURCE #-} Type( noParenPred, isPredTy ) -- Transitively pulls in a LOT of stuff, better to break the loop +import {-# SOURCE #-} Type( isPredTy ) -- Transitively pulls in a LOT of stuff, better to break the loop -- friends: import Var @@ -81,7 +82,6 @@ import CoAxiom import PrelNames import Outputable import FastString -import Pair import Util import DynFlags @@ -491,13 +491,31 @@ defined to use this. @pprParendType@ is the same, except it puts parens around the type, except for the atomic cases. @pprParendType@ works just by setting the initial context precedence very high. +Note [Precedence in types] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't keep the fixity of type operators in the operator. So the pretty printer +operates the following precedene structre: + Type constructor application binds more tightly than + Oerator applications which bind more tightly than + Function arrow + +So we might see a :+: T b -> c +meaning (a :+: (T b)) -> c + +Maybe operator applications should bind a bit less tightly? + +Anyway, that's the current story, and it is used consistently for Type and HsType + \begin{code} -data Prec = TopPrec -- No parens - | FunPrec -- Function args; no parens for tycon apps - | TyConPrec -- Tycon args; no parens for atomic - deriving( Eq, Ord ) +data TyPrec -- See Note [Prededence in types] + + = TopPrec -- No parens + | FunPrec -- Function args; no parens for tycon apps + | TyOpPrec -- Infix operator + | TyConPrec -- Tycon args; no parens for atomic + deriving( Eq, Ord ) -maybeParen :: Prec -> Prec -> SDoc -> SDoc +maybeParen :: TyPrec -> TyPrec -> SDoc -> SDoc maybeParen ctxt_prec inner_prec pretty | ctxt_prec < inner_prec = pretty | otherwise = parens pretty @@ -514,18 +532,6 @@ pprKind, pprParendKind :: Kind -> SDoc pprKind = pprType pprParendKind = pprParendType ------------------- -pprEqPred :: Pair Type -> SDoc --- NB: Maybe move to Coercion? It's only called after coercionKind anyway. -pprEqPred (Pair ty1 ty2) - = sep [ ppr_type FunPrec ty1 - , nest 2 (ptext (sLit "~#")) - , ppr_type FunPrec ty2] - -- Precedence looks like (->) so that we get - -- Maybe a ~ Bool - -- (a->a) ~ Bool - -- Note parens on the latter! - ------------ pprClassPred :: Class -> [Type] -> SDoc pprClassPred clas tys = pprTypeApp (classTyCon clas) tys @@ -536,10 +542,9 @@ pprTheta :: ThetaType -> SDoc pprTheta theta = parens (sep (punctuate comma (map (ppr_type TopPrec) theta))) pprThetaArrowTy :: ThetaType -> SDoc -pprThetaArrowTy [] = empty -pprThetaArrowTy [pred] - | noParenPred pred = ppr_type TopPrec pred <+> darrow -pprThetaArrowTy preds = parens (fsep (punctuate comma (map (ppr_type TopPrec) preds))) +pprThetaArrowTy [] = empty +pprThetaArrowTy [pred] = ppr_type FunPrec pred <+> darrow +pprThetaArrowTy preds = parens (fsep (punctuate comma (map (ppr_type TopPrec) preds))) <+> darrow -- Notice 'fsep' here rather that 'sep', so that -- type contexts don't get displayed in a giant column @@ -573,15 +578,9 @@ instance Outputable TyLit where ------------------ -- OK, here's the main printer -ppr_type :: Prec -> Type -> SDoc +ppr_type :: TyPrec -> Type -> SDoc ppr_type _ (TyVarTy tv) = ppr_tvar tv - -ppr_type _ (TyConApp tc [LitTy (StrTyLit n),ty]) - | tc `hasKey` ipClassNameKey - = char '?' <> ftext n <> ptext (sLit "::") <> ppr_type TopPrec ty - ppr_type p (TyConApp tc tys) = pprTyTcApp p tc tys - ppr_type p (LitTy l) = ppr_tylit p l ppr_type p ty@(ForAllTy {}) = ppr_forall_type p ty @@ -600,15 +599,17 @@ ppr_type p fun_ty@(FunTy ty1 ty2) ppr_fun_tail other_ty = [ppr_type TopPrec other_ty] -ppr_forall_type :: Prec -> Type -> SDoc +ppr_forall_type :: TyPrec -> Type -> SDoc ppr_forall_type p ty = maybeParen p FunPrec $ ppr_sigma_type True ty + -- True <=> we always print the foralls on *nested* quantifiers + -- Opt_PrintExplicitForalls only affects top-level quantifiers ppr_tvar :: TyVar -> SDoc ppr_tvar tv -- Note [Infix type variables] = parenSymOcc (getOccName tv) (ppr tv) -ppr_tylit :: Prec -> TyLit -> SDoc +ppr_tylit :: TyPrec -> TyLit -> SDoc ppr_tylit _ tl = case tl of NumTyLit n -> integer n @@ -616,34 +617,38 @@ ppr_tylit _ tl = ------------------- ppr_sigma_type :: Bool -> Type -> SDoc --- Bool <=> Show the foralls -ppr_sigma_type show_foralls ty - = sdocWithDynFlags $ \ dflags -> - let filtered_tvs | gopt Opt_PrintExplicitKinds dflags - = tvs - | otherwise - = filterOut isKindVar tvs - in sep [ ppWhen show_foralls (pprForAll filtered_tvs) - , pprThetaArrowTy ctxt - , pprType tau ] +-- Bool <=> Show the foralls unconditionally +ppr_sigma_type show_foralls_unconditionally ty + = sep [ if show_foralls_unconditionally + then pprForAll tvs + else pprUserForAll tvs + , pprThetaArrowTy ctxt + , pprType tau ] where (tvs, rho) = split1 [] ty (ctxt, tau) = split2 [] rho split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty - split1 tvs ty = (reverse tvs, ty) - + split1 tvs ty = (reverse tvs, ty) + split2 ps (ty1 `FunTy` ty2) | isPredTy ty1 = split2 (ty1:ps) ty2 split2 ps ty = (reverse ps, ty) - pprSigmaType :: Type -> SDoc -pprSigmaType ty = sdocWithDynFlags $ \dflags -> - ppr_sigma_type (gopt Opt_PrintExplicitForalls dflags) ty +pprSigmaType ty = ppr_sigma_type False ty + +pprUserForAll :: [TyVar] -> SDoc +-- Print a user-level forall; see Note [WHen to print foralls] +pprUserForAll tvs + = sdocWithDynFlags $ \dflags -> + ppWhen (any tv_has_kind_var tvs || gopt Opt_PrintExplicitForalls dflags) $ + pprForAll tvs + where + tv_has_kind_var tv = not (isEmptyVarSet (tyVarsOfType (tyVarKind tv))) pprForAll :: [TyVar] -> SDoc pprForAll [] = empty -pprForAll tvs = ptext (sLit "forall") <+> pprTvBndrs tvs <> dot +pprForAll tvs = forAllLit <+> pprTvBndrs tvs <> dot pprTvBndrs :: [TyVar] -> SDoc pprTvBndrs tvs = sep (map pprTvBndr tvs) @@ -656,6 +661,24 @@ pprTvBndr tv kind = tyVarKind tv \end{code} +Note [When to print foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Mostly we want to print top-level foralls when (and only when) the user specifies +-fprint-explicit-foralls. But when kind polymorphism is at work, that suppresses +too much information; see Trac #9018. + +So I'm trying out this rule: print explicit foralls if + a) User specifies -fprint-explicit-foralls, or + b) Any of the quantified type variables has a kind + that mentions a kind variable + +This catches common situations, such as a type siguature + f :: m a +which means + f :: forall k. forall (m :: k->*) (a :: k). m a +We really want to see both the "forall k" and the kind signatures +on m and a. The latter comes from pprTvBndr. + Note [Infix type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ With TypeOperators you can say @@ -680,10 +703,15 @@ pprTypeApp tc tys = pprTyTcApp TopPrec tc tys -- We have to use ppr on the TyCon (not its name) -- so that we get promotion quotes in the right place -pprTyTcApp :: Prec -> TyCon -> [Type] -> SDoc +pprTyTcApp :: TyPrec -> TyCon -> [Type] -> SDoc -- Used for types only; so that we can make a -- special case for type-level lists pprTyTcApp p tc tys + | tc `hasKey` ipClassNameKey + , [LitTy (StrTyLit n),ty] <- tys + = maybeParen p FunPrec $ + char '?' <> ftext n <> ptext (sLit "::") <> ppr_type TopPrec ty + | tc `hasKey` consDataConKey , [_kind,ty1,ty2] <- tys = sdocWithDynFlags $ \dflags -> @@ -693,7 +721,7 @@ pprTyTcApp p tc tys | otherwise = pprTcApp p ppr_type tc tys -pprTcApp :: Prec -> (Prec -> a -> SDoc) -> TyCon -> [a] -> SDoc +pprTcApp :: TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> [a] -> SDoc -- Used for both types and coercions, hence polymorphism pprTcApp _ pp tc [ty] | tc `hasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp TopPrec ty) @@ -717,7 +745,7 @@ pprTcApp p pp tc tys | otherwise = sdocWithDynFlags (pprTcApp_help p pp tc tys) -pprTcApp_help :: Prec -> (Prec -> a -> SDoc) -> TyCon -> [a] -> DynFlags -> SDoc +pprTcApp_help :: TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> [a] -> DynFlags -> SDoc -- This one has accss to the DynFlags pprTcApp_help p pp tc tys dflags | not (isSymOcc (nameOccName (tyConName tc))) @@ -740,6 +768,7 @@ pprTcApp_help p pp tc tys dflags suppressKinds :: DynFlags -> Kind -> [a] -> [a] -- Given the kind of a TyCon, and the args to which it is applied, -- suppress the args that are kind args +-- C.f. Note [Suppressing kinds] in IfaceType suppressKinds dflags kind xs | gopt Opt_PrintExplicitKinds dflags = xs | otherwise = suppress kind xs @@ -749,7 +778,7 @@ suppressKinds dflags kind xs suppress _ xs = xs ---------------- -pprTyList :: Prec -> Type -> Type -> SDoc +pprTyList :: TyPrec -> Type -> Type -> SDoc -- Given a type-level list (t1 ': t2), see if we can print -- it in list notation [t1, ...]. pprTyList p ty1 ty2 @@ -773,19 +802,19 @@ pprTyList p ty1 ty2 gather ty = ([], Just ty) ---------------- -pprInfixApp :: Prec -> (Prec -> a -> SDoc) -> SDoc -> a -> a -> SDoc +pprInfixApp :: TyPrec -> (TyPrec -> a -> SDoc) -> SDoc -> a -> a -> SDoc pprInfixApp p pp pp_tc ty1 ty2 - = maybeParen p FunPrec $ - sep [pp FunPrec ty1, pprInfixVar True pp_tc <+> pp FunPrec ty2] + = maybeParen p TyOpPrec $ + sep [pp TyOpPrec ty1, pprInfixVar True pp_tc <+> pp TyOpPrec ty2] -pprPrefixApp :: Prec -> SDoc -> [SDoc] -> SDoc +pprPrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc pprPrefixApp p pp_fun pp_tys | null pp_tys = pp_fun | otherwise = maybeParen p TyConPrec $ hang pp_fun 2 (sep pp_tys) ---------------- -pprArrowChain :: Prec -> [SDoc] -> SDoc +pprArrowChain :: TyPrec -> [SDoc] -> SDoc -- pprArrowChain p [a,b,c] generates a -> b -> c pprArrowChain _ [] = empty pprArrowChain p (arg:args) = maybeParen p FunPrec $ diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs index d56a3f65fc..1eb1c2b872 100644 --- a/compiler/types/Unify.lhs +++ b/compiler/types/Unify.lhs @@ -3,7 +3,8 @@ % \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 @@ -23,7 +24,6 @@ module Unify ( -- Side-effect free unification tcUnifyTy, tcUnifyTys, BindFlag(..), - niFixTvSubst, niSubstTvSet, UnifyResultM(..), UnifyResult, tcUnifyTysFG @@ -205,6 +205,8 @@ match _ subst (LitTy x) (LitTy y) | x == y = return subst match _ _ _ _ = Nothing + + -------------- match_kind :: MatchEnv -> TvSubstEnv -> Kind -> Kind -> Maybe TvSubstEnv -- Match the kind of the template tyvar with the kind of Type @@ -416,6 +418,26 @@ substituted, we can't properly unify the types. But, that skolem variable may later be instantiated with a unifyable type. So, we return maybeApart in these cases. +Note [Lists of different lengths are MaybeApart] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is unusual to call tcUnifyTys or tcUnifyTysFG with lists of different +lengths. The place where we know this can happen is from compatibleBranches in +FamInstEnv, when checking data family instances. Data family instances may be +eta-reduced; see Note [Eta reduction for data family axioms] in TcInstDcls. + +We wish to say that + + D :: * -> * -> * + axDF1 :: D Int ~ DFInst1 + axDF2 :: D Int Bool ~ DFInst2 + +overlap. If we conclude that lists of different lengths are SurelyApart, then +it will look like these do *not* overlap, causing disaster. See Trac #9371. + +In usages of tcUnifyTys outside of family instances, we always use tcUnifyTys, +which can't tell the difference between MaybeApart and SurelyApart, so those +usages won't notice this design choice. + \begin{code} tcUnifyTy :: Type -> Type -- All tyvars are bindable -> Maybe TvSubst -- A regular one-shot (idempotent) substitution @@ -470,19 +492,52 @@ During unification we use a TvSubstEnv that is (a) non-idempotent (b) loop-free; ie repeatedly applying it yields a fixed point +Note [Finding the substitution fixpoint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Finding the fixpoint of a non-idempotent substitution arising from a +unification is harder than it looks, because of kinds. Consider + T k (H k (f:k)) ~ T * (g:*) +If we unify, we get the substitution + [ k -> * + , g -> H k (f:k) ] +To make it idempotent we don't want to get just + [ k -> * + , g -> H * (f:k) ] +We also want to substitute inside f's kind, to get + [ k -> * + , g -> H k (f:*) ] +If we don't do this, we may apply the substitition to something, +and get an ill-formed type, i.e. one where typeKind will fail. +This happened, for example, in Trac #9106. + +This is the reason for extending env with [f:k -> f:*], in the +definition of env' in niFixTvSubst + \begin{code} niFixTvSubst :: TvSubstEnv -> TvSubst -- Find the idempotent fixed point of the non-idempotent substitution +-- See Note [Finding the substitution fixpoint] -- ToDo: use laziness instead of iteration? niFixTvSubst env = f env where - f e | not_fixpoint = f (mapVarEnv (substTy subst) e) - | otherwise = subst + f env | not_fixpoint = f (mapVarEnv (substTy subst') env) + | otherwise = subst where - range_tvs = foldVarEnv (unionVarSet . tyVarsOfType) emptyVarSet e - subst = mkTvSubst (mkInScopeSet range_tvs) e - not_fixpoint = foldVarSet ((||) . in_domain) False range_tvs - in_domain tv = tv `elemVarEnv` e + not_fixpoint = foldVarSet ((||) . in_domain) False all_range_tvs + in_domain tv = tv `elemVarEnv` env + + range_tvs = foldVarEnv (unionVarSet . tyVarsOfType) emptyVarSet env + all_range_tvs = closeOverKinds range_tvs + subst = mkTvSubst (mkInScopeSet all_range_tvs) env + + -- env' extends env by replacing any free type with + -- that same tyvar with a substituted kind + -- See note [Finding the substitution fixpoint] + env' = extendVarEnvList env [ (rtv, mkTyVarTy $ setTyVarKind rtv $ + substTy subst $ tyVarKind rtv) + | rtv <- varSetElems range_tvs + , not (in_domain rtv) ] + subst' = mkTvSubst (mkInScopeSet all_range_tvs) env' niSubstTvSet :: TvSubstEnv -> TyVarSet -> TyVarSet -- Apply the non-idempotent substitution to a set of type variables, @@ -558,7 +613,7 @@ unifyList subst orig_xs orig_ys go subst [] [] = return subst go subst (x:xs) (y:ys) = do { subst' <- unify subst x y ; go subst' xs ys } - go _ _ _ = surelyApart + go subst _ _ = maybeApart subst -- See Note [Lists of different lengths are MaybeApart] --------------------------------- uVar :: TvSubstEnv -- An existing substitution to extend @@ -620,6 +675,7 @@ uUnrefined subst tv1 ty2 ty2' -- ty2 is not a type variable -- See Note [Fine-grained unification] | otherwise = do { subst' <- unify subst k1 k2 + -- Note [Kinds Containing Only Literals] ; bindTv subst' tv1 ty2 } -- Bind tyvar to the synonym if poss where k1 = tyVarKind tv1 diff --git a/compiler/utils/Bag.lhs b/compiler/utils/Bag.lhs index 2d823e46bb..65c5b39df1 100644 --- a/compiler/utils/Bag.lhs +++ b/compiler/utils/Bag.lhs @@ -6,6 +6,8 @@ Bag: an unordered collection with duplicates \begin{code} +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} + module Bag ( Bag, -- abstract type diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 332bfc8e0c..0aa8c648b8 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -cpp #-} +{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} {-# OPTIONS_GHC -O -funbox-strict-fields #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected @@ -707,14 +707,13 @@ getBS bh = do l <- get bh fp <- mallocForeignPtrBytes l withForeignPtr fp $ \ptr -> do - let - go n | n == l = return $ BS.fromForeignPtr fp 0 l + let go n | n == l = return $ BS.fromForeignPtr fp 0 l | otherwise = do b <- getByte bh pokeElemOff ptr n b go (n+1) - -- - go 0 + -- + go 0 instance Binary ByteString where put_ bh f = putBS bh f @@ -834,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/BufWrite.hs b/compiler/utils/BufWrite.hs index f85ea8e792..7eba0753fe 100644 --- a/compiler/utils/BufWrite.hs +++ b/compiler/utils/BufWrite.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Fast write-buffered Handles @@ -10,7 +12,7 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs index cc684303b6..35782bac6e 100644 --- a/compiler/utils/Digraph.lhs +++ b/compiler/utils/Digraph.lhs @@ -3,28 +3,21 @@ % \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP, ScopedTypeVariables #-} module Digraph( Graph, graphFromVerticesAndAdjacency, graphFromEdgedVertices, SCC(..), Node, flattenSCC, flattenSCCs, - stronglyConnCompG, stronglyConnCompFromG, + stronglyConnCompG, topologicalSortG, dfsTopSortG, verticesG, edgesG, hasVertexG, - reachableG, transposeG, + reachableG, reachablesG, transposeG, outdegreeG, indegreeG, vertexGroupsG, emptyG, 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} @@ -258,14 +251,6 @@ stronglyConnCompG :: Graph node -> [SCC node] stronglyConnCompG graph = decodeSccs graph forest where forest = {-# SCC "Digraph.scc" #-} scc (gr_int_graph graph) --- Find the set of strongly connected components starting from the --- given roots. This is a good way to discard unreachable nodes at --- the same time as computing SCCs. -stronglyConnCompFromG :: Graph node -> [node] -> [SCC node] -stronglyConnCompFromG graph roots = decodeSccs graph forest - where forest = {-# SCC "Digraph.scc" #-} sccFrom (gr_int_graph graph) vs - vs = [ v | Just v <- map (gr_node_to_vertex graph) roots ] - decodeSccs :: Graph node -> Forest Vertex -> [SCC node] decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest = map decode forest @@ -315,7 +300,13 @@ dfsTopSortG graph = reachableG :: Graph node -> node -> [node] reachableG graph from = map (gr_vertex_to_node graph) result where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from) - result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) from_vertex + result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) [from_vertex] + +reachablesG :: Graph node -> [node] -> [node] +reachablesG graph froms = map (gr_vertex_to_node graph) result + where result = {-# SCC "Digraph.reachable" #-} + reachable (gr_int_graph graph) vs + vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ] hasVertexG :: Graph node -> node -> Bool hasVertexG graph node = isJust $ gr_node_to_vertex graph node @@ -548,9 +539,6 @@ postorderF ts = foldr (.) id $ map postorder ts postOrd :: IntGraph -> [Vertex] postOrd g = postorderF (dff g) [] -postOrdFrom :: IntGraph -> [Vertex] -> [Vertex] -postOrdFrom g vs = postorderF (dfs g vs) [] - topSort :: IntGraph -> [Vertex] topSort = reverse . postOrd \end{code} @@ -574,9 +562,6 @@ undirected g = buildG (bounds g) (edges g ++ reverseE g) \begin{code} scc :: IntGraph -> Forest Vertex scc g = dfs g (reverse (postOrd (transpose g))) - -sccFrom :: IntGraph -> [Vertex] -> Forest Vertex -sccFrom g vs = reverse (dfs (transpose g) (reverse (postOrdFrom g vs))) \end{code} ------------------------------------------------------------ @@ -602,11 +587,11 @@ forward g tree pre = mapT select g ------------------------------------------------------------ \begin{code} -reachable :: IntGraph -> Vertex -> [Vertex] -reachable g v = preorderF (dfs g [v]) +reachable :: IntGraph -> [Vertex] -> [Vertex] +reachable g vs = preorderF (dfs g vs) path :: IntGraph -> Vertex -> Vertex -> Bool -path g v w = w `elem` (reachable g v) +path g v w = w `elem` (reachable g [v]) \end{code} ------------------------------------------------------------ @@ -664,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/Encoding.hs b/compiler/utils/Encoding.hs index c4a669c134..115703fc69 100644 --- a/compiler/utils/Encoding.hs +++ b/compiler/utils/Encoding.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-} {-# OPTIONS_GHC -O #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected diff --git a/compiler/utils/ExtsCompat46.hs b/compiler/utils/ExtsCompat46.hs index da0e67ab93..a33fef57d8 100644 --- a/compiler/utils/ExtsCompat46.hs +++ b/compiler/utils/ExtsCompat46.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, CPP #-} +{-# LANGUAGE BangPatterns, CPP, MagicHash #-} ----------------------------------------------------------------------------- -- | diff --git a/compiler/utils/FastBool.lhs b/compiler/utils/FastBool.lhs index 32cb7aef3a..9558da7079 100644 --- a/compiler/utils/FastBool.lhs +++ b/compiler/utils/FastBool.lhs @@ -4,6 +4,8 @@ \section{Fast booleans} \begin{code} +{-# LANGUAGE CPP, MagicHash #-} + module FastBool ( --fastBool could be called bBox; isFastTrue, bUnbox; but they're not FastBool, fastBool, isFastTrue, fastOr, fastAnd diff --git a/compiler/utils/FastFunctions.lhs b/compiler/utils/FastFunctions.lhs index b1dacdcd9b..457fcc9c93 100644 --- a/compiler/utils/FastFunctions.lhs +++ b/compiler/utils/FastFunctions.lhs @@ -4,6 +4,7 @@ Z% \section{Fast functions} \begin{code} +{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} module FastFunctions ( unsafeChr, inlinePerformIO, unsafeDupableInterleaveIO, diff --git a/compiler/utils/FastMutInt.lhs b/compiler/utils/FastMutInt.lhs index 7156cdc9fb..0f0ca78e14 100644 --- a/compiler/utils/FastMutInt.lhs +++ b/compiler/utils/FastMutInt.lhs @@ -1,6 +1,5 @@ \begin{code} -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS -cpp #-} +{-# LANGUAGE CPP, BangPatterns, MagicHash, UnboxedTuples #-} {-# OPTIONS_GHC -O #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected diff --git a/compiler/utils/FastString.lhs b/compiler/utils/FastString.lhs index 5a78c0b59b..157e5f08b0 100644 --- a/compiler/utils/FastString.lhs +++ b/compiler/utils/FastString.lhs @@ -2,7 +2,7 @@ % (c) The University of Glasgow, 1997-2006 % \begin{code} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, CPP, DeriveDataTypeable, MagicHash, UnboxedTuples #-} {-# OPTIONS_GHC -O -funbox-strict-fields #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected @@ -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/FastTypes.lhs b/compiler/utils/FastTypes.lhs index 0ef10ade56..36d8e4c4fd 100644 --- a/compiler/utils/FastTypes.lhs +++ b/compiler/utils/FastTypes.lhs @@ -4,6 +4,7 @@ \section{Fast integers, etc... booleans moved to FastBool for using panic} \begin{code} +{-# LANGUAGE CPP, MagicHash #-} --Even if the optimizer could handle boxed arithmetic equally well, --this helps automatically check the sources to make sure that diff --git a/compiler/utils/Fingerprint.hsc b/compiler/utils/Fingerprint.hsc index 9a55e385b3..464337b7a9 100644 --- a/compiler/utils/Fingerprint.hsc +++ b/compiler/utils/Fingerprint.hsc @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- ---------------------------------------------------------------------------- -- -- (c) The University of Glasgow 2006 diff --git a/compiler/utils/GraphBase.hs b/compiler/utils/GraphBase.hs index 8cb3acee71..2aa16ae99e 100644 --- a/compiler/utils/GraphBase.hs +++ b/compiler/utils/GraphBase.hs @@ -1,7 +1,7 @@ -- | Types for the general graph colorer. -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 diff --git a/compiler/utils/GraphPpr.hs b/compiler/utils/GraphPpr.hs index a896bbbf63..2682c7347e 100644 --- a/compiler/utils/GraphPpr.hs +++ b/compiler/utils/GraphPpr.hs @@ -1,7 +1,7 @@ -- | Pretty printing of graphs. -{-# OPTIONS -fno-warn-tabs #-} +{-# 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 diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs index 6885bbd127..1db15537c7 100644 --- a/compiler/utils/IOEnv.hs +++ b/compiler/utils/IOEnv.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveDataTypeable, UndecidableInstances #-} + -- -- (c) The University of Glasgow 2002-2006 -- @@ -7,7 +9,6 @@ -- as its in the IO monad, mutable references can be used -- for updating state. -- -{-# LANGUAGE UndecidableInstances #-} module IOEnv ( IOEnv, -- Instance of Monad diff --git a/compiler/utils/ListSetOps.lhs b/compiler/utils/ListSetOps.lhs index 5ad402d081..6247dc67f6 100644 --- a/compiler/utils/ListSetOps.lhs +++ b/compiler/utils/ListSetOps.lhs @@ -5,6 +5,7 @@ \section[ListSetOps]{Set-like operations on lists} \begin{code} +{-# LANGUAGE CPP #-} module ListSetOps ( unionLists, minusList, insertList, 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 e8d9347767..a65607a7c3 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -22,11 +22,12 @@ module Outputable ( char, text, ftext, ptext, ztext, int, intWithCommas, integer, float, double, rational, - parens, cparen, brackets, braces, quotes, quote, + parens, cparen, brackets, braces, quotes, quote, doubleQuotes, angleBrackets, paBrackets, - semi, comma, colon, dcolon, space, equals, dot, arrow, darrow, + semi, comma, colon, dcolon, space, equals, dot, + arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, - blankLine, + blankLine, forAllLit, (<>), (<+>), hcat, hsep, ($$), ($+$), vcat, sep, cat, @@ -52,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(..), @@ -73,9 +76,9 @@ module Outputable ( import {-# SOURCE #-} DynFlags( DynFlags, targetPlatform, pprUserLength, pprCols, - useUnicodeQuotes, + 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 ) @@ -141,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 @@ -160,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 @@ -172,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) @@ -184,37 +197,50 @@ 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 -defaultUserStyle = mkUserStyle alwaysQualify AllTheWay +defaultUserStyle = mkUserStyle neverQualify AllTheWay + -- Print without qualifiers to reduce verbosity, unless -dppr-debug defaultDumpStyle | opt_PprStyle_Debug = PprDebug | otherwise = PprDump +defaultErrStyle :: DynFlags -> PprStyle +-- Default style for error messages, when we don't know PrintUnqualified +-- It's a bit of a hack because it doesn't take into account what's in scope +-- Only used for desugarer warnings, and typechecker errors in interface sigs +-- NB that -dppr-debug will still get into PprDebug style +defaultErrStyle dflags = mkErrStyle dflags neverQualify + -- | Style for printing error messages mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle mkErrStyle dflags qual = mkUserStyle qual (PartWay (pprUserLength dflags)) -defaultErrStyle :: DynFlags -> PprStyle --- Default style for error messages --- It's a bit of a hack because it doesn't take into account what's in scope --- Only used for desugarer warnings, and typechecker errors in interface sigs -defaultErrStyle dflags = mkUserStyle alwaysQualify depth - where depth = if opt_PprStyle_Debug - then AllTheWay - else PartWay (pprUserLength dflags) +cmdlineParserStyle :: PprStyle +cmdlineParserStyle = mkUserStyle alwaysQualify AllTheWay mkUserStyle :: PrintUnqualified -> Depth -> PprStyle mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug | otherwise = PprUser unqual depth - -cmdlineParserStyle :: PprStyle -cmdlineParserStyle = PprUser alwaysQualify AllTheWay \end{code} Orthogonal to the above printing styles are (possibly) some @@ -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 @@ -459,7 +494,7 @@ cparen b d = SDoc $ Pretty.cparen b . runSDoc d -- so that we don't get `foo''. Instead we just have foo'. quotes d = sdocWithDynFlags $ \dflags -> - if useUnicodeQuotes dflags + if useUnicode dflags then char '‘' <> d <> char '’' else SDoc $ \sty -> let pp_d = runSDoc d sty @@ -469,13 +504,19 @@ quotes d = ('\'' : _, _) -> pp_d _other -> Pretty.quotes pp_d -semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc -darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc +semi, comma, colon, equals, space, dcolon, underscore, dot :: SDoc +arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc +lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc blankLine = docToSDoc $ Pretty.ptext (sLit "") -dcolon = docToSDoc $ Pretty.ptext (sLit "::") -arrow = docToSDoc $ Pretty.ptext (sLit "->") -darrow = docToSDoc $ Pretty.ptext (sLit "=>") +dcolon = unicodeSyntax (char '∷') (docToSDoc $ Pretty.ptext (sLit "::")) +arrow = unicodeSyntax (char '→') (docToSDoc $ Pretty.ptext (sLit "->")) +larrow = unicodeSyntax (char '←') (docToSDoc $ Pretty.ptext (sLit "<-")) +darrow = unicodeSyntax (char '⇒') (docToSDoc $ Pretty.ptext (sLit "=>")) +arrowt = unicodeSyntax (char '↣') (docToSDoc $ Pretty.ptext (sLit ">-")) +larrowt = unicodeSyntax (char '↢') (docToSDoc $ Pretty.ptext (sLit "-<")) +arrowtt = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.ptext (sLit ">>-")) +larrowtt = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.ptext (sLit "-<<")) semi = docToSDoc $ Pretty.semi comma = docToSDoc $ Pretty.comma colon = docToSDoc $ Pretty.colon @@ -490,6 +531,15 @@ rbrack = docToSDoc $ Pretty.rbrack lbrace = docToSDoc $ Pretty.lbrace rbrace = docToSDoc $ Pretty.rbrace +forAllLit :: SDoc +forAllLit = unicodeSyntax (char '∀') (ptext (sLit "forall")) + +unicodeSyntax :: SDoc -> SDoc -> SDoc +unicodeSyntax unicode plain = sdocWithDynFlags $ \dflags -> + if useUnicode dflags && useUnicodeSyntax dflags + then unicode + else plain + nest :: Int -> SDoc -> SDoc -- ^ Indent 'SDoc' some specified amount (<>) :: SDoc -> SDoc -> SDoc @@ -979,7 +1029,7 @@ assertPprPanic file line msg pprDebugAndThen :: DynFlags -> (String -> a) -> String -> SDoc -> a pprDebugAndThen dflags cont heading pretty_msg - = cont (showSDocDebug dflags doc) + = cont (showSDoc dflags doc) where doc = sep [text heading, nest 4 pretty_msg] \end{code} diff --git a/compiler/utils/Pair.lhs b/compiler/utils/Pair.lhs index 9e847d6950..ca7c2a7f8e 100644 --- a/compiler/utils/Pair.lhs +++ b/compiler/utils/Pair.lhs @@ -3,6 +3,8 @@ A simple homogeneous pair type with useful Functor, Applicative, and Traversable instances. \begin{code} +{-# LANGUAGE CPP #-} + module Pair ( Pair(..), unPair, toPair, swap ) where #include "HsVersions.h" diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs index fc04668ae1..23bf01cafe 100644 --- a/compiler/utils/Panic.lhs +++ b/compiler/utils/Panic.lhs @@ -8,6 +8,8 @@ It's hard to put these functions anywhere else without causing some unnecessary loops in the module dependency graph. \begin{code} +{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} + module Panic ( GhcException(..), showGhcException, throwGhcException, throwGhcExceptionIO, @@ -33,9 +35,6 @@ import Exception import Control.Concurrent import Data.Dynamic -#if __GLASGOW_HASKELL__ < 705 -import Data.Maybe -#endif import Debug.Trace ( trace ) import System.IO.Unsafe import System.Exit @@ -50,10 +49,7 @@ import GHC.ConsoleHandler #endif import GHC.Stack - -#if __GLASGOW_HASKELL__ >= 705 import System.Mem.Weak ( Weak, deRefWeak ) -#endif -- | GHC's own exception type -- error messages all take the form: @@ -284,7 +280,6 @@ installSignalHandlers = do return () #endif -#if __GLASGOW_HASKELL__ >= 705 {-# NOINLINE interruptTargetThread #-} interruptTargetThread :: MVar [Weak ThreadId] interruptTargetThread = unsafePerformIO (newMVar []) @@ -304,19 +299,6 @@ peekInterruptTargetThread = case r of Nothing -> loop ts Just t -> return (Just t) -#else -{-# NOINLINE interruptTargetThread #-} -interruptTargetThread :: MVar [ThreadId] -interruptTargetThread = unsafePerformIO (newMVar []) - -pushInterruptTargetThread :: ThreadId -> IO () -pushInterruptTargetThread tid = do - modifyMVar_ interruptTargetThread $ return . (tid :) - -peekInterruptTargetThread :: IO (Maybe ThreadId) -peekInterruptTargetThread = - withMVar interruptTargetThread $ return . listToMaybe -#endif popInterruptTargetThread :: IO () popInterruptTargetThread = diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs index ea1a3e5e93..ca8f0de862 100644 --- a/compiler/utils/Platform.hs +++ b/compiler/utils/Platform.hs @@ -52,6 +52,7 @@ data Arch , armISAExt :: [ArmISAExt] , armABI :: ArmABI } + | ArchARM64 | ArchAlpha | ArchMipseb | ArchMipsel diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.lhs index fb7fe2b7fb..f6a5a44e2e 100644 --- a/compiler/utils/Pretty.lhs +++ b/compiler/utils/Pretty.lhs @@ -152,7 +152,7 @@ Relative to John's original paper, there are the following new features: \begin{code} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, CPP, MagicHash #-} module Pretty ( Doc, -- Abstract diff --git a/compiler/utils/Serialized.hs b/compiler/utils/Serialized.hs index 902d2feea0..b1576a087f 100644 --- a/compiler/utils/Serialized.hs +++ b/compiler/utils/Serialized.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} + -- -- (c) The University of Glasgow 2002-2006 -- -- Serialized values -{-# LANGUAGE ScopedTypeVariables #-} module Serialized ( -- * Main Serialized data type Serialized, diff --git a/compiler/utils/State.hs b/compiler/utils/State.hs index 0b6a285562..216034fdbf 100644 --- a/compiler/utils/State.hs +++ b/compiler/utils/State.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UnboxedTuples #-} module State (module State, mapAccumLM {- XXX hack -}) where diff --git a/compiler/utils/StringBuffer.lhs b/compiler/utils/StringBuffer.lhs index 46cce5864d..a54f45ffff 100644 --- a/compiler/utils/StringBuffer.lhs +++ b/compiler/utils/StringBuffer.lhs @@ -6,7 +6,7 @@ Buffers for scanning string input stored in external arrays. \begin{code} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-} {-# OPTIONS_GHC -O -funbox-strict-fields #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index 0836e12e28..a51d548336 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.lhs @@ -20,9 +20,9 @@ and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order of arguments of combining function. \begin{code} -{-# LANGUAGE DeriveTraversable, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveTraversable, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS -Wall #-} module UniqFM ( -- * Unique-keyed mappings UniqFM, -- abstract type @@ -61,9 +61,10 @@ module UniqFM ( eltsUFM, keysUFM, splitUFM, ufmToSet_Directly, ufmToList, - joinUFM + joinUFM, pprUniqFM ) where +import FastString import Unique ( Uniquable(..), Unique, getKey ) import Outputable @@ -322,5 +323,11 @@ joinUFM eltJoin l (OldFact old) (NewFact new) = foldUFM_Directly add (NoChange, \begin{code} instance Outputable a => Outputable (UniqFM a) where - ppr ufm = ppr (ufmToList ufm) + ppr ufm = pprUniqFM ppr ufm + +pprUniqFM :: (a -> SDoc) -> UniqFM a -> SDoc +pprUniqFM ppr_elt ufm + = brackets $ fsep $ punctuate comma $ + [ ppr uq <+> ptext (sLit ":->") <+> ppr_elt elt + | (uq, elt) <- ufmToList ufm ] \end{code} diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 5c82c757aa..dfac0ae020 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -3,6 +3,7 @@ % \begin{code} +{-# LANGUAGE CPP #-} -- | Highly random utility functions -- @@ -46,7 +47,7 @@ module Util ( nTimes, -- * Sorting - sortWith, minWith, + sortWith, minWith, nubSort, -- * Comparisons isEqual, eqListBy, eqMaybeBy, @@ -125,12 +126,9 @@ 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 -import Data.Time.Clock.POSIX -import System.Time -#endif infixr 9 `thenCmp` \end{code} @@ -489,6 +487,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} %************************************************************************ @@ -949,13 +950,7 @@ doesDirNameExist fpath = case takeDirectory fpath of -- Backwards compatibility definition of getModificationTime getModificationUTCTime :: FilePath -> IO UTCTime -#if __GLASGOW_HASKELL__ < 705 -getModificationUTCTime f = do - TOD secs _ <- getModificationTime f - return $ posixSecondsToUTCTime (realToFrac secs) -#else getModificationUTCTime = getModificationTime -#endif -- -------------------------------------------------------------- -- check existence & modification time at the same time diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index 012ae37039..38bd55482a 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -351,6 +351,6 @@ tryConvert var vect_var rhs = fromVect (idType var) (Var vect_var) `orElseErrV` do - { emitVt " Could NOT call vectorised from original version" $ ppr var + { emitVt " Could NOT call vectorised from original version" $ ppr var <+> dcolon <+> ppr (idType var) ; return rhs } diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs index fb0c148610..6adb9ec435 100644 --- a/compiler/vectorise/Vectorise/Exp.hs +++ b/compiler/vectorise/Vectorise/Exp.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP, TupleSections #-} -- |Vectorisation of expressions. diff --git a/compiler/vectorise/Vectorise/Generic/PAMethods.hs b/compiler/vectorise/Vectorise/Generic/PAMethods.hs index 269119c6dd..0d5d37c7d7 100644 --- a/compiler/vectorise/Vectorise/Generic/PAMethods.hs +++ b/compiler/vectorise/Vectorise/Generic/PAMethods.hs @@ -16,7 +16,7 @@ import Vectorise.Generic.Description import CoreSyn import CoreUtils import FamInstEnv -import MkCore ( mkWildCase ) +import MkCore ( mkWildCase, mkCoreLet ) import TyCon import CoAxiom import Type @@ -24,6 +24,7 @@ import OccName import Coercion import MkId import FamInst +import TysPrim( intPrimTy ) import DynFlags import FastString @@ -404,9 +405,13 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r -- and PDatas Void arrays in the product. See Note [Empty PDatas]. let xSums = App (repr_selsLength_v ss) (Var sels) - (vars, exprs) <- mapAndUnzipM (to_con xSums) (repr_cons ss) + xSums_var <- newLocalVar (fsLit "xsum") intPrimTy + + (vars, exprs) <- mapAndUnzipM (to_con xSums_var) (repr_cons ss) return ( sels : concat vars , wrapFamInstBody psums_tc (repr_con_tys ss) + $ mkCoreLet (NonRec xSums_var xSums) + -- mkCoreLet ensures that the let/app invariant holds $ mkConApp psums_con $ map Type (repr_con_tys ss) ++ (Var sels : exprs)) @@ -414,7 +419,7 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r = case ss of EmptyProd -> do pvoids <- builtin pvoidsVar - return ([], App (Var pvoids) xSums ) + return ([], App (Var pvoids) (Var xSums) ) UnaryProd r -> do pty <- mkPDatasType (compOrigType r) diff --git a/compiler/vectorise/Vectorise/Monad/InstEnv.hs b/compiler/vectorise/Vectorise/Monad/InstEnv.hs index 84b29ceb61..a97f319b4f 100644 --- a/compiler/vectorise/Vectorise/Monad/InstEnv.hs +++ b/compiler/vectorise/Vectorise/Monad/InstEnv.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Vectorise.Monad.InstEnv ( existsInst , lookupInst diff --git a/compiler/vectorise/Vectorise/Monad/Naming.hs b/compiler/vectorise/Vectorise/Monad/Naming.hs index def1ffa58c..b53324012f 100644 --- a/compiler/vectorise/Vectorise/Monad/Naming.hs +++ b/compiler/vectorise/Vectorise/Monad/Naming.hs @@ -24,6 +24,7 @@ import Name import SrcLoc import MkId import Id +import IdInfo( IdDetails(VanillaId) ) import FastString import Control.Monad @@ -67,7 +68,7 @@ mkVectId :: Id -> Type -> VM Id mkVectId id ty = do { name <- mkLocalisedName mkVectOcc (getName id) ; let id' | isDFunId id = MkId.mkDictFunId name tvs theta cls tys - | isExportedId id = Id.mkExportedLocalId name ty + | isExportedId id = Id.mkExportedLocalId VanillaId name ty | otherwise = Id.mkLocalId name ty ; return id' } @@ -91,8 +92,8 @@ newExportedVar occ_name ty u <- liftDs newUnique let name = mkExternalName u mod occ_name noSrcSpan - - return $ Id.mkExportedLocalId name ty + + return $ Id.mkExportedLocalId VanillaId name ty -- |Make a fresh local variable with the given type. -- The variable's name is formed using the given string as the prefix. diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs index 34008efbbd..6ee5ca6cd9 100644 --- a/compiler/vectorise/Vectorise/Type/Env.hs +++ b/compiler/vectorise/Vectorise/Type/Env.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- Vectorise a modules type and class declarations. -- -- This produces new type constructors and family instances top be included in the module toplevel diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs index a8159b09f4..37a07f710d 100644 --- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs +++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs @@ -59,7 +59,6 @@ vectTyConDecl tycon name' -- NB: 'buildClass' attaches new quantifiers and dictionaries to the method types ; cls' <- liftDs $ buildClass - False -- include unfoldings on dictionary selectors name' -- new name: "V:Class" (tyConTyVars tycon) -- keep original type vars (map (const Nominal) (tyConRoles tycon)) -- all role are N for safety diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs index cb7b34e36a..7d4bae3046 100644 --- a/compiler/vectorise/Vectorise/Utils/Base.hs +++ b/compiler/vectorise/Vectorise/Utils/Base.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Vectorise.Utils.Base ( voidType , newLocalVVar |