diff options
Diffstat (limited to 'compiler')
331 files changed, 6687 insertions, 5885 deletions
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 9a92b003bc..f4a7aaf335 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -41,7 +41,7 @@ module BasicTypes( TopLevelFlag(..), isTopLevel, isNotTopLevel, - OverlapFlag(..), + OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, Boxity(..), isBoxed, @@ -447,9 +447,19 @@ 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 +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 } + + +data OverlapMode -- | This instance must not overlap another - = NoOverlap { isSafeOverlap :: Bool } + = NoOverlap -- | Silently ignore this instance if you find a -- more specific one that matches the constraint @@ -461,7 +471,7 @@ data OverlapFlag -- Since the second instance has the OverlapOk flag, -- the first instance will be chosen (otherwise -- its ambiguous which to choose) - | OverlapOk { isSafeOverlap :: Bool } + | OverlapOk -- | Silently ignore this instance if you find any other that matches the -- constraing you are trying to resolve, including when checking if there are @@ -473,13 +483,16 @@ data OverlapFlag -- Without the Incoherent flag, we'd complain that -- instantiating 'b' would change which instance -- was chosen. See also note [Incoherent instances] - | Incoherent { isSafeOverlap :: Bool } + | Incoherent 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 OverlapOk = ptext (sLit "[overlap ok]") + ppr Incoherent = ptext (sLit "[incoherent]") pprSafeOverlap :: Bool -> SDoc pprSafeOverlap True = ptext $ sLit "[safe]" 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..0dcf98f6c5 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 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..080ae47ac9 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 ( diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index e2742bb3a8..c2e7aeabdc 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: 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 b41d711f69..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 @@ -86,7 +90,7 @@ module OccName ( 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, @@ -100,7 +104,10 @@ 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 @@ -117,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} %* * %************************************************************************ @@ -244,6 +274,9 @@ instance Data OccName where toConstr _ = abstractConstr "OccName" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "OccName" + +instance HasOccName OccName where + occName = id \end{code} @@ -339,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 @@ -416,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 @@ -852,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..ebfb71aa65 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 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..9dccd29135 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -888,6 +888,8 @@ labelDynamic dflags this_pkg this_mod lbl = PlainModuleInitLabel m -> not (gopt Opt_Static dflags) && this_pkg /= (modulePackageId m) + HpcTicksLabel m -> not (gopt Opt_Static dflags) && this_pkg /= (modulePackageId m) + -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves. _ -> False where os = platformOS (targetPlatform dflags) diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index fadce0b5eb..e21efc13af 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 diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 16ace5245f..e10716a2ac 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 #-} 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..aae3ea1c71 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -1,4 +1,5 @@ -{-# 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/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs index bdc947829d..db22deb639 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 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..d8ce492de1 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 @@ -546,8 +550,24 @@ data CallishMachOp | MO_PopCnt Width | MO_BSwap Width + + -- Atomic read-modify-write. + | MO_AtomicRMW Width AtomicMachOp + | MO_AtomicRead Width + | MO_AtomicWrite Width + | MO_Cmpxchg Width deriving (Eq, Show) +-- | The operation to perform atomically. +data AtomicMachOp = + AMO_Add + | AMO_Sub + | AMO_And + | AMO_Nand + | AMO_Or + | AMO_Xor + deriving (Eq, Show) + pprCallishMachOp :: CallishMachOp -> SDoc pprCallishMachOp mo = text (show mo) diff --git a/compiler/cmm/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/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index 1447f6d8cd..4314695201 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 diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs index 187f4c47df..4dced9afd2 100644 --- a/compiler/cmm/CmmSink.hs +++ b/compiler/cmm/CmmSink.hs @@ -9,6 +9,7 @@ import BlockId import CmmLive import CmmUtils import Hoopl +import CodeGen.Platform import DynFlags import UniqFM @@ -16,6 +17,7 @@ import PprCmm () import Data.List (partition) import qualified Data.Set as Set +import Data.Maybe -- ----------------------------------------------------------------------------- -- Sinking and inlining @@ -197,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 @@ -219,26 +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 _) = True -isTrivial (CmmLit _) = True -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 @@ -401,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 @@ -650,6 +650,10 @@ data AbsMem -- perhaps we ought to have a special annotation for calls that can -- modify heap/stack memory. For now we just use the conservative -- definition here. +-- +-- Some CallishMachOp imply a memory barrier e.g. AtomicRMW and +-- therefore we should never float any memory operations across one of +-- these calls. bothMems :: AbsMem -> AbsMem -> AbsMem @@ -695,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..455c79ba02 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,10 @@ pprCallishMachOp_for_C mop MO_Memmove -> ptext (sLit "memmove") (MO_BSwap w) -> ptext (sLit $ bSwapLabel w) (MO_PopCnt w) -> ptext (sLit $ popCntLabel w) + (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop) + (MO_Cmpxchg w) -> ptext (sLit $ cmpxchgLabel w) + (MO_AtomicRead w) -> ptext (sLit $ atomicReadLabel w) + (MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w) (MO_UF_Conv w) -> ptext (sLit $ word2FloatLabel w) MO_S_QuotRem {} -> unsupported diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 46257b4188..b5beb07ae9 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 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..b23bcc11ce 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 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..1a69927b5c 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Stg to C--: code generation for constructors 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/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..d00dc6ec84 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Stg to C--: heap management functions diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index a56248dcb9..99e926c987 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Building info tables. diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 348b7b9299..cad261bcfb 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 diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 5c75acba5a..e4c682bf02 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ---------------------------------------------------------------------------- -- -- Stg to C--: primitive operations @@ -767,6 +769,25 @@ emitPrimOp _ res PrefetchByteArrayOp0 args = doPrefetchByteArrayOp 0 res emitPrimOp _ res PrefetchMutableByteArrayOp0 args = doPrefetchByteArrayOp 0 res args emitPrimOp _ res PrefetchAddrOp0 args = doPrefetchAddrOp 0 res args +-- Atomic read-modify-write +emitPrimOp dflags [res] FetchAddByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Add mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchSubByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Sub mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchAndByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_And mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchNandByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Nand mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchOrByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Or mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchXorByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Xor mba ix (bWord dflags) n +emitPrimOp dflags [res] AtomicReadByteArrayOp_Int [mba, ix] = + doAtomicReadByteArray res mba ix (bWord dflags) +emitPrimOp dflags [] AtomicWriteByteArrayOp_Int [mba, ix, val] = + doAtomicWriteByteArray mba ix (bWord dflags) val +emitPrimOp dflags [res] CasByteArrayOp_Int [mba, ix, old, new] = + doCasByteArray res mba ix (bWord dflags) old new -- The rest just translate straightforwardly emitPrimOp dflags [res] op [arg] @@ -1931,6 +1952,81 @@ doWriteSmallPtrArrayOp addr idx val = do emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) ------------------------------------------------------------------------------ +-- Atomic read-modify-write + +-- | Emit an atomic modification to a byte array element. The result +-- reg contains that previous value of the element. Implies a full +-- memory barrier. +doAtomicRMW :: LocalReg -- ^ Result reg + -> AtomicMachOp -- ^ Atomic op (e.g. add) + -> CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Op argument (e.g. amount to add) + -> FCode () +doAtomicRMW res amop mba idx idx_ty n = do + dflags <- getDynFlags + let width = typeWidth idx_ty + addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) + width mba idx + emitPrimCall + [ res ] + (MO_AtomicRMW width amop) + [ addr, n ] + +-- | Emit an atomic read to a byte array that acts as a memory barrier. +doAtomicReadByteArray + :: LocalReg -- ^ Result reg + -> CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> FCode () +doAtomicReadByteArray res mba idx idx_ty = do + dflags <- getDynFlags + let width = typeWidth idx_ty + addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) + width mba idx + emitPrimCall + [ res ] + (MO_AtomicRead width) + [ addr ] + +-- | Emit an atomic write to a byte array that acts as a memory barrier. +doAtomicWriteByteArray + :: CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Value to write + -> FCode () +doAtomicWriteByteArray mba idx idx_ty val = do + dflags <- getDynFlags + let width = typeWidth idx_ty + addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) + width mba idx + emitPrimCall + [ {- no results -} ] + (MO_AtomicWrite width) + [ addr, val ] + +doCasByteArray + :: LocalReg -- ^ Result reg + -> CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Old value + -> CmmExpr -- ^ New value + -> FCode () +doCasByteArray res mba idx idx_ty old new = do + dflags <- getDynFlags + let width = (typeWidth idx_ty) + addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) + width mba idx + emitPrimCall + [ res ] + (MO_Cmpxchg width) + [ addr, old, new ] + +------------------------------------------------------------------------------ -- Helpers for emitting function calls -- | Emit a call to @memcpy@. diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index f858c5a0b6..1aa08a1e58 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Code generation for profiling diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index b1218201a6..6913c9ec15 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns, CPP #-} + ----------------------------------------------------------------------------- -- -- Code generation for ticky-ticky profiling diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 1c6c3f2eae..bc1a15fe3c 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Code generator utilities; mostly monadic diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs index ca7216fe29..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 diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs index 636c049c42..4011191d75 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 b5c79855f2..a5868108d9 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -7,12 +7,7 @@ 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 @@ -856,6 +851,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) diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index 5e0cd6599d..c754aae4e7 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, @@ -196,6 +196,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 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 defd669a78..b36cb6d8a6 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 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..3bf07febf3 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} @@ -1222,7 +1224,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 +1252,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 +1270,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 +1282,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..5213f92bac 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" 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 6bdc61d9c2..e646667651 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 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 f87877681c..1bbcc05e40 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 diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 1dbf530123..9691b99975 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 diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs index 80f2ec525f..217a4ce7c9 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 diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 859309d592..4eadef69b8 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" @@ -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 diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index e2f4f4ff3c..0654ebc983 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 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 73c1adfdc8..adfc0f688f 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) 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 b42a720c32..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" @@ -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) 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..350ed22d69 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 @@ -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..e6f86c97d9 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,16 +73,34 @@ 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 @@ -96,8 +117,6 @@ Library c-sources: parser/cutils.c - - c-sources: ghci/keepCAFsForGHCi.c cbits/genSym.c @@ -232,11 +251,8 @@ Library CoreTidy CoreUnfold CoreUtils - ExternalCore MkCore - MkExternalCore PprCore - PprExternalCore Check Coverage Desugar @@ -303,12 +319,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..c236bcf7ff 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' >> $@ @@ -667,9 +665,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..d4a58044f5 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -5,7 +5,8 @@ ByteCodeGen: Generate bytecode from Core \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# LANGUAGE CPP, MagicHash #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See diff --git a/compiler/ghci/ByteCodeInstr.lhs b/compiler/ghci/ByteCodeInstr.lhs index 005a430cd9..548c29f514 100644 --- a/compiler/ghci/ByteCodeInstr.lhs +++ b/compiler/ghci/ByteCodeInstr.lhs @@ -4,7 +4,8 @@ ByteCodeInstrs: Bytecode instruction definitions \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# LANGUAGE CPP, MagicHash #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See 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..d508a1c5aa 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, 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..67767e41b9 100644 --- a/compiler/ghci/DebuggerUtils.hs +++ b/compiler/ghci/DebuggerUtils.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module DebuggerUtils ( dataConInfoPtrToName, ) where diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 274f2fbd44..0dbab24de7 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, @@ -1208,7 +1209,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 +1228,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..a2f9af92f1 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 @@ -6,7 +8,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/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index bcea29bea2..e22af3b947 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] @@ -828,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 @@ -1156,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/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index bae804eb07..845c05296c 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -29,7 +29,7 @@ module HsDecls ( InstDecl(..), LInstDecl, NewOrData(..), FamilyInfo(..), TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts, DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, - TyFamInstEqn(..), LTyFamInstEqn, + TyFamEqn(..), TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn, LClsInstDecl, ClsInstDecl(..), -- ** Standalone deriving declarations @@ -472,7 +472,7 @@ data TyClDecl name tcdSigs :: [LSig name], -- ^ Methods' signatures tcdMeths :: LHsBinds name, -- ^ Default methods tcdATs :: [LFamilyDecl name], -- ^ Associated types; ie - tcdATDefs :: [LTyFamInstDecl name], -- ^ Associated type defaults + tcdATDefs :: [LTyFamDefltEqn name], -- ^ Associated type defaults tcdDocs :: [LDocDecl], -- ^ Haddock docs tcdFVs :: NameSet } @@ -573,7 +573,7 @@ tyFamInstDeclName = unLoc . tyFamInstDeclLName tyFamInstDeclLName :: OutputableBndr name => TyFamInstDecl name -> Located name tyFamInstDeclLName (TyFamInstDecl { tfid_eqn = - (L _ (TyFamInstEqn { tfie_tycon = ln })) }) + (L _ (TyFamEqn { tfe_tycon = ln })) }) = ln tyClDeclLName :: TyClDecl name -> Located name @@ -632,7 +632,7 @@ instance OutputableBndr name | otherwise -- Laid out = vcat [ top_matter <+> ptext (sLit "where") , nest 2 $ pprDeclList (map ppr ats ++ - map ppr at_defs ++ + map ppr_fam_deflt_eqn at_defs ++ pprLHsBindsForUser methods sigs) ] where top_matter = ptext (sLit "class") @@ -657,7 +657,7 @@ instance (OutputableBndr name) => Outputable (FamilyDecl name) where ClosedTypeFamily eqns -> ( ptext (sLit "where") , if null eqns then ptext (sLit "..") - else vcat $ map ppr eqns ) + else vcat $ map ppr_fam_inst_eqn eqns ) _ -> (empty, empty) pprFlavour :: FamilyInfo name -> SDoc @@ -678,7 +678,7 @@ pp_vanilla_decl_head thing tyvars context pp_fam_inst_lhs :: OutputableBndr name => Located name - -> HsWithBndrs [LHsType name] + -> HsTyPats name -> HsContext name -> SDoc pp_fam_inst_lhs thing (HsWB { hswb_cts = typats }) context -- explicit type patterns @@ -686,12 +686,13 @@ pp_fam_inst_lhs thing (HsWB { hswb_cts = typats }) context -- explicit type patt , hsep (map (pprParendHsType.unLoc) typats)] pprTyClDeclFlavour :: TyClDecl a -> SDoc -pprTyClDeclFlavour (ClassDecl {}) = ptext (sLit "class") -pprTyClDeclFlavour (FamDecl {}) = ptext (sLit "family") -pprTyClDeclFlavour (SynDecl {}) = ptext (sLit "type") -pprTyClDeclFlavour (DataDecl { tcdDataDefn = (HsDataDefn { dd_ND = nd }) }) - = ppr nd +pprTyClDeclFlavour (ClassDecl {}) = ptext (sLit "class") +pprTyClDeclFlavour (SynDecl {}) = ptext (sLit "type") pprTyClDeclFlavour (ForeignType {}) = ptext (sLit "foreign type") +pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }}) + = pprFlavour info +pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } }) + = ppr nd \end{code} %************************************************************************ @@ -893,25 +894,49 @@ pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT { %* * %************************************************************************ +Note [Type family instance declarations in HsSyn] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The data type TyFamEqn represents one equation of a type family instance. +It is parameterised over its tfe_pats field: + + * An ordinary type family instance declaration looks like this in source Haskell + type instance T [a] Int = a -> a + (or something similar for a closed family) + It is represented by a TyFamInstEqn, with *type* in the tfe_pats field. + + * On the other hand, the *default instance* of an associated type looksl like + this in source Haskell + class C a where + type T a b + type T a b = a -> b -- The default instance + It is represented by a TyFamDefltEqn, with *type variables8 in the tfe_pats field. + \begin{code} ----------------- Type synonym family instances ------------- +type LTyFamInstEqn name = Located (TyFamInstEqn name) +type LTyFamDefltEqn name = Located (TyFamDefltEqn name) -type LTyFamInstEqn name = Located (TyFamInstEqn name) - --- | One equation in a type family instance declaration -data TyFamInstEqn name - = TyFamInstEqn - { tfie_tycon :: Located name - , tfie_pats :: HsWithBndrs [LHsType name] +type HsTyPats name = HsWithBndrs [LHsType name] -- ^ Type patterns (with kind and type bndrs) -- See Note [Family instance declaration binders] - , tfie_rhs :: LHsType name } + +type TyFamInstEqn name = TyFamEqn name (HsTyPats name) +type TyFamDefltEqn name = TyFamEqn name (LHsTyVarBndrs name) + -- See Note [Type family instance declarations in HsSyn] + +-- | One equation in a type family instance declaration +-- See Note [Type family instance declarations in HsSyn] +data TyFamEqn name pats + = TyFamEqn + { tfe_tycon :: Located name + , tfe_pats :: pats + , tfe_rhs :: LHsType name } deriving( Typeable, Data ) type LTyFamInstDecl name = Located (TyFamInstDecl name) -data TyFamInstDecl name +data TyFamInstDecl name = TyFamInstDecl - { tfid_eqn :: LTyFamInstEqn name + { tfid_eqn :: LTyFamInstEqn name , tfid_fvs :: NameSet } deriving( Typeable, Data ) @@ -921,11 +946,9 @@ type LDataFamInstDecl name = Located (DataFamInstDecl name) data DataFamInstDecl name = DataFamInstDecl { dfid_tycon :: Located name - , dfid_pats :: HsWithBndrs [LHsType name] -- lhs - -- ^ Type patterns (with kind and type bndrs) - -- See Note [Family instance declaration binders] - , dfid_defn :: HsDataDefn name -- rhs - , dfid_fvs :: NameSet } -- free vars for dependency analysis + , dfid_pats :: HsTyPats name -- LHS + , dfid_defn :: HsDataDefn name -- RHS + , dfid_fvs :: NameSet } -- Rree vars for dependency analysis deriving( Typeable, Data ) @@ -937,10 +960,11 @@ data ClsInstDecl name { cid_poly_ty :: LHsType name -- Context => Class Instance-type -- Using a polytype means that the renamer conveniently -- figures out the quantified type variables for us. - , cid_binds :: LHsBinds name - , cid_sigs :: [LSig name] -- User-supplied pragmatic info - , cid_tyfam_insts :: [LTyFamInstDecl name] -- type family instances - , cid_datafam_insts :: [LDataFamInstDecl name] -- data family instances + , cid_binds :: LHsBinds name -- Class methods + , cid_sigs :: [LSig name] -- User-supplied pragmatic info + , cid_tyfam_insts :: [LTyFamInstDecl name] -- Type family instances + , cid_datafam_insts :: [LDataFamInstDecl name] -- Data family instances + , cid_overlap_mode :: Maybe OverlapMode } deriving (Data, Typeable) @@ -983,17 +1007,23 @@ instance (OutputableBndr name) => Outputable (TyFamInstDecl name) where pprTyFamInstDecl :: OutputableBndr name => TopLevelFlag -> TyFamInstDecl name -> SDoc pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn }) - = ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> (ppr eqn) + = ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn ppr_instance_keyword :: TopLevelFlag -> SDoc ppr_instance_keyword TopLevel = ptext (sLit "instance") ppr_instance_keyword NotTopLevel = empty -instance (OutputableBndr name) => Outputable (TyFamInstEqn name) where - ppr (TyFamInstEqn { tfie_tycon = tycon - , tfie_pats = pats - , tfie_rhs = rhs }) - = (pp_fam_inst_lhs tycon pats []) <+> equals <+> (ppr rhs) +ppr_fam_inst_eqn :: OutputableBndr name => LTyFamInstEqn name -> SDoc +ppr_fam_inst_eqn (L _ (TyFamEqn { tfe_tycon = tycon + , tfe_pats = pats + , tfe_rhs = rhs })) + = pp_fam_inst_lhs tycon pats [] <+> equals <+> ppr rhs + +ppr_fam_deflt_eqn :: OutputableBndr name => LTyFamDefltEqn name -> SDoc +ppr_fam_deflt_eqn (L _ (TyFamEqn { tfe_tycon = tycon + , tfe_pats = tvs + , tfe_rhs = rhs })) + = pp_vanilla_decl_head tycon tvs [] <+> equals <+> ppr rhs instance (OutputableBndr name) => Outputable (DataFamInstDecl name) where ppr = pprDataFamInstDecl TopLevel @@ -1013,6 +1043,7 @@ pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd }) instance (OutputableBndr name) => Outputable (ClsInstDecl name) where ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds , cid_sigs = sigs, cid_tyfam_insts = ats + , cid_overlap_mode = mbOverlap , cid_datafam_insts = adts }) | null sigs, null ats, null adts, isEmptyBag binds -- No "where" part = top_matter @@ -1024,7 +1055,19 @@ 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") <+> ppOveralapPragma mbOverlap + <+> ppr inst_ty + +ppOveralapPragma :: Maybe OverlapMode -> SDoc +ppOveralapPragma mb = + case mb of + Nothing -> empty + Just NoOverlap -> ptext (sLit "{-# NO_OVERLAP #-}") + Just OverlapOk -> ptext (sLit "{-# OVERLAP #-}") + Just Incoherent -> ptext (sLit "{-# INCOHERENT #-}") + + + instance (OutputableBndr name) => Outputable (InstDecl name) where ppr (ClsInstD { cid_inst = decl }) = ppr decl @@ -1052,12 +1095,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"), ppOveralapPragma o, ppr ty] \end{code} %************************************************************************ @@ -1236,7 +1281,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 f5ba1903ee..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)]] @@ -1300,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..08a0eef498 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -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 ) @@ -506,15 +507,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 +567,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 +575,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 +598,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 +613,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 +630,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 +649,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 eff67df3cf..42838ef93f 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -4,7 +4,7 @@ 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 +13,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 @@ -382,7 +383,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 diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 9fd0c33423..9dd95fc0f2 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- -- (c) The University of Glasgow 2002-2006 -- diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index e412d7ef30..f2d6f7e39a 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] diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs index 4a00c91381..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 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..03ce53fff8 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 @@ -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 @@ -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 diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index bb51cdae9d..460c6076ba 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 @@ -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 @@ -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 @@ -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 61e7e39a49..dd16e52868 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -1,8 +1,8 @@ +{-# LANGUAGE CPP, TypeFamilies #-} + -- ----------------------------------------------------------------------------- -- | This is the top-level module in the LLVM code generator. -- - -{-# LANGUAGE TypeFamilies #-} module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where #include "HsVersions.h" diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 5d5f385ade..686b352c2a 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- ---------------------------------------------------------------------------- -- | Base LLVM Code Generation module -- diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 808c591d92..4a56600937 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 -- ----------------------------------------------------------------------------- @@ -229,6 +230,17 @@ genCall t@(PrimTarget (MO_PopCnt w)) dsts args = genCall t@(PrimTarget (MO_BSwap w)) dsts args = genCallSimpleCast w t dsts args +genCall (PrimTarget (MO_AtomicRead _)) [dst] [addr] = do + dstV <- getCmmReg (CmmLocal dst) + (v1, stmts, top) <- genLoad True addr (localRegType dst) + let stmt1 = Store v1 dstV + return (stmts `snocOL` stmt1, top) + +-- TODO: implement these properly rather than calling to RTS functions. +-- genCall t@(PrimTarget (MO_AtomicWrite width)) [] [addr, val] = undefined +-- genCall t@(PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = undefined +-- genCall t@(PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] = undefined + -- Handle memcpy function specifically since llvm's intrinsic version takes -- some extra parameters. genCall t@(PrimTarget op) [] args' @@ -549,7 +561,6 @@ cmmPrimOpFunctions mop = do (MO_Prefetch_Data _ )-> fsLit "llvm.prefetch" - MO_S_QuotRem {} -> unsupported MO_U_QuotRem {} -> unsupported MO_U_QuotRem2 {} -> unsupported @@ -559,6 +570,12 @@ cmmPrimOpFunctions mop = do MO_Touch -> unsupported MO_UF_Conv _ -> unsupported + MO_AtomicRead _ -> unsupported + + MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop + MO_Cmpxchg w -> fsLit $ cmpxchgLabel w + MO_AtomicWrite w -> fsLit $ atomicWriteLabel w + -- | Tail function calls genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData @@ -805,7 +822,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 +867,7 @@ exprToVarOpt opt e = case e of -> genLit opt lit CmmLoad e' ty - -> genLoad e' ty + -> genLoad False e' ty -- Cmmreg in expression is the value, so must load. If you want actual -- reg pointer, call getCmmReg directly. @@ -1002,8 +1019,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 +1286,41 @@ genMachOp_slow _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!" -- | Handle CmmLoad expression. -genLoad :: CmmExpr -> CmmType -> LlvmM ExprData +genLoad :: Atomic -> CmmExpr -> CmmType -> LlvmM ExprData -- First we try to detect a few common cases and produce better code for -- these then the default case. We are mostly trying to detect Cmm code -- like I32[Sp + n] and use 'getelementptr' operations instead of the -- generic case that uses casts and pointer arithmetic -genLoad e@(CmmReg (CmmGlobal r)) ty - = genLoad_fast e r 0 ty +genLoad atomic e@(CmmReg (CmmGlobal r)) ty + = genLoad_fast atomic e r 0 ty -genLoad e@(CmmRegOff (CmmGlobal r) n) ty - = genLoad_fast e r n ty +genLoad atomic e@(CmmRegOff (CmmGlobal r) n) ty + = genLoad_fast atomic e r n ty -genLoad e@(CmmMachOp (MO_Add _) [ +genLoad atomic e@(CmmMachOp (MO_Add _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]) ty - = genLoad_fast e r (fromInteger n) ty + = genLoad_fast atomic e r (fromInteger n) ty -genLoad e@(CmmMachOp (MO_Sub _) [ +genLoad atomic e@(CmmMachOp (MO_Sub _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]) ty - = genLoad_fast e r (negate $ fromInteger n) ty + = genLoad_fast atomic e r (negate $ fromInteger n) ty -- generic case -genLoad e ty +genLoad atomic e ty = do other <- getTBAAMeta otherN - genLoad_slow e ty other + genLoad_slow atomic e ty other -- | Handle CmmLoad expression. -- This is a special case for loading from a global register pointer -- offset such as I32[Sp+8]. -genLoad_fast :: CmmExpr -> GlobalReg -> Int -> CmmType - -> LlvmM ExprData -genLoad_fast e r n ty = do +genLoad_fast :: Atomic -> CmmExpr -> GlobalReg -> Int -> CmmType + -> LlvmM ExprData +genLoad_fast atomic e r n ty = do dflags <- getDynFlags (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) meta <- getTBAARegMeta r @@ -1316,7 +1333,7 @@ genLoad_fast e r n ty = do case grt == ty' of -- were fine True -> do - (var, s3) <- doExpr ty' (MExpr meta $ Load ptr) + (var, s3) <- doExpr ty' (MExpr meta $ loadInstr ptr) return (var, s1 `snocOL` s2 `snocOL` s3, []) @@ -1324,32 +1341,34 @@ genLoad_fast e r n ty = do False -> do let pty = pLift ty' (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty - (var, s4) <- doExpr ty' (MExpr meta $ Load ptr') + (var, s4) <- doExpr ty' (MExpr meta $ loadInstr ptr') return (var, s1 `snocOL` s2 `snocOL` s3 `snocOL` s4, []) -- If its a bit type then we use the slow method since -- we can't avoid casting anyway. - False -> genLoad_slow e ty meta - + False -> genLoad_slow atomic e ty meta + where + loadInstr ptr | atomic = ALoad SyncSeqCst False ptr + | otherwise = Load ptr -- | Handle Cmm load expression. -- Generic case. Uses casts and pointer arithmetic if needed. -genLoad_slow :: CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData -genLoad_slow e ty meta = do +genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData +genLoad_slow atomic e ty meta = do (iptr, stmts, tops) <- exprToVar e dflags <- getDynFlags case getVarType iptr of LMPointer _ -> do (dvar, load) <- doExpr (cmmToLlvmType ty) - (MExpr meta $ Load iptr) + (MExpr meta $ loadInstr iptr) return (dvar, stmts `snocOL` load, tops) i@(LMInt _) | i == llvmWord dflags -> do let pty = LMPointer $ cmmToLlvmType ty (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty (dvar, load) <- doExpr (cmmToLlvmType ty) - (MExpr meta $ Load ptr) + (MExpr meta $ loadInstr ptr) return (dvar, stmts `snocOL` cast `snocOL` load, tops) other -> do dflags <- getDynFlags @@ -1358,6 +1377,9 @@ genLoad_slow e ty meta = do "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ ", Size of var: " ++ show (llvmWidthInBits dflags other) ++ ", Var: " ++ showSDoc dflags (ppr iptr))) + where + loadInstr ptr | atomic = ALoad SyncSeqCst False ptr + | otherwise = Load ptr -- | Handle CmmReg expression. This will return a pointer to the stack diff --git a/compiler/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..7084a2e727 100644 --- a/compiler/llvmGen/LlvmMangler.hs +++ b/compiler/llvmGen/LlvmMangler.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- ----------------------------------------------------------------------------- -- | GHC LLVM Mangler -- 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..c0a609ba2e 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" @@ -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; @@ -190,11 +191,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 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 2981269d54..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 @@ -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 @@ -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 @@ -227,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" ] @@ -250,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 @@ -267,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 b93cef1fba..11427e27cf 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. @@ -892,16 +891,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 +930,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 +949,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, @@ -1216,6 +1208,7 @@ runPhase (RealPhase (As with_cpp)) 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,7 +1223,9 @@ runPhase (RealPhase (As with_cpp)) input_fn dflags ++ (if platformArch (targetPlatform dflags) == ArchSPARC then [SysTools.Option "-mcpu=v9"] else []) - + ++ (if any (ccInfo ==) [Clang, AppleClang, AppleClang51] + then [SysTools.Option "-Qunused-arguments"] + else []) ++ [ SysTools.Option "-x" , if with_cpp then SysTools.Option "assembler-with-cpp" @@ -2139,26 +2134,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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 72ebb38fc2..122eafff19 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ------------------------------------------------------------------------------- -- -- | Dynamic flags @@ -11,7 +13,7 @@ -- ------------------------------------------------------------------------------- -{-# OPTIONS -fno-cse #-} +{-# OPTIONS_GHC -fno-cse #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly module DynFlags ( @@ -30,6 +32,7 @@ module DynFlags ( wopt, wopt_set, wopt_unset, xopt, xopt_set, xopt_unset, lang_set, + useUnicodeSyntax, whenGeneratingDynamicToo, ifGeneratingDynamicToo, whenCannotGenerateDynamicToo, dynamicTooMkDynamicDynFlags, @@ -330,6 +333,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 @@ -403,8 +407,6 @@ data GeneralFlag | Opt_SuppressUniques -- temporary flags - | Opt_RunCPS - | Opt_RunCPSZ | Opt_AutoLinkPackages | Opt_ImplicitImportQualified @@ -580,6 +582,7 @@ data ExtensionFlag | Opt_TraditionalRecordSyntax | Opt_LambdaCase | Opt_MultiWayIf + | Opt_BinaryLiterals | Opt_NegativeLiterals | Opt_EmptyCase | Opt_PatternSynonyms @@ -774,7 +777,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, @@ -1292,12 +1295,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, @@ -1307,7 +1310,7 @@ initDynFlags dflags = do generatedDumps = refGeneratedDumps, llvmVersion = refLlvmVersion, nextWrapperNum = wrapperNum, - useUnicodeQuotes = canUseUnicodeQuotes, + useUnicode = canUseUnicode, rtldInfo = refRtldInfo, rtccInfo = refRtccInfo } @@ -1446,7 +1449,7 @@ defaultDynFlags mySettings = flushErr = defaultFlushErr, pprUserLength = 5, pprCols = 100, - useUnicodeQuotes = False, + useUnicode = False, traceLevel = 1, profAuto = NoProfAuto, llvmVersion = panic "defaultDynFlags: No llvmVersion", @@ -1682,6 +1685,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) @@ -2187,16 +2193,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 })) @@ -2650,6 +2649,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 ), @@ -2669,8 +2669,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 ), @@ -2685,7 +2683,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 ), @@ -2869,13 +2868,15 @@ 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 ), ( "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 ) @@ -2960,6 +2961,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)] @@ -3187,16 +3191,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) @@ -3764,6 +3761,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..02f731d3c2 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -4,6 +4,7 @@ \section[ErrsUtils]{Utilities for error reporting} \begin{code} +{-# LANGUAGE CPP #-} module ErrUtils ( ErrMsg, WarnMsg, Severity(..), diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs index 60683b2289..cbfd4e4f1c 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(..), @@ -432,8 +434,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 +445,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 +461,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 +477,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) -- ----------------------------------------------------------------------------- diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 7694bc9821..13d4f87009 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(..), @@ -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 @@ -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 diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index b7a1282f5c..694778115d 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 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..aef6007fb7 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 @@ -516,8 +517,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 +555,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 +585,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 +623,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 +636,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 @@ -1070,18 +1073,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 +1097,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 +1154,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 +1239,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 @@ -1533,11 +1536,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/HscTypes.lhs b/compiler/main/HscTypes.lhs index 6fcf8e24a7..9738f590b6 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 ( @@ -71,7 +72,7 @@ module HscTypes ( TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv, typeEnvFromEntities, mkTypeEnvWithImplicits, extendTypeEnv, extendTypeEnvList, - extendTypeEnvWithIds, extendTypeEnvWithPatSyns, + extendTypeEnvWithIds, lookupTypeEnv, typeEnvElts, typeEnvTyCons, typeEnvIds, typeEnvPatSyns, typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses, @@ -951,7 +952,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 @@ -1483,7 +1485,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 +1506,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 +1565,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 +1682,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} @@ -2207,37 +2200,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, diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index ede519982a..cfcc076235 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 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..514a2e004f 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 @@ -45,16 +47,11 @@ defaultPackageConfig = emptyInstalledPackageInfo -- $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 'PackageId's, which have the +-- form @<pkg>-<version>@. You're expected to pass in the version for +-- the @-package-name@ flag. However, for wired-in packages like @base@ +-- & @rts@, we don't necessarily know what the version is, so these are +-- handled specially; see #wired_in_packages#. -- | Turn a Cabal 'PackageIdentifier' into a GHC 'PackageId' mkPackageId :: PackageIdentifier -> PackageId diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index a13b3599b8..bb2e048cc3 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -2,13 +2,15 @@ % (c) The University of Glasgow, 2006 % \begin{code} +{-# LANGUAGE CPP #-} + -- | Package manipulation module Packages ( module PackageConfig, -- * The PackageConfigMap PackageConfigMap, emptyPackageConfigMap, lookupPackage, - extendPackageConfigMap, dumpPackages, + extendPackageConfigMap, dumpPackages, simpleDumpPackages, -- * Reading the package config, and processing cmdline args PackageState(..), @@ -1078,12 +1080,26 @@ 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 +dumpPackages = dumpPackages' showInstalledPackageInfo + +dumpPackages' :: (InstalledPackageInfo -> String) -> DynFlags -> IO () +dumpPackages' showIPI dflags = do let pkg_map = pkgIdMap (pkgState dflags) putMsg dflags $ - vcat (map (text . showInstalledPackageInfo + vcat (map (text . showIPI . packageConfigToInstalledPackageInfo) (eltsUFM pkg_map)) + +-- | 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 + \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..d993ab87c8 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -6,7 +6,8 @@ -- ----------------------------------------------------------------------------- -{-# 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 @@ -19,51 +20,83 @@ module PprTyThing ( pprTyThingLoc, pprTyThingInContextLoc, pprTyThingHdr, - pprTypeForUser + 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 +106,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 +123,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 +132,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 -- Then we want to display -- (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 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 53240faf48..641b0cb12f 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" @@ -727,7 +729,7 @@ 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 -> @@ -786,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" diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index b20658b073..7d47330044 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 ) where @@ -21,11 +23,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 @@ -129,18 +134,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' @@ -333,19 +340,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 @@ -354,6 +355,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 @@ -405,11 +416,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 @@ -517,7 +528,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 } @@ -559,14 +570,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)) diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 09a3bf7ec8..e53bb11cc3 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" @@ -605,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 diff --git a/compiler/nativeGen/CPrim.hs b/compiler/nativeGen/CPrim.hs index a6f4cab7bd..34782dfc1c 100644 --- a/compiler/nativeGen/CPrim.hs +++ b/compiler/nativeGen/CPrim.hs @@ -1,11 +1,16 @@ -- | Generating C symbol names emitted by the compiler. module CPrim - ( popCntLabel + ( atomicReadLabel + , atomicWriteLabel + , atomicRMWLabel + , cmpxchgLabel + , popCntLabel , bSwapLabel , word2FloatLabel ) where import CmmType +import CmmMachOp import Outputable popCntLabel :: Width -> String @@ -31,3 +36,46 @@ word2FloatLabel w = "hs_word2float" ++ pprWidth w pprWidth W32 = "32" pprWidth W64 = "64" pprWidth w = pprPanic "word2FloatLabel: Unsupported word width " (ppr w) + +atomicRMWLabel :: Width -> AtomicMachOp -> String +atomicRMWLabel w amop = "hs_atomic_" ++ pprFunName amop ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "atomicRMWLabel: Unsupported word width " (ppr w) + + pprFunName AMO_Add = "add" + pprFunName AMO_Sub = "sub" + pprFunName AMO_And = "and" + pprFunName AMO_Nand = "nand" + pprFunName AMO_Or = "or" + pprFunName AMO_Xor = "xor" + +cmpxchgLabel :: Width -> String +cmpxchgLabel w = "hs_cmpxchg" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "cmpxchgLabel: Unsupported word width " (ppr w) + +atomicReadLabel :: Width -> String +atomicReadLabel w = "hs_atomicread" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "atomicReadLabel: Unsupported word width " (ppr w) + +atomicWriteLabel :: Width -> String +atomicWriteLabel w = "hs_atomicwrite" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "atomicWriteLabel: Unsupported word width " (ppr w) diff --git a/compiler/nativeGen/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..014117dd4c 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,10 @@ genCCall' dflags gcp target dest_regs args0 MO_BSwap w -> (fsLit $ bSwapLabel w, False) MO_PopCnt w -> (fsLit $ popCntLabel w, False) + MO_AtomicRMW w amop -> (fsLit $ atomicRMWLabel w amop, False) + MO_Cmpxchg w -> (fsLit $ cmpxchgLabel w, False) + MO_AtomicRead w -> (fsLit $ atomicReadLabel w, False) + MO_AtomicWrite w -> (fsLit $ atomicWriteLabel w, False) MO_S_QuotRem {} -> unsupported MO_U_QuotRem {} -> unsupported diff --git a/compiler/nativeGen/PPC/Cond.hs b/compiler/nativeGen/PPC/Cond.hs index b8c5208c66..2568da5249 100644 --- a/compiler/nativeGen/PPC/Cond.hs +++ b/compiler/nativeGen/PPC/Cond.hs @@ -1,5 +1,5 @@ -{-# 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/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..bffa9ea63f 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 @@ -6,7 +8,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/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..77ca7480d6 100644 --- a/compiler/nativeGen/Reg.hs +++ b/compiler/nativeGen/Reg.hs @@ -5,7 +5,7 @@ -- by all architectures. -- -{-# 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/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 2d58ed9981..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, diff --git a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs index 0247c9dfae..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(..), diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 46d5309f70..ee43d25aa3 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 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 b0e763a6f0..1cb6dc8268 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,7 +10,7 @@ -- (c) The University of Glasgow 2004-2013 -- ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts, TypeFamilies #-} + module RegAlloc.Liveness ( RegSet, RegMap, emptyRegMap, @@ -666,14 +671,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..cac4e64221 100644 --- a/compiler/nativeGen/RegClass.hs +++ b/compiler/nativeGen/RegClass.hs @@ -1,4 +1,4 @@ -{-# 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/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index 5d65b427e1..51f89d629f 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,10 @@ outOfLineMachOp_table mop MO_BSwap w -> fsLit $ bSwapLabel w MO_PopCnt w -> fsLit $ popCntLabel w + MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop + MO_Cmpxchg w -> fsLit $ cmpxchgLabel w + MO_AtomicRead w -> fsLit $ atomicReadLabel w + MO_AtomicWrite w -> fsLit $ atomicWriteLabel w MO_S_QuotRem {} -> unsupported MO_U_QuotRem {} -> unsupported diff --git a/compiler/nativeGen/SPARC/CodeGen/Amode.hs b/compiler/nativeGen/SPARC/CodeGen/Amode.hs index 324eda94e7..f0aed0d02e 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Amode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Amode.hs @@ -1,5 +1,5 @@ -{-# 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/nativeGen/SPARC/CodeGen/Base.hs b/compiler/nativeGen/SPARC/CodeGen/Base.hs index 03b31e016a..45b7801960 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Base.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Base.hs @@ -1,5 +1,5 @@ -{-# 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/nativeGen/SPARC/CodeGen/CondCode.hs b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs index 375a9e1b33..2c3dbe6fc0 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs @@ -1,5 +1,5 @@ -{-# 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/nativeGen/SPARC/CodeGen/Expand.hs b/compiler/nativeGen/SPARC/CodeGen/Expand.hs index 03f571c20b..7ebc2f6630 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Expand.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs @@ -1,5 +1,5 @@ -{-# 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/nativeGen/SPARC/CodeGen/Gen32.hs b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs index df876b4622..43a26e525a 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs @@ -1,5 +1,5 @@ -{-# 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/nativeGen/SPARC/CodeGen/Sanity.hs b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs index d4cdaf2b16..5dff9ce704 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs @@ -1,5 +1,5 @@ -{-# 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/nativeGen/SPARC/Cond.hs b/compiler/nativeGen/SPARC/Cond.hs index b8919a72a2..198e4a7627 100644 --- a/compiler/nativeGen/SPARC/Cond.hs +++ b/compiler/nativeGen/SPARC/Cond.hs @@ -1,5 +1,5 @@ -{-# 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/nativeGen/SPARC/Imm.hs b/compiler/nativeGen/SPARC/Imm.hs index 4c2bb5a481..844a08824b 100644 --- a/compiler/nativeGen/SPARC/Imm.hs +++ b/compiler/nativeGen/SPARC/Imm.hs @@ -1,5 +1,5 @@ -{-# 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/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs index 601e04787a..8e4a2b32df 100644 --- a/compiler/nativeGen/SPARC/Instr.hs +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Machine-dependent assembly language @@ -6,7 +8,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/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..01db0ed3ac 100644 --- a/compiler/nativeGen/SPARC/Regs.hs +++ b/compiler/nativeGen/SPARC/Regs.hs @@ -4,7 +4,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/nativeGen/SPARC/ShortcutJump.hs b/compiler/nativeGen/SPARC/ShortcutJump.hs index 7f978c17c5..142ec6e65d 100644 --- a/compiler/nativeGen/SPARC/ShortcutJump.hs +++ b/compiler/nativeGen/SPARC/ShortcutJump.hs @@ -1,5 +1,5 @@ -{-# 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/nativeGen/SPARC/Stack.hs b/compiler/nativeGen/SPARC/Stack.hs index 4a6f4c1335..3560a0fe82 100644 --- a/compiler/nativeGen/SPARC/Stack.hs +++ b/compiler/nativeGen/SPARC/Stack.hs @@ -1,5 +1,5 @@ -{-# 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/nativeGen/Size.hs b/compiler/nativeGen/Size.hs index 45a39645cc..1b95ceb98b 100644 --- a/compiler/nativeGen/Size.hs +++ b/compiler/nativeGen/Size.hs @@ -1,4 +1,4 @@ -{-# 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/nativeGen/TargetReg.hs b/compiler/nativeGen/TargetReg.hs index 1f7f4e0db0..daf1e254c8 100644 --- a/compiler/nativeGen/TargetReg.hs +++ b/compiler/nativeGen/TargetReg.hs @@ -1,5 +1,5 @@ - -{-# 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/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index e659488fe0..8e9b49d78d 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, @@ -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 @@ -1751,6 +1773,99 @@ genCCall dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args = do where lbl = mkCmmCodeLabel primPackageId (fsLit (word2FloatLabel width)) +genCCall dflags is32Bit (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = do + Amode amode addr_code <- + if amop `elem` [AMO_Add, AMO_Sub] + then getAmode addr + else getSimpleAmode dflags is32Bit addr -- See genCCall for MO_Cmpxchg + arg <- getNewRegNat size + arg_code <- getAnyReg n + use_sse2 <- sse2Enabled + let platform = targetPlatform dflags + dst_r = getRegisterReg platform use_sse2 (CmmLocal dst) + code <- op_code dst_r arg amode + return $ addr_code `appOL` arg_code arg `appOL` code + where + -- Code for the operation + op_code :: Reg -- Destination reg + -> Reg -- Register containing argument + -> AddrMode -- Address of location to mutate + -> NatM (OrdList Instr) + op_code dst_r arg amode = case amop of + -- In the common case where dst_r is a virtual register the + -- final move should go away, because it's the last use of arg + -- and the first use of dst_r. + AMO_Add -> return $ toOL [ LOCK + , XADD size (OpReg arg) (OpAddr amode) + , MOV size (OpReg arg) (OpReg dst_r) + ] + AMO_Sub -> return $ toOL [ NEGI size (OpReg arg) + , LOCK + , XADD size (OpReg arg) (OpAddr amode) + , MOV size (OpReg arg) (OpReg dst_r) + ] + AMO_And -> cmpxchg_code (\ src dst -> unitOL $ AND size src dst) + AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND size src dst + , NOT size dst + ]) + AMO_Or -> cmpxchg_code (\ src dst -> unitOL $ OR size src dst) + AMO_Xor -> cmpxchg_code (\ src dst -> unitOL $ XOR size src dst) + where + -- Simulate operation that lacks a dedicated instruction using + -- cmpxchg. + cmpxchg_code :: (Operand -> Operand -> OrdList Instr) + -> NatM (OrdList Instr) + cmpxchg_code instrs = do + lbl <- getBlockIdNat + tmp <- getNewRegNat size + return $ toOL + [ MOV size (OpAddr amode) (OpReg eax) + , JXX ALWAYS lbl + , NEWBLOCK lbl + -- Keep old value so we can return it: + , MOV size (OpReg eax) (OpReg dst_r) + , MOV size (OpReg eax) (OpReg tmp) + ] + `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL + [ LOCK + , CMPXCHG size (OpReg tmp) (OpAddr amode) + , JXX NE lbl + ] + + size = intSize width + +genCCall dflags _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] = do + load_code <- intLoadCode (MOV (intSize width)) addr + let platform = targetPlatform dflags + use_sse2 <- sse2Enabled + return (load_code (getRegisterReg platform use_sse2 (CmmLocal dst))) + +genCCall _ _ (PrimTarget (MO_AtomicWrite width)) [] [addr, val] = do + assignMem_IntCode (intSize width) addr val + +genCCall dflags is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] = do + -- On x86 we don't have enough registers to use cmpxchg with a + -- complicated addressing mode, so on that architecture we + -- pre-compute the address first. + Amode amode addr_code <- getSimpleAmode dflags is32Bit addr + newval <- getNewRegNat size + newval_code <- getAnyReg new + oldval <- getNewRegNat size + oldval_code <- getAnyReg old + use_sse2 <- sse2Enabled + let platform = targetPlatform dflags + dst_r = getRegisterReg platform use_sse2 (CmmLocal dst) + code = toOL + [ MOV size (OpReg oldval) (OpReg eax) + , LOCK + , CMPXCHG size (OpReg newval) (OpAddr amode) + , MOV size (OpReg eax) (OpReg dst_r) + ] + return $ addr_code `appOL` newval_code newval `appOL` oldval_code oldval + `appOL` code + where + size = intSize width + genCCall _ is32Bit target dest_regs args | is32Bit = genCCall32 target dest_regs args | otherwise = genCCall64 target dest_regs args @@ -2375,6 +2490,11 @@ outOfLineCmmOp mop res args MO_PopCnt _ -> fsLit "popcnt" MO_BSwap _ -> fsLit "bswap" + MO_AtomicRMW _ _ -> fsLit "atomicrmw" + MO_AtomicRead _ -> fsLit "atomicread" + MO_AtomicWrite _ -> fsLit "atomicwrite" + MO_Cmpxchg _ -> fsLit "cmpxchg" + MO_UF_Conv _ -> unsupported MO_S_QuotRem {} -> unsupported diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index 75e5b9e737..ac91747171 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,16 +8,15 @@ -- ----------------------------------------------------------------------------- -#include "HsVersions.h" -#include "nativeGen/NCG.h" - -{-# LANGUAGE TypeFamilies #-} 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 @@ -326,6 +327,10 @@ data Instr | PREFETCH PrefetchVariant Size Operand -- prefetch Variant, addr size, address to prefetch -- variant can be NTA, Lvl0, Lvl1, or Lvl2 + | LOCK -- lock prefix + | XADD Size Operand Operand -- src (r), dst (r/m) + | CMPXCHG Size Operand Operand -- src (r), dst (r/m), eax implicit + data PrefetchVariant = NTA | Lvl0 | Lvl1 | Lvl2 @@ -336,6 +341,8 @@ data Operand +-- | Returns which registers are read and written as a (read, written) +-- pair. x86_regUsageOfInstr :: Platform -> Instr -> RegUsage x86_regUsageOfInstr platform instr = case instr of @@ -427,10 +434,21 @@ x86_regUsageOfInstr platform instr -- note: might be a better way to do this PREFETCH _ _ src -> mkRU (use_R src []) [] + LOCK -> noUsage + XADD _ src dst -> usageMM src dst + CMPXCHG _ src dst -> usageRMM src dst (OpReg eax) _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] @@ -443,6 +461,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] @@ -475,6 +505,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) @@ -482,6 +513,8 @@ interesting _ (RegReal (RealRegPair{})) = panic "X86.interesting: no re +-- | Applies the supplied function to all registers in instructions. +-- Typically used to change virtual registers to real registers. x86_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr x86_patchRegsOfInstr instr env = case instr of @@ -570,6 +603,10 @@ x86_patchRegsOfInstr instr env PREFETCH lvl size src -> PREFETCH lvl size (patchOp src) + LOCK -> instr + XADD sz src dst -> patch2 (XADD sz) src dst + CMPXCHG sz src dst -> patch2 (CMPXCHG sz) src dst + _other -> panic "patchRegs: unrecognised instr" where diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index f38a04d069..7771c02512 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Pretty-printing assembly language @@ -884,6 +886,14 @@ pprInstr GFREE ptext (sLit "\tffree %st(4) ;ffree %st(5)") ] +-- Atomics + +pprInstr LOCK = ptext (sLit "\tlock") + +pprInstr (XADD size src dst) = pprSizeOpOp (sLit "xadd") size src dst + +pprInstr (CMPXCHG size src dst) = pprSizeOpOp (sLit "cmpxchg") size src dst + pprInstr _ = panic "X86.Ppr.pprInstr: no match" diff --git a/compiler/nativeGen/X86/RegInfo.hs b/compiler/nativeGen/X86/RegInfo.hs index 8c63933c5b..0303295bc6 100644 --- a/compiler/nativeGen/X86/RegInfo.hs +++ b/compiler/nativeGen/X86/RegInfo.hs @@ -1,5 +1,5 @@ - -{-# 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/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..c024ebe45a 100644 --- a/compiler/parser/Ctype.lhs +++ b/compiler/parser/Ctype.lhs @@ -1,7 +1,8 @@ Character classification \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 @@ -18,7 +19,7 @@ module Ctype , is_digit -- Char# -> Bool , is_alphanum -- Char# -> Bool - , is_decdigit, is_hexdigit, is_octdigit + , is_decdigit, is_hexdigit, is_octdigit, is_bindigit , hexDigit, octDecDigit ) where @@ -86,6 +87,9 @@ is_hexdigit c 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')) 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..fe3d6a5d2b 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,9 @@ data Token | ITvect_scalar_prag | ITnovect_prag | ITminimal_prag + | ITno_overlap_prag -- instance overlap mode + | IToverlap_prag -- instance overlap mode + | ITincoherent_prag -- instance overlap mode | ITctype | ITdotdot -- reserved symbols @@ -635,7 +649,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 +678,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 +725,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 +836,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 +849,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 +863,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 +968,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 +1126,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 +1425,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 +1608,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], @@ -1669,13 +1685,13 @@ 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 +1871,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 +1995,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 +2007,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 +2431,9 @@ oneWordPrags = Map.fromList([("rules", rulePrag), ("vectorize", token ITvect_prag), ("novectorize", token ITnovect_prag), ("minimal", token ITminimal_prag), + ("no_overlap", token ITno_overlap_prag), + ("overlap", token IToverlap_prag), + ("incoherent", token ITincoherent_prag), ("ctype", token ITctype)]) twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)), @@ -2447,7 +2447,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 4f4ec0b123..a3c68c3e59 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -269,6 +269,9 @@ incorrect. '{-# NOVECTORISE' { L _ ITnovect_prag } '{-# MINIMAL' { L _ ITminimal_prag } '{-# CTYPE' { L _ ITctype } + '{-# NO_OVERLAP' { L _ ITno_overlap_prag } + '{-# OVERLAP' { L _ IToverlap_prag } + '{-# INCOHERENT' { L _ ITincoherent_prag } '#-}' { L _ ITclose_prag } '..' { L _ ITdotdot } -- reserved symbols @@ -654,12 +657,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 +681,13 @@ inst_decl :: { LInstDecl RdrName } {% mkDataFamInst (comb4 $1 $4 $6 $7) (unLoc $1) $3 $4 (unLoc $5) (unLoc $6) (unLoc $7) } +overlap_pragma :: { Maybe OverlapMode } + : '{-# OVERLAP' '#-}' { Just OverlapOk } + | '{-# INCOHERENT' '#-}' { Just Incoherent } + | '{-# NO_OVERLAP' '#-}' { Just NoOverlap } + | {- empty -} { Nothing } + + -- Closed type families where_type_family :: { Located (FamilyInfo RdrName) } @@ -783,7 +794,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 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 03ec622223..93a98d068e 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, @@ -32,6 +34,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 +74,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 +125,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 +160,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 +188,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 +197,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 +230,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 @@ -500,26 +518,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 +700,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) diff --git a/compiler/prelude/PrelInfo.lhs b/compiler/prelude/PrelInfo.lhs index 014e0e7483..829b5e3bf9 100644 --- a/compiler/prelude/PrelInfo.lhs +++ b/compiler/prelude/PrelInfo.lhs @@ -4,7 +4,8 @@ \section[PrelInfo]{The @PrelInfo@ interface to the compiler's prelude knowledge} \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/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 1d54726f2f..01c5764fd3 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -102,6 +102,8 @@ This is accomplished through a combination of mechanisms: See also Note [Built-in syntax and the OrigNameCache] \begin{code} +{-# LANGUAGE CPP #-} + module PrelNames ( Unique, Uniquable(..), hasKey, -- Re-exported for convenience @@ -128,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} %* * %************************************************************************ @@ -817,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 @@ -843,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 @@ -864,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 @@ -875,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 @@ -903,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, @@ -973,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 @@ -1005,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 @@ -1031,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, @@ -1065,24 +1080,24 @@ 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 -- 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 @@ -1090,7 +1105,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 @@ -1104,12 +1119,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 @@ -1119,21 +1134,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 @@ -1144,9 +1159,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 @@ -1202,10 +1217,6 @@ mk_known_key_name space modu str unique conName :: Module -> FastString -> Unique -> Name conName modu occ unique = mkExternalName unique modu (mkOccNameFS dataName occ) noSrcSpan - -methName :: Module -> FastString -> Unique -> Name -methName modu occ unique - = mkExternalName unique modu (mkVarOccFS occ) noSrcSpan \end{code} %************************************************************************ diff --git a/compiler/prelude/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..4155a541ba 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, 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 dc4c775e3a..4586b90cb2 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -4,6 +4,8 @@ \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 ( diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 10dd19d4bb..4faa585246 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -843,8 +843,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\#}. + } ------------------------------------------------------------------------ @@ -1082,34 +1096,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 +1148,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 +1363,79 @@ primop SetByteArrayOp "setByteArray#" GenPrimOp code_size = { primOpCodeSizeForeignCall + 4 } can_fail = True +-- Atomic operations + +primop AtomicReadByteArrayOp_Int "atomicReadIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #) + {Given an array and an offset in Int units, read an element. The + index is assumed to be in bounds. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop AtomicWriteByteArrayOp_Int "atomicWriteIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + {Given an array and an offset in Int units, write an element. The + index is assumed to be in bounds. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + primop CasByteArrayOp_Int "casIntArray#" GenPrimOp MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s, Int# #) - {Machine-level atomic compare and swap on a word within a ByteArray.} - with - out_of_line = True - has_side_effects = True + {Given an array, an offset in Int units, the expected old value, and + the new value, perform an atomic compare and swap i.e. write the new + value if the current value matches the provided old value. Returns + the value of the element before the operation. Implies a full memory + barrier.} + with has_side_effects = True + can_fail = True primop FetchAddByteArrayOp_Int "fetchAddIntArray#" GenPrimOp MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) - {Machine-level word-sized fetch-and-add within a ByteArray.} - with - out_of_line = True - has_side_effects = True + {Given an array, and offset in Int units, and a value to add, + atomically add the value to the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop FetchSubByteArrayOp_Int "fetchSubIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in Int units, and a value to subtract, + atomically substract the value to the element. Returns the value of + the element before the operation. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop FetchAndByteArrayOp_Int "fetchAndIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in Int units, and a value to AND, + atomically AND the value to the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop FetchNandByteArrayOp_Int "fetchNandIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in Int units, and a value to NAND, + atomically NAND the value to the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop FetchOrByteArrayOp_Int "fetchOrIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in Int units, and a value to OR, + atomically OR the value to the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop FetchXorByteArrayOp_Int "fetchXorIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in Int units, and a value to XOR, + atomically XOR the value to the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True ------------------------------------------------------------------------ @@ -2413,7 +2497,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 +2522,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..4a7a063897 100644 --- a/compiler/profiling/CostCentre.lhs +++ b/compiler/profiling/CostCentre.lhs @@ -1,5 +1,5 @@ \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/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 7251492ccf..e65d3173d6 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 @@ -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 diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 178f722d99..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,22 +268,29 @@ lookupExactOcc name ; return name } - (gre:_) -> return (gre_name gre) } + [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; but there will already be a - -- reported error for the duplicate. (If we add the error - -- rather than stopping when we encounter it.) - -- So all we need do here is not crash. - -- Example is Trac #8932: + -- 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 - -- Here the 'foo' in the splice turns into an Exact Name + -- 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 @@ -1080,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 @@ -1461,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") @@ -1473,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..d680292a25 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 @@ -45,16 +47,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 +58,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 +109,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 +150,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 +165,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 +192,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 +235,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 +277,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 +291,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 +319,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 +389,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 +412,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 +428,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 +468,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 +560,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 +941,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 +983,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 diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 7f6a840295..db4258607a 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, @@ -1301,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]) @@ -1314,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} @@ -1433,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 @@ -1452,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 @@ -1462,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 fbc22c0c28..9bc0e44780 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 @@ -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 @@ -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} 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 b2f697a632..c06036044d 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..2cf886c5c6 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 diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs index fbe8a3eb8a..dbab552431 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 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..c9323359c5 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 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 6edadb8bd9..225d5d612e 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 436d1b63aa..59b39a9c60 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..1c5ebc501b 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, diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 59e5d4adc1..14789c44a4 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, diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 02470be050..1125c2e883 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} 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 0c47042b4d..7807d895dc 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 72137c7b4b..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') @@ -595,7 +596,16 @@ dmdAnalRhs :: TopLevelFlag dmdAnalRhs top_lvl rec_flag env id rhs | 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') diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs index df7edae991..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 diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs index 4610b58734..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 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..e5cd356712 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, @@ -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..dac522803f 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 @@ -382,14 +383,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 OverlapOk + | otherwise = use NoOverlap ; return overlap_flag } @@ -461,10 +463,10 @@ addLocalInst home_ie ispec 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 + True -> case (dup_ispecs, home_ie_matches, unifs, overlapMode 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) + ([], _, 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 @@ -476,7 +478,8 @@ 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 () 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 407e1725ff..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,14 +222,14 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty) -- D;G |-a cmd exp : stk --> res tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty) - = addErrCtxt (cmdCtxt cmd) $ + = addErrCtxt (cmdCtxt cmd) $ do { arg_ty <- newFlexiTyVarTy openTypeKind - ; fun' <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty) - ; arg' <- tcMonoExpr arg arg_ty - ; return (HsCmdApp fun' arg') } + ; fun' <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty) + ; arg' <- tcMonoExpr arg arg_ty + ; return (HsCmdApp fun' arg') } ------------------------------------------- --- Lambda +-- Lambda -- -- D;G,x:t |-a cmd : stk --> res -- ------------------------------ @@ -243,60 +238,60 @@ tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty) tc_cmd env (HsCmdLam (MG { mg_alts = [L mtch_loc (match@(Match pats _maybe_rhs_sig grhss))], mg_origin = origin })) (cmd_stk, res_ty) - = addErrCtxt (pprMatchInCtxt match_ctxt match) $ - do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk + = addErrCtxt (pprMatchInCtxt match_ctxt match) $ + do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk - -- Check the patterns, and the GRHSs inside - ; (pats', grhss') <- setSrcSpan mtch_loc $ + -- Check the patterns, and the GRHSs inside + ; (pats', grhss') <- setSrcSpan mtch_loc $ tcPats LambdaExpr pats arg_tys $ tc_grhss grhss cmd_stk' res_ty - ; let match' = L mtch_loc (Match pats' Nothing grhss') + ; let match' = L mtch_loc (Match pats' Nothing grhss') arg_tys = map hsLPatType pats' cmd' = HsCmdLam (MG { mg_alts = [match'], mg_arg_tys = arg_tys , mg_res_ty = res_ty, mg_origin = origin }) - ; return (mkHsCmdCast co cmd') } + ; return (mkHsCmdCast co cmd') } where n_pats = length pats - match_ctxt = (LambdaExpr :: HsMatchContext Name) -- Maybe KappaExpr? + match_ctxt = (LambdaExpr :: HsMatchContext Name) -- Maybe KappaExpr? pg_ctxt = PatGuard match_ctxt tc_grhss (GRHSs grhss binds) stk_ty res_ty - = do { (binds', grhss') <- tcLocalBinds binds $ - mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss - ; return (GRHSs grhss' binds') } + = do { (binds', grhss') <- tcLocalBinds binds $ + mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss + ; return (GRHSs grhss' binds') } tc_grhs stk_ty res_ty (GRHS guards body) - = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ - \ res_ty -> tcCmd env body (stk_ty, res_ty) - ; return (GRHS guards' rhs') } + = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ + \ res_ty -> tcCmd env body (stk_ty, res_ty) + ; return (GRHS guards' rhs') } ------------------------------------------- --- Do notation +-- Do notation tc_cmd env (HsCmdDo stmts _) (cmd_stk, res_ty) - = do { co <- unifyType unitTy cmd_stk -- Expecting empty argument stack - ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty - ; return (mkHsCmdCast co (HsCmdDo stmts' res_ty)) } + = do { co <- unifyType unitTy cmd_stk -- Expecting empty argument stack + ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty + ; return (mkHsCmdCast co (HsCmdDo stmts' res_ty)) } ----------------------------------------------------------------- --- Arrow ``forms'' (| e c1 .. cn |) +-- Arrow ``forms'' (| e c1 .. cn |) -- --- D; G |-a1 c1 : stk1 --> r1 --- ... --- D; G |-an cn : stkn --> rn --- D |- e :: forall e. a1 (e, stk1) t1 +-- D; G |-a1 c1 : stk1 --> r1 +-- ... +-- D; G |-an cn : stkn --> rn +-- D |- e :: forall e. a1 (e, stk1) t1 -- ... -- -> an (e, stkn) tn -- -> a (e, stk) t --- e \not\in (stk, stk1, ..., stkm, t, t1, ..., tn) --- ---------------------------------------------- --- D; G |-a (| e c1 ... cn |) : stk --> t +-- e \not\in (stk, stk1, ..., stkm, t, t1, ..., tn) +-- ---------------------------------------------- +-- D; G |-a (| e c1 ... cn |) : stk --> t -tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty) - = addErrCtxt (cmdCtxt cmd) $ - do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args +tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty) + = addErrCtxt (cmdCtxt cmd) $ + do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args ; let e_ty = mkForAllTy alphaTyVar $ -- We use alphaTyVar for 'w' mkFunTys cmd_tys $ mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty @@ -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 17f124b0d8..887e41c0d5 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, @@ -37,6 +39,7 @@ import TysPrim import Id import Var import VarSet +import VarEnv( TidyEnv ) import Module import Name import NameSet @@ -54,7 +57,7 @@ import FastString import Type(mkStrLitTy) import Class(classTyCon) import PrelNames(ipClassName) -import TcValidity (checkValidTheta) +import TcValidity (checkValidType) import Control.Monad @@ -271,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] @@ -278,19 +305,26 @@ 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] $ + tcBindGroups top_lvl sig_fn prag_fn + binds thing_inside } + where + patsyn_placeholder_kinds -- See Note [Placeholder PatSyn kinds] + = [ (name, placeholder_patsyn_tything) + | (_, lbinds) <- binds + , L _ (PatSynBind{ patsyn_id = L _ name }) <- bagToList lbinds ] + placeholder_patsyn_tything + = AGlobal $ AConLike $ PatSynCon $ panic "fakePatSynCon" ------------------------ tcBindGroups :: TopLevelFlag -> TcSigFun -> PragFun @@ -559,16 +593,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 - - ; theta <- zonkTcThetaType (map evVarPred givens) - -- We need to check inferred theta for validity. The reason is that we - -- might have inferred theta that requires language extension that is - -- not turned on. See #8883. Example can be found in the T8883 testcase. - ; checkValidTheta (InfSigCtxt (fst . head $ name_taus)) theta - ; exports <- checkNoErrs $ mapM (mkExport prag_fn qtvs theta) mono_infos + ; (qtvs, givens, mr_bites, ev_binds) + <- simplifyInfer closed mono name_taus wanted + ; 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 @@ -603,20 +632,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 @@ -632,7 +653,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 @@ -643,24 +664,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 diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 5784d81ce4..43cbb2c49d 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -1,4 +1,6 @@ \begin{code} +{-# LANGUAGE CPP #-} + module TcCanonical( canonicalize, emitWorkNC, StopOrContinue (..) @@ -1260,7 +1262,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 187aea5083..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 diff --git a/compiler/typecheck/TcDefaults.lhs b/compiler/typecheck/TcDefaults.lhs index a096e506ed..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 diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 71fd25c557..d18c21c9de 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 ) import TcClassDcl( tcAddDeclCtxt ) -- Small helper import TcGenDeriv -- Deriv stuff import TcGenGenerics @@ -91,6 +93,7 @@ data DerivSpec theta = DS { ds_loc :: SrcSpan , 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 @@ -565,6 +568,7 @@ deriveAutoTypeable auto_typeable done_specs tycl_decls 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 } @@ -597,7 +601,7 @@ deriveFamInst decl@(DataFamInstDecl { dfid_tycon = L _ tc_name, dfid_pats = pats , dfid_defn = HsDataDefn { dd_derivs = Just preds } }) = tcAddDataFamInstCtxt decl $ do { fam_tc <- tcLookupTyCon tc_name - ; tcFamTyPats tc_name (tyConKind fam_tc) pats (\_ -> return ()) $ + ; tcFamTyPats (famTyConShape fam_tc) pats (\_ -> return ()) $ \ tvs' pats' _ -> concatMapM (deriveTyData True tvs' fam_tc pats') preds } -- Tiresomely we must figure out the "lhs", which is awkward for type families @@ -615,7 +619,7 @@ 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) @@ -644,7 +648,7 @@ deriveStandalone (L loc (DerivDecl deriv_ty)) ; mkPolyKindedTypeableEqn cls tc } | isAlgTyCon tc -- All other classes - -> do { spec <- mkEqnHelp tvs cls cls_tys tc tc_args (Just theta) + -> do { spec <- mkEqnHelp overlap_mode tvs cls cls_tys tc tc_args (Just theta) ; return [spec] } _ -> -- Complain about functions, primitive types, etc, @@ -702,8 +706,9 @@ deriveTyData :: Bool -- False <=> data/newtype -- 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 @@ -717,12 +722,8 @@ deriveTyData is_instance tvs tc tc_args (L loc deriv_pred) 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 - - ; let cls_arg_kind = tyVarKind (last cls_tyvars) - (arg_kinds, _) = splitKindFunTys cls_arg_kind + -- 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 @@ -734,9 +735,9 @@ deriveTyData is_instance 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 @@ -769,7 +770,7 @@ deriveTyData is_instance tvs tc tc_args (L loc deriv_pred) -- newtype T a s = ... deriving( ST s ) -- newtype K a a = ... deriving( Monad ) - ; spec <- mkEqnHelp (univ_kvs' ++ univ_tvs') + ; spec <- mkEqnHelp Nothing (univ_kvs' ++ univ_tvs') cls final_cls_tys tc final_tc_args Nothing ; return [spec] } } @@ -851,7 +852,8 @@ and occurrence sites. \begin{code} -mkEqnHelp :: [TyVar] +mkEqnHelp :: Maybe OverlapMode + -> [TyVar] -> Class -> [Type] -> TyCon -> [Type] -> DerivContext -- Just => context supplied (standalone deriving) @@ -862,7 +864,7 @@ 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 @@ -898,10 +900,10 @@ mkEqnHelp tvs cls cls_tys tycon tc_args mtheta ; dflags <- getDynFlags ; if isDataTyCon rep_tc then - mkDataTypeEqn dflags tvs cls cls_tys + mkDataTypeEqn dflags overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta else - mkNewTypeEqn dflags tvs cls cls_tys + mkNewTypeEqn dflags overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta } where bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg) @@ -991,6 +993,7 @@ See Note [Eta reduction for data family axioms] in TcInstDcls. \begin{code} mkDataTypeEqn :: DynFlags + -> Maybe OverlapMode -> [Var] -- Universally quantified type variables in the instance -> Class -- Class for which we need to derive an instance -> [Type] -- Other parameters to the class except the last @@ -1002,7 +1005,7 @@ mkDataTypeEqn :: DynFlags -> DerivContext -- Context of the instance, for standalone deriving -> TcRn EarlyDerivSpec -- Return 'Nothing' if error -mkDataTypeEqn dflags tvs cls cls_tys +mkDataTypeEqn dflags overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta = case checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args of -- NB: pass the *representation* tycon to checkSideConditions @@ -1010,13 +1013,13 @@ mkDataTypeEqn dflags tvs cls cls_tys NonDerivableClass -> bale_out (nonStdErr cls) DerivableClassError msg -> bale_out msg where - go_for_it = mk_data_eqn tvs cls tycon tc_args rep_tc rep_tc_args mtheta + go_for_it = mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg) -mk_data_eqn :: [TyVar] -> Class +mk_data_eqn :: Maybe OverlapMode -> [TyVar] -> Class -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext -> TcM EarlyDerivSpec -mk_data_eqn tvs cls tycon tc_args rep_tc rep_tc_args mtheta +mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta = do loc <- getSrcSpanM dfun_name <- new_dfun_name cls tycon case mtheta of @@ -1028,6 +1031,7 @@ mk_data_eqn tvs cls tycon tc_args rep_tc rep_tc_args mtheta , ds_cls = cls, ds_tys = inst_tys , ds_tc = rep_tc, ds_tc_args = rep_tc_args , ds_theta = inferred_constraints + , ds_overlap = overlap_mode , ds_newtype = False } Just theta -> do -- Specified context return $ GivenTheta $ DS @@ -1036,6 +1040,7 @@ mk_data_eqn tvs cls tycon tc_args rep_tc rep_tc_args mtheta , ds_cls = cls, ds_tys = inst_tys , ds_tc = rep_tc, ds_tc_args = rep_tc_args , ds_theta = theta + , ds_overlap = overlap_mode , ds_newtype = False } where inst_tys = [mkTyConApp tycon tc_args] @@ -1073,7 +1078,9 @@ mkOldTypeableEqn tvs cls tycon tc_args mtheta DS { ds_loc = loc, ds_name = dfun_name, ds_tvs = [] , ds_cls = cls, ds_tys = [mkTyConApp tycon []] , ds_tc = tycon, ds_tc_args = [] - , ds_theta = mtheta `orElse` [], ds_newtype = False }) } + , ds_theta = mtheta `orElse` [] + , ds_overlap = Nothing -- Or, Just NoOverlap? + , ds_newtype = False }) } mkPolyKindedTypeableEqn :: Class -> TyCon -> TcM [EarlyDerivSpec] -- We can arrive here from a 'deriving' clause @@ -1098,6 +1105,9 @@ mkPolyKindedTypeableEqn cls tc -- so we must instantiate it appropiately , ds_tc = tc, ds_tc_args = tc_args , ds_theta = [] -- Context is empty for polykinded Typeable + , ds_overlap = Nothing + -- Perhaps this should be `Just NoOverlap`? + , ds_newtype = False } } where (kvs,tc_app_kind) = splitForAllTys (tyConKind tc) @@ -1121,21 +1131,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] @@ -1145,10 +1157,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 @@ -1442,16 +1454,6 @@ 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 @@ -1553,14 +1555,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 @@ -1571,6 +1574,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 @@ -1578,6 +1582,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 @@ -1591,7 +1596,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 @@ -1687,15 +1692,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 @@ -1711,13 +1711,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] @@ -2058,9 +2055,10 @@ genInst :: Bool -- True <=> standalone deriving -> OverlapFlag -> CommonAuxiliaries -> DerivSpec ThetaType -> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name) -genInst standalone_deriv oflag comauxs +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_overlap = overlap_mode , ds_name = name, ds_cls = clas, ds_loc = loc }) | is_newtype = do { inst_spec <- mkInstance oflag theta spec @@ -2091,6 +2089,7 @@ 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 diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index f3d754640f..6020797449 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, @@ -66,6 +68,7 @@ import TcIface import PrelNames import TysWiredIn import Id +import IdInfo( IdDetails(VanillaId) ) import Var import VarSet import RdrName @@ -801,7 +804,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 @@ -864,13 +867,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 3ca1319a9d..8fe97519e1 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 @@ -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 @@ -734,7 +735,7 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2 , 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 + tv_extra = extraTyVarInfo ctxt tv1 ty2 add_sig = suggestAddSig ctxt ty1 ty2 ; mkErrorMsg ctxt ct (vcat [msg, untch_extra, tv_extra, add_sig, extra]) } @@ -793,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 } @@ -815,15 +816,18 @@ pp_givens givens 2 (sep [ ptext (sLit "bound by") <+> ppr skol_info , ptext (sLit "at") <+> ppr loc]) -extraTyVarInfo :: ReportErrCtxt -> TcType -> TcType -> SDoc +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 (tv_extra ty1 $$ tv_extra ty2) +extraTyVarInfo ctxt tv1 ty2 + = nest 2 (tv_extra tv1 $$ ty_extra ty2) where implics = cec_encl ctxt - tv_extra ty | Just tv <- tcGetTyVar_maybe ty - , isTcTyVar tv, isSkolemTyVar tv + 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) @@ -1285,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 63eb020ff1..8370e0aa06 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 @@ -92,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, @@ -114,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 @@ -141,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 diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 7031e54f6f..960e3faaa3 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -11,7 +11,7 @@ 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(..), diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs index d9d92ba2ea..385fc37306 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, @@ -46,7 +40,7 @@ import BuildTyCl import SrcLoc import Bag import VarSet (elemVarSet) -import Outputable +import Outputable import FastString import Util @@ -64,7 +58,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 +84,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 +115,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 +138,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 +150,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 +163,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 +183,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 = (:) } {- @@ -287,8 +280,8 @@ canDoGenerics tc tc_args then (Just (ppr dc <+> text "must be a vanilla data constructor")) else Nothing) - -- 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 @@ -402,13 +395,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 +428,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 +450,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 +462,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 +495,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 +578,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 +595,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 +609,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 +624,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 +639,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 +710,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 +771,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 +815,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 +841,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 59b42ea673..f90cfca317 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 @@ -1025,16 +1035,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. @@ -1043,7 +1053,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..cdeb191489 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 @@ -53,6 +54,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 +74,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 +210,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 +396,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 +625,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 +734,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) @@ -1297,6 +1307,11 @@ tcTyClTyVars tycon (HsQTvs { hsq_kvs = hs_kvs, hsq_tvs = hs_tvs }) thing_inside ; tvs <- zipWithM tc_hs_tv hs_tvs kinds ; tcExtendTyVarEnv tvs (thing_inside (kvs ++ tvs) res) } where + -- In the case of associated types, the renamer has + -- ensured that the names are in commmon + -- e.g. class C a_29 where + -- type T b_30 a_29 :: * + -- Here the a_29 is shared tc_hs_tv (L _ (UserTyVar n)) kind = return (mkTyVar n kind) tc_hs_tv (L _ (KindedTyVar n hs_k)) kind = do { tc_kind <- tcLHsKind hs_k ; checkKind kind tc_kind @@ -1313,21 +1328,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 +1352,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 fc1842908d..c3ba825cd5 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 @@ -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 @@ -504,6 +507,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 +529,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 +557,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 +647,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 +685,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 +700,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 +723,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 diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 3d057ae2d7..02c5866018 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 @@ -103,6 +105,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 } @@ -1584,7 +1587,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 } -------------------- @@ -2032,6 +2037,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 [] @@ -2047,7 +2054,19 @@ 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 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 (D ty1 ty2) (D ty1' ty2') (see case 2 in [Coercible Instances]) | Just (tc1,tyArgs1) <- splitTyConApp_maybe ty1, Just (tc2,tyArgs2) <- splitTyConApp_maybe ty2, tc1 == tc2, @@ -2078,19 +2097,7 @@ 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]) + -- 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 @@ -2141,7 +2148,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. @@ -2150,26 +2157,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 @@ -2177,12 +2172,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 @@ -2191,6 +2198,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 f646305e39..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 diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index 5859e7b810..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 diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 0b2a200867..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,14 +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" (vcat [ ppr con_name, ppr univ_tvs, ppr ex_tvs, ppr eq_spec - , ppr ex_tvs', ppr pat_ty', ppr arg_tys' ]) + , 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]) @@ -747,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) } @@ -780,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) } } @@ -790,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 @@ -838,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 0b3b4e4858..82fa999f34 100644 --- a/compiler/typecheck/TcPatSyn.lhs +++ b/compiler/typecheck/TcPatSyn.lhs @@ -5,6 +5,8 @@ \section[TcPatSyn]{Typechecking pattern synonym declarations} \begin{code} +{-# LANGUAGE CPP #-} + module TcPatSyn (tcPatSynDecl) where import HsSyn @@ -22,6 +24,7 @@ import Outputable import FastString import Var import Id +import IdInfo( IdDetails( VanillaId ) ) import TcBinds import BasicTypes import TcSimplify @@ -31,31 +34,11 @@ import Data.Monoid import Bag import TcEvidence import BuildTyCl +import TypeRep #include "HsVersions.h" \end{code} -Note [Pattern synonym typechecking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Consider the following pattern synonym declaration - - pattern P x = MkT [x] (Just 42) - -where - data T a where - MkT :: (Show a, Ord b) => [b] -> a -> T a - -The pattern synonym's type is described with five axes, given here for -the above example: - - Pattern type: T (Maybe t) - Arguments: [x :: b] - Universal type variables: [t] - Required theta: (Eq t, Num t) - Existential type variables: [b] - Provided theta: (Show (Maybe t), Ord b) - \begin{code} tcPatSynDecl :: Located Name -> HsPatSynDetails (Located Name) @@ -118,7 +101,7 @@ tcPatSynDecl lname@(L _ name) details lpat dir ; traceTc "tcPatSynDecl }" $ ppr name ; let patSyn = mkPatSyn name is_infix - args + (map varType args) univ_tvs ex_tvs prov_theta req_theta pat_ty @@ -127,40 +110,6 @@ tcPatSynDecl lname@(L _ name) details lpat dir \end{code} -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) - -N.b. 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. \begin{code} tcPatSynMatcher :: Located Name @@ -172,12 +121,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 @@ -241,6 +196,7 @@ tcPatSynWrapper :: Located Name -> ThetaType -> TcType -> TcM (Maybe (Id, LHsBinds Id)) +-- See Note [Matchers and wrappers for pattern synonyms] in PatSyn tcPatSynWrapper lname lpat dir args univ_tvs ex_tvs theta pat_ty = do { let argNames = mkNameSet (map Var.varName args) ; case (dir, tcPatToExpr argNames lpat) of @@ -260,18 +216,16 @@ tc_pat_syn_wrapper_from_expr :: Located Name -> TcM (Id, LHsBinds Id) tc_pat_syn_wrapper_from_expr (L loc name) lexpr 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 + ; let wrapper_lname = L loc wrapper_name + wrapper_id = mkExportedLocalId VanillaId wrapper_name wrapper_sigma ; let wrapper_args = map (noLoc . VarPat . Var.varName) args' wrapper_match = mkMatch wrapper_args lexpr EmptyLocalBinds diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 5b39132254..281db25620 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 @@ -82,7 +82,6 @@ import CoAxiom import Inst ( tcGetInstEnvs ) import Annotations import Data.List ( sortBy ) -import Data.IORef ( readIORef ) import Data.Ord #ifdef GHCI import BasicTypes hiding( SuccessFlag(..) ) @@ -306,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 %* * %************************************************************************ @@ -647,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] @@ -669,19 +590,11 @@ checkHiBootIface -- Check instance declarations ; mb_dfun_prs <- mapM check_inst boot_insts - ; let dfun_prs = catMaybes mb_dfun_prs - boot_dfuns = map fst dfun_prs - dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) - | (boot_dfun, dfun) <- dfun_prs ] - type_env' = extendTypeEnvWithIds local_type_env boot_dfuns - tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds } ; failIfErrsM - ; setGlobalTypeEnv tcg_env' type_env' } - -- Update the global type env *including* the knot-tied one - -- so that if the source module reads in an interface unfolding - -- mentioning one of the dfuns from the boot module, then it - -- can "see" that boot dfun. See Trac #4003 + + ; return mb_dfun_prs } + where check_export boot_avail -- boot_avail is exported by the boot iface | name `elem` dfun_names = return () @@ -735,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 @@ -783,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) && @@ -1148,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 @@ -1864,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, @@ -1900,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) @@ -1956,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 01c9d36cf3..17700e77ce 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, @@ -1245,17 +1247,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 0355dab9c7..bc536c17a8 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)], @@ -1282,6 +1284,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 +1745,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 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 ad3e5cbcb7..60ff5d26c8 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -1,6 +1,7 @@ \begin{code} +{-# LANGUAGE CPP, TypeFamilies #-} + -- Type definitions for the constraint solver -{-# LANGUAGE TypeFamilies #-} module TcSMonad ( -- Canonical constraints, definition is now in TcRnTypes @@ -461,6 +462,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] @@ -478,8 +480,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))) @@ -506,9 +529,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 } @@ -521,10 +544,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 @@ -601,7 +626,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 @@ -1125,8 +1150,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 $ @@ -1154,8 +1179,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 @@ -1173,8 +1198,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 @@ -1257,19 +1282,36 @@ 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) @@ -1354,7 +1396,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 @@ -1794,7 +1836,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] @@ -1821,7 +1863,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 64ef3fed4b..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, @@ -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. ********************************************************************************* diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 7fce241edb..de3fbdbe89 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(..) ) @@ -1183,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 @@ -1507,13 +1508,14 @@ lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn)) mkModule (stringToPackageId $ 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 diff --git a/compiler/typecheck/TcSplice.lhs-boot b/compiler/typecheck/TcSplice.lhs-boot index c496aed798..ea3848db18 100644 --- a/compiler/typecheck/TcSplice.lhs-boot +++ b/compiler/typecheck/TcSplice.lhs-boot @@ -1,4 +1,6 @@ \begin{code} +{-# LANGUAGE CPP #-} + module TcSplice where import HsSyn ( HsSplice, HsBracket, HsQuasiQuote, HsExpr, LHsType, LHsExpr, LPat, LHsDecl ) diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index f11295a7d0..f09bef8081 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 @@ -502,10 +502,12 @@ kcTyClDecl (ForeignType {}) = return () -- closed type families look at their equations, but other families don't -- do anything here -kcTyClDecl (FamDecl (FamilyDecl { fdLName = L _ fam_tc_name - , fdInfo = ClosedTypeFamily eqns })) - = do { k <- kcLookupKind fam_tc_name - ; mapM_ (kcTyFamInstEqn fam_tc_name k) eqns } +kcTyClDecl (FamDecl (FamilyDecl { fdLName = L _ fam_tc_name + , fdTyVars = hs_tvs + , fdInfo = ClosedTypeFamily eqns })) + = do { tc_kind <- kcLookupKind fam_tc_name + ; let fam_tc_shape = ( fam_tc_name, length (hsQTvBndrs hs_tvs), tc_kind) + ; mapM_ (kcTyFamInstEqn fam_tc_shape) eqns } kcTyClDecl (FamDecl {}) = return () ------------------- @@ -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. @@ -793,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) @@ -808,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} @@ -836,76 +835,90 @@ Note that: - We can get default definitions only for type families, not data families \begin{code} -tcClassATs :: Name -- The class name (not knot-tied) - -> TyConParent -- The class parent of this associated type - -> [LFamilyDecl Name] -- Associated types. - -> [LTyFamInstDecl Name] -- Associated type defaults. +tcClassATs :: Name -- The class name (not knot-tied) + -> TyConParent -- The class parent of this associated type + -> [LFamilyDecl Name] -- Associated types. + -> [LTyFamDefltEqn Name] -- Associated type defaults. -> TcM [ClassATItem] tcClassATs class_name parent ats at_defs = do { -- Complain about associated type defaults for non associated-types sequence_ [ failWithTc (badATErr class_name n) - | n <- map (tyFamInstDeclName . unLoc) at_defs + | n <- map at_def_tycon at_defs , not (n `elemNameSet` at_names) ] ; mapM tc_at ats } where - at_names = mkNameSet (map (unLoc . fdLName . unLoc) ats) + at_def_tycon :: LTyFamDefltEqn Name -> Name + at_def_tycon (L _ eqn) = unLoc (tfe_tycon eqn) + + at_fam_name :: LFamilyDecl Name -> Name + at_fam_name (L _ decl) = unLoc (fdLName decl) + + at_names = mkNameSet (map at_fam_name ats) - at_defs_map :: NameEnv [LTyFamInstDecl Name] + at_defs_map :: NameEnv [LTyFamDefltEqn Name] -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs' at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv - (tyFamInstDeclName (unLoc at_def)) [at_def]) + (at_def_tycon at_def) [at_def]) emptyNameEnv at_defs tc_at at = do { [ATyCon fam_tc] <- addLocM (tcFamDecl1 parent) at - ; let at_defs = lookupNameEnv at_defs_map (unLoc $ fdLName $ unLoc at) - `orElse` [] - ; atd <- mapM (tcDefaultAssocDecl fam_tc) at_defs - ; return (fam_tc, atd) } + ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at) + `orElse` [] + ; atd <- tcDefaultAssocDecl fam_tc at_defs + ; return (ATI fam_tc atd) } ------------------------- -tcDefaultAssocDecl :: TyCon -- ^ Family TyCon - -> LTyFamInstDecl Name -- ^ RHS - -> TcM CoAxBranch -- ^ Type checked RHS and free TyVars -tcDefaultAssocDecl fam_tc (L loc decl) +tcDefaultAssocDecl :: TyCon -- ^ Family TyCon + -> [LTyFamDefltEqn Name] -- ^ Defaults + -> TcM (Maybe Type) -- ^ Type checked RHS +tcDefaultAssocDecl _ [] + = return Nothing -- No default declaration + +tcDefaultAssocDecl _ (d1:_:_) + = failWithTc (ptext (sLit "More than one default declaration for") + <+> ppr (tfe_tycon (unLoc d1))) + +tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = L _ tc_name + , tfe_pats = hs_tvs + , tfe_rhs = rhs })] = setSrcSpan loc $ - tcAddTyFamInstCtxt decl $ - do { traceTc "tcDefaultAssocDecl" (ppr decl) - ; tcSynFamInstDecl fam_tc decl } + tcAddFamInstCtxt (ptext (sLit "default type instance")) tc_name $ + tcTyClTyVars tc_name hs_tvs $ \ tvs rhs_kind -> + do { traceTc "tcDefaultAssocDecl" (ppr tc_name) + ; checkTc (isSynFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) + ; let (fam_name, fam_pat_arity, _) = famTyConShape fam_tc + ; ASSERT( fam_name == tc_name ) + checkTc (length (hsQTvBndrs hs_tvs) == fam_pat_arity) + (wrongNumberOfParmsErr fam_pat_arity) + ; rhs_ty <- tcCheckLHsType rhs rhs_kind + ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty + ; let fam_tc_tvs = tyConTyVars fam_tc + subst = zipTopTvSubst tvs (mkTyVarTys fam_tc_tvs) + ; return ( ASSERT( equalLength fam_tc_tvs tvs ) + Just (substTy subst rhs_ty) ) } -- We check for well-formedness and validity later, in checkValidClass ------------------------- -tcSynFamInstDecl :: TyCon -> TyFamInstDecl Name -> TcM CoAxBranch --- Placed here because type family instances appear as --- default decls in class declarations -tcSynFamInstDecl fam_tc (TyFamInstDecl { tfid_eqn = eqn }) - = do { checkTc (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 @@ -947,6 +960,19 @@ type families. tcFamTyPats type checks the patterns, zonks, and then calls thing_inside to generate a desugaring. It is used during type-checking (not kind-checking). +Note [Type-checking type patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking the patterns of a family instance declaration, we can't +rely on using the family TyCon, because this is sometimes called +from within a type-checking knot. (Specifically for closed type families.) +The type FamTyConShape gives just enough information to do the job. + +The "arity" field of FamTyConShape is the *visible* arity of the family +type constructor, i.e. what the users sees and writes, not including kind +arguments. + +See also Note [tc_fam_ty_pats vs tcFamTyPats] + Note [Failing early in kcDataDefn] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We need to use checkNoErrs when calling kcConDecl. This is because kcConDecl @@ -961,15 +987,18 @@ two bad things could happen: \begin{code} ----------------- --- Note that we can't use the family TyCon, because this is sometimes called --- from within a type-checking knot. So, we ask our callers to do a little more --- work. --- See Note [tc_fam_ty_pats vs tcFamTyPats] -tc_fam_ty_pats :: Name -- of the family TyCon - -> Kind -- of the family TyCon +type FamTyConShape = (Name, Arity, Kind) -- See Note [Type-checking type patterns] + +famTyConShape :: TyCon -> FamTyConShape +famTyConShape fam_tc + = ( tyConName fam_tc + , length (filterOut isKindVar (tyConTyVars fam_tc)) + , tyConKind fam_tc ) + +tc_fam_ty_pats :: FamTyConShape -> HsWithBndrs [LHsType Name] -- Patterns - -> (TcKind -> TcM ()) -- Kind checker for RHS - -- result is ignored + -> (TcKind -> TcM ()) -- Kind checker for RHS + -- result is ignored -> TcM ([Kind], [Type], Kind) -- Check the type patterns of a type or data family instance -- type instance F <pat1> <pat2> = <type> @@ -982,7 +1011,7 @@ tc_fam_ty_pats :: Name -- of the family TyCon -- In that case, the type variable 'a' will *already be in scope* -- (and, if C is poly-kinded, so will its kind parameter). -tc_fam_ty_pats fam_tc_name kind +tc_fam_ty_pats (name, arity, kind) (HsWB { hswb_cts = arg_pats, hswb_kvs = kvars, hswb_tvs = tvars }) kind_checker = do { let (fam_kvs, fam_body) = splitForAllTys kind @@ -994,9 +1023,8 @@ tc_fam_ty_pats fam_tc_name kind -- Note that we don't have enough information at hand to do a full check, -- as that requires the full declared arity of the family, which isn't -- nearby. - ; let max_args = length (fst $ splitKindFunTys fam_body) - ; checkTc (length arg_pats <= max_args) $ - wrongNumberOfParmsErrTooMany max_args + ; checkTc (length arg_pats == arity) $ + wrongNumberOfParmsErr arity -- Instantiate with meta kind vars ; fam_arg_kinds <- mapM (const newMetaKindVar) fam_kvs @@ -1011,22 +1039,21 @@ tc_fam_ty_pats fam_tc_name kind -- See Note [Quantifying over family patterns] ; typats <- tcHsTyVarBndrs hs_tvs $ \ _ -> do { kind_checker res_kind - ; tcHsArgTys (quotes (ppr fam_tc_name)) arg_pats arg_kinds } + ; tcHsArgTys (quotes (ppr name)) arg_pats arg_kinds } ; return (fam_arg_kinds, typats, res_kind) } -- See Note [tc_fam_ty_pats vs tcFamTyPats] -tcFamTyPats :: Name -- of the family ToCon - -> Kind -- of the family TyCon +tcFamTyPats :: FamTyConShape -> HsWithBndrs [LHsType Name] -- patterns -> (TcKind -> TcM ()) -- kind-checker for RHS -> ([TKVar] -- Kind and type variables -> [TcType] -- Kind and type arguments -> Kind -> TcM a) -> TcM a -tcFamTyPats fam_tc_name kind pats kind_checker thing_inside +tcFamTyPats fam_shape@(name,_,_) pats kind_checker thing_inside = do { (fam_arg_kinds, typats, res_kind) - <- tc_fam_ty_pats fam_tc_name kind pats kind_checker + <- tc_fam_ty_pats fam_shape pats kind_checker ; let all_args = fam_arg_kinds ++ typats -- Find free variables (after zonking) and turn @@ -1040,7 +1067,7 @@ tcFamTyPats fam_tc_name kind pats kind_checker thing_inside ; all_args' <- zonkTcTypeToTypes ze all_args ; res_kind' <- zonkTcTypeToType ze res_kind - ; traceTc "tcFamTyPats" (ppr fam_tc_name) + ; traceTc "tcFamTyPats" (ppr name) -- don't print out too much, as we might be in the knot ; tcExtendTyVarEnv qtkvs' $ thing_inside qtkvs' all_args' res_kind' } @@ -1101,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 @@ -1119,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 ----------------------------------- @@ -1466,8 +1493,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 @@ -1484,16 +1511,19 @@ checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM () checkValidDataCon dflags existential_ok tc con = setSrcSpan (srcLocSpan (getSrcLoc con)) $ addErrCtxt (dataConCtxt con) $ - do { traceTc "checkValidDataCon" (ppr con $$ ppr tc) - - -- Check that the return type of the data constructor + do { -- Check that the return type of the data constructor -- matches the type constructor; eg reject this: -- data T a where { MkT :: Bogus a } -- c.f. Note [Check role annotations in a second pass] -- and Note [Checking GADT return types] - ; let tc_tvs = tyConTyVars tc + let tc_tvs = tyConTyVars tc res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs) orig_res_ty = dataConOrigResTy con + ; traceTc "checkValidDataCon" (vcat + [ ppr con, ppr tc, ppr tc_tvs + , ppr res_ty_tmpl <+> dcolon <+> ppr (typeKind res_ty_tmpl) + , ppr orig_res_ty <+> dcolon <+> ppr (typeKind orig_res_ty)]) + ; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs) res_ty_tmpl orig_res_ty)) @@ -1581,10 +1611,12 @@ 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 @@ -1621,7 +1653,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 @@ -1643,11 +1675,10 @@ checkValidClass cls -- in the context of a for-all must mention at least one quantified -- type variable. What a mess! - check_at_defs (fam_tc, defs) - = 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 @@ -1672,9 +1703,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 @@ -1798,7 +1829,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 ] @@ -1838,8 +1869,7 @@ mkRecSelBind (tycon, sel_name) = (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 @@ -2005,13 +2035,6 @@ gotten by appying the eq_spec to the univ_tvs of the data con. %************************************************************************ \begin{code} -tcAddDefaultAssocDeclCtxt :: Name -> TcM a -> TcM a -tcAddDefaultAssocDeclCtxt name thing_inside - = addErrCtxt ctxt thing_inside - where - ctxt = hsep [ptext (sLit "In the type synonym instance default declaration for"), - quotes (ppr name)] - tcAddTyFamInstCtxt :: TyFamInstDecl Name -> TcM a -> TcM a tcAddTyFamInstCtxt decl = tcAddFamInstCtxt (ptext (sLit "type instance")) (tyFamInstDeclName decl) @@ -2054,26 +2077,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 @@ -2152,20 +2175,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 @@ -2206,12 +2229,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 ed9a5b7661..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 diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 08c7a627ce..a952ce702e 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 @@ -478,7 +480,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 +736,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 +963,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 diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 1447448973..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 diff --git a/compiler/typecheck/TcValidity.lhs b/compiler/typecheck/TcValidity.lhs index 84453eb700..b5e6d64522 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." @@ -1160,26 +1164,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..2f499b704b 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, sinc each +NthCo node makes a seaprate 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 wan. + \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..fcf7cb443f 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, @@ -167,12 +166,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 +199,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 diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 826537db17..be1cdb1e44 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, overwriteInstEnv, extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv', lookupInstEnv, instEnvElts, classInstances, orphNamesOfClsInst, instanceBindFun, instanceCantMatch, roughMatchTcs @@ -164,15 +167,13 @@ 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) @@ -536,7 +537,7 @@ lookupInstEnv' ie cls tys -- Does not match, so next check whether the things unify -- See Note [Overlapping instances] and Note [Incoherent Instances] - | Incoherent _ <- oflag + | Incoherent <- overlapMode oflag = find ms us rest | otherwise @@ -635,11 +636,10 @@ insert_overlapping new_item (item:items) new_beats_old = new_item `beats` item old_beats_new = item `beats` new_item - incoherent (inst, _) = case is_flag inst of Incoherent _ -> True - _ -> False + incoherent (inst, _) = overlapMode (is_flag inst) == Incoherent (instA, _) `beats` (instB, _) - = overlap_ok && + = 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) @@ -648,9 +648,10 @@ insert_overlapping new_item (item:items) -- 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 + overlap_ok = case (overlapMode (is_flag instA), + overlapMode (is_flag instB)) of + (NoOverlap, NoOverlap) -> False + _ -> True \end{code} Note [Incoherent instances] diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs index 793aa4a761..e4dc783124 100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.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 @@ -62,6 +63,7 @@ import PrelNames import Outputable import Maybes( orElse ) import Util +import FastString \end{code} %************************************************************************ @@ -96,14 +98,19 @@ 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) @@ -127,7 +134,8 @@ splitKindFunTysN n k = pprPanic "splitKindFunTysN" (ppr n <+> ppr k) -- 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, 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..c39f9d1729 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, @@ -1187,11 +1187,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 +1205,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 +1272,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 +1372,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..f44e260c57 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 @@ -470,19 +472,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, @@ -620,6 +655,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..82d1497ee6 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,26 @@ 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 OverlapOk = putByte bh 1 + put_ bh Incoherent = putByte bh 2 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 OverlapOk + 2 -> return Incoherent + _ -> 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..d22380ff6e 100644 --- a/compiler/utils/Digraph.lhs +++ b/compiler/utils/Digraph.lhs @@ -3,22 +3,22 @@ % \begin{code} -{-# 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 -- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces -- for details -{-# LANGUAGE 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, @@ -258,14 +258,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 +307,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 +546,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 +569,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 +594,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} ------------------------------------------------------------ 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..0396c02749 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 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/Outputable.lhs b/compiler/utils/Outputable.lhs index 85d3d03557..e32261de65 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, @@ -73,7 +74,7 @@ module Outputable ( import {-# SOURCE #-} DynFlags( DynFlags, targetPlatform, pprUserLength, pprCols, - useUnicodeQuotes, + useUnicode, useUnicodeSyntax, unsafeGlobalDynFlags ) import {-# SOURCE #-} Module( Module, ModuleName, moduleName ) import {-# SOURCE #-} OccName( OccName ) @@ -458,7 +459,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 @@ -468,13 +469,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 @@ -489,6 +496,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 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..583174b201 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, 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 a13a17c412..d8e08f599a 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 @@ -60,9 +60,10 @@ module UniqFM ( eltsUFM, keysUFM, splitUFM, ufmToSet_Directly, ufmToList, - joinUFM + joinUFM, pprUniqFM ) where +import FastString import Unique ( Uniquable(..), Unique, getKey ) import Outputable @@ -319,5 +320,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..2dcc73fd89 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,6 +126,7 @@ import Data.Ord ( comparing ) import Data.Bits import Data.Word import qualified Data.IntMap as IM +import qualified Data.Set as Set import Data.Time #if __GLASGOW_HASKELL__ < 705 @@ -489,6 +491,9 @@ sortWith get_key xs = sortBy (comparing get_key) xs minWith :: Ord b => (a -> b) -> [a] -> a minWith get_key xs = ASSERT( not (null xs) ) head (sortWith get_key xs) + +nubSort :: Ord a => [a] -> [a] +nubSort = Set.toAscList . Set.fromList \end{code} %************************************************************************ diff --git a/compiler/vectorise/Vectorise.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/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 |