diff options
79 files changed, 2376 insertions, 1493 deletions
diff --git a/aclocal.m4 b/aclocal.m4 index 8318452913..9b8ad5ecc2 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -211,6 +211,9 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS], freebsd) test -z "[$]2" || eval "[$]2=OSFreeBSD" ;; + dragonfly) + test -z "[$]2" || eval "[$]2=OSDragonFly" + ;; kfreebsdgnu) test -z "[$]2" || eval "[$]2=OSKFreeBSD" ;; @@ -526,7 +529,8 @@ AC_DEFUN([FP_EVAL_STDERR], # XXX # # $1 = the variable to set -# $2 = the command to look for +# $2 = the with option name +# $3 = the command to look for # AC_DEFUN([FP_ARG_WITH_PATH_GNU_PROG], [ @@ -544,10 +548,14 @@ AC_ARG_WITH($2, [ if test "$HostOS" != "mingw32" then - AC_PATH_PROG([$1], [$2]) + if test "$target_alias" = "" ; then + AC_PATH_PROG([$1], [$3]) + else + AC_PATH_PROG([$1], [$target_alias-$3]) + fi if test -z "$$1" then - AC_MSG_ERROR([cannot find $2 in your PATH, no idea how to link]) + AC_MSG_ERROR([cannot find $3 in your PATH]) fi fi ] @@ -635,7 +643,7 @@ AC_CHECK_TYPE([$1], [], [], [$3])[]dnl m4_pushdef([fp_Cache], [AS_TR_SH([fp_cv_alignment_$1])])[]dnl AC_CACHE_CHECK([alignment of $1], [fp_Cache], [if test "$AS_TR_SH([ac_cv_type_$1])" = yes; then - FP_COMPUTE_INT([(long) (&((struct { char c; $1 ty; } *)0)->ty)], + FP_COMPUTE_INT([offsetof(struct { char c; $1 ty; },ty)], [fp_Cache], [AC_INCLUDES_DEFAULT([$3])], [AC_MSG_ERROR([cannot compute alignment ($1) @@ -1575,6 +1583,7 @@ AC_SUBST([ProjectPatchLevel]) # timer_create() in certain versions of Linux (see bug #1933). # AC_DEFUN([FP_CHECK_TIMER_CREATE], +if test "$cross_compiling" = "no" ; then [AC_CACHE_CHECK([for a working timer_create(CLOCK_REALTIME)], [fptools_cv_timer_create_works], [AC_TRY_RUN([ @@ -1698,6 +1707,7 @@ case $fptools_cv_timer_create_works in yes) AC_DEFINE([USE_TIMER_CREATE], 1, [Define to 1 if we can use timer_create(CLOCK_PROCESS_CPUTIME_ID,...)]);; esac +fi ]) # FP_ICONV @@ -1925,7 +1935,9 @@ case "$1" in freebsd|netbsd|openbsd|dragonfly|osf1|osf3|hpux|linuxaout|kfreebsdgnu|freebsd2|solaris2|cygwin32|mingw32|darwin|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku) $2="$1" ;; - freebsd8) # like i686-gentoo-freebsd8 + freebsd*) # like i686-gentoo-freebsd7 + # i686-gentoo-freebsd8 + # i686-gentoo-freebsd8.2 $2="freebsd" ;; *) @@ -1996,6 +2008,10 @@ AC_DEFUN([XCODE_VERSION],[ # FIND_GCC() # -------------------------------- # Finds where gcc is +# +# $1 = the variable to set +# $2 = the with option name +# $3 = the command to look for AC_DEFUN([FIND_GCC],[ if test "$TargetOS_CPP" = "darwin" && test "$XCodeVersion1" -eq 4 && @@ -2004,13 +2020,14 @@ AC_DEFUN([FIND_GCC],[ # In Xcode 4.1, 'gcc-4.2' is the gcc legacy backend (rather # than the LLVM backend). We prefer the legacy gcc, but in # Xcode 4.2 'gcc-4.2' was removed. - FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc-4.2]) + FP_ARG_WITH_PATH_GNU_PROG([$1], [gcc-4.2], [gcc-4.2]) + elif test "$windows" = YES + then + $1="$CC" else - FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc]) + FP_ARG_WITH_PATH_GNU_PROG([$1], [$2], [$3]) fi - export CC - WhatGccIsCalled="$CC" - AC_SUBST(WhatGccIsCalled) + AC_SUBST($1) ]) # LocalWords: fi diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index c2cf0bfcdd..e08bc67241 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -42,12 +42,18 @@ module DataCon ( -- * Splitting product types splitProductType_maybe, splitProductType, deepSplitProductType, - deepSplitProductType_maybe + deepSplitProductType_maybe, + + -- ** Promotion related functions + promoteType, isPromotableType, isPromotableTyCon, + buildPromotedTyCon, buildPromotedDataCon, ) where #include "HsVersions.h" import Type +import TypeRep( Type(..) ) -- Used in promoteType +import Kind import Unify import Coercion import TyCon @@ -61,6 +67,7 @@ import Util import BasicTypes import FastString import Module +import VarEnv import qualified Data.Data as Data import qualified Data.Typeable @@ -959,4 +966,86 @@ computeRep stricts tys where (_tycon, _tycon_args, arg_dc, arg_tys) = deepSplitProductType "unbox_strict_arg_ty" ty -\end{code}
\ No newline at end of file +\end{code} + + +%************************************************************************ +%* * + Promoting of data types to the kind level +%* * +%************************************************************************ + +These two 'buildPromoted..' functions are here because + * They belong together + * 'buildPromotedTyCon' is used by promoteType + * 'buildPromotedTyCon' depends on DataCon stuff + +\begin{code} +buildPromotedTyCon :: TyCon -> TyCon +buildPromotedTyCon tc + = mkPromotedTyCon tc tySuperKind + +buildPromotedDataCon :: DataCon -> TyCon +buildPromotedDataCon dc + = ASSERT ( isPromotableType ty ) + mkPromotedDataTyCon dc (getName dc) (getUnique dc) kind arity + where + ty = dataConUserType dc + kind = promoteType ty + arity = dataConSourceArity dc +\end{code} + +Note [Promoting a Type to a Kind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppsoe we have a data constructor D + D :: forall (a:*). Maybe a -> T a +We promote this to be a type constructor 'D: + 'D :: forall (k:BOX). 'Maybe k -> 'T k + +The transformation from type to kind is done by promoteType + + * Convert forall (a:*) to forall (k:BOX), and substitute + + * Ensure all foralls are at the top (no higher rank stuff) + + * Ensure that all type constructors mentioned (Maybe and T + in the example) are promotable; that is, they have kind + * -> ... -> * -> * + +\begin{code} +isPromotableType :: Type -> Bool +isPromotableType ty + = all (isLiftedTypeKind . tyVarKind) tvs + && go rho + where + (tvs, rho) = splitForAllTys ty + go (TyConApp tc tys) | Just n <- isPromotableTyCon tc + = tys `lengthIs` n && all go tys + go (FunTy arg res) = go arg && go res + go (TyVarTy tvar) = tvar `elem` tvs + go _ = False + +-- If tc's kind is [ *^n -> * ] returns [ Just n ], else returns [ Nothing ] +isPromotableTyCon :: TyCon -> Maybe Int +isPromotableTyCon tc + | all isLiftedTypeKind (res:args) = Just $ length args + | otherwise = Nothing + where + (args, res) = splitKindFunTys (tyConKind tc) + +-- | Promotes a type to a kind. +-- Assumes the argument satisfies 'isPromotableType' +promoteType :: Type -> Kind +promoteType ty + = mkForAllTys kvs (go rho) + where + (tvs, rho) = splitForAllTys ty + kvs = [ mkKindVar (tyVarName tv) tySuperKind | tv <- tvs ] + env = zipVarEnv tvs kvs + + go (TyConApp tc tys) = mkTyConApp (buildPromotedTyCon tc) (map go tys) + go (FunTy arg res) = mkArrowKind (go arg) (go res) + go (TyVarTy tv) | Just kv <- lookupVarEnv env tv + = TyVarTy kv + go _ = panic "promoteType" -- Argument did not satisfy isPromotableType +\end{code} diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 6f6e58b25b..f62d519bbb 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -664,31 +664,33 @@ lintInTy ty ; lintKind k ; return ty' } -lintInCo :: InCoercion -> LintM OutCoercion --- Check the coercion, and apply the substitution to it --- See Note [Linting type lets] -lintInCo co - = addLoc (InCo co) $ - do { co' <- applySubstCo co - ; _ <- lintCoercion co' - ; return co' } - ------------------- lintKind :: OutKind -> LintM () -- Check well-formedness of kinds: *, *->*, Either * (* -> *), etc +lintKind (TyVarTy kv) + = do { checkTyCoVarInScope kv + ; unless (isSuperKind (varType kv)) + (addErrL (hang (ptext (sLit "Badly kinded kind variable")) + 2 (ppr kv <+> dcolon <+> ppr (varType kv)))) } + lintKind (FunTy k1 k2) - = lintKind k1 >> lintKind k2 + = do { lintKind k1; lintKind k2 } lintKind kind@(TyConApp tc kis) - = do { unless (isSuperKindTyCon tc || tyConArity tc == length kis) - (addErrL malformed_kind) - ; mapM_ lintKind kis } - where - malformed_kind = hang (ptext (sLit "Malformed kind:")) 2 (quotes (ppr kind)) + | not (isSuperKind (tyConKind tc)) + = addErrL (hang (ptext (sLit "Type constructor") <+> quotes (ppr tc)) + 2 (ptext (sLit "cannot be used in a kind"))) + + | not (tyConArity tc == length kis) + = addErrL (hang (ptext (sLit "Unsaturated ype constructor in kind")) + 2 (quotes (ppr kind))) + + | otherwise + = mapM_ lintKind kis -lintKind (TyVarTy kv) = checkTyCoVarInScope kv lintKind kind - = addErrL (hang (ptext (sLit "Malformed kind:")) 2 (quotes (ppr kind))) + = addErrL (hang (ptext (sLit "Malformed kind:")) + 2 (quotes (ppr kind))) ------------------- lintTyBndrKind :: OutTyVar -> LintM () @@ -699,16 +701,128 @@ lintTyBndrKind tv = then return () -- kind forall else lintKind ki -- type forall +---------- +checkTcApp :: OutCoercion -> Int -> Type -> LintM OutType +checkTcApp co n ty + | Just tys <- tyConAppArgs_maybe ty + , n < length tys + = return (tys !! n) + | otherwise + = failWithL (hang (ptext (sLit "Bad getNth:") <+> ppr co) + 2 (ptext (sLit "Offending type:") <+> ppr ty)) + ------------------- +lintType :: OutType -> LintM Kind +-- The returned Kind has itself been linted +lintType (TyVarTy tv) + = do { checkTyCoVarInScope tv + ; let kind = tyVarKind tv + ; lintKind kind + ; WARN( isSuperKind kind, msg ) + return kind } + where msg = hang (ptext (sLit "Expecting a type, but got a kind")) + 2 (ptext (sLit "Offending kind:") <+> ppr tv) + +lintType ty@(AppTy t1 t2) + = do { k1 <- lintType t1 + ; lint_ty_app ty k1 [t2] } + +lintType ty@(FunTy t1 t2) + = lint_ty_app ty (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind) [t1,t2] + +lintType ty@(TyConApp tc tys) + | tyConHasKind tc -- Guards for SuperKindOon + , not (isUnLiftedTyCon tc) || tys `lengthIs` tyConArity tc + -- Check that primitive types are saturated + -- See Note [The kind invariant] in TypeRep + = lint_ty_app ty (tyConKind tc) tys + | otherwise + = failWithL (hang (ptext (sLit "Malformed type:")) 2 (ppr ty)) + +lintType (ForAllTy tv ty) + = do { lintTyBndrKind tv + ; addInScopeVar tv (lintType ty) } + +lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty) + +---------------- +lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind +lint_ty_app ty k tys + = lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys + +---------------- +lint_co_app :: Coercion -> Kind -> [OutType] -> LintM () +lint_co_app ty k tys + = do { _ <- lint_kind_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys + ; return () } + +---------------- +lintTyLit :: TyLit -> LintM () +lintTyLit (NumTyLit n) + | n >= 0 = return () + | otherwise = failWithL msg + where msg = ptext (sLit "Negative type literal:") <+> integer n +lintTyLit (StrTyLit _) = return () + +---------------- +lint_kind_app :: SDoc -> Kind -> [OutType] -> LintM Kind +-- (lint_kind_app d fun_kind arg_tys) +-- We have an application (f arg_ty1 .. arg_tyn), +-- where f :: fun_kind +-- Takes care of linting the OutTypes +lint_kind_app doc kfn tys = go kfn tys + where + fail_msg = vcat [ hang (ptext (sLit "Kind application error in")) 2 doc + , nest 2 (ptext (sLit "Function kind =") <+> ppr kfn) + , nest 2 (ptext (sLit "Arg types =") <+> ppr tys) ] + + go kfn [] = return kfn + go kfn (ty:tys) = + case splitKindFunTy_maybe kfn of + { Nothing -> + case splitForAllTy_maybe kfn of + { Nothing -> failWithL fail_msg + ; Just (kv, body) -> do + -- Something of kind (forall kv. body) gets instantiated + -- with ty. 'kv' is a kind variable and 'ty' is a kind. + { unless (isSuperKind (tyVarKind kv)) (addErrL fail_msg) + ; lintKind ty + ; go (substKiWith [kv] [ty] body) tys } } + ; Just (kfa, kfb) -> do + -- Something of kind (kfa -> kfb) is applied to ty. 'ty' is + -- a type accepting kind 'kfa'. + { k <- lintType ty + ; lintKind kfa + ; unless (k `isSubKind` kfa) (addErrL fail_msg) + ; go kfb tys } } + +\end{code} + +%************************************************************************ +%* * + Linting coercions +%* * +%************************************************************************ + +\begin{code} +lintInCo :: InCoercion -> LintM OutCoercion +-- Check the coercion, and apply the substitution to it +-- See Note [Linting type lets] +lintInCo co + = addLoc (InCo co) $ + do { co' <- applySubstCo co + ; _ <- lintCoercion co' + ; return co' } + lintKindCoercion :: OutCoercion -> LintM OutKind -- Kind coercions are only reflexivity because they mean kind -- instantiation. See Note [Kind coercions] in Coercion +lintKindCoercion (Refl k) + = do { lintKind k + ; return k } lintKindCoercion co - = do { (k1,k2) <- lintCoercion co - ; checkL (k1 `eqKind` k2) - (hang (ptext (sLit "Non-refl kind coercion")) - 2 (ppr co)) - ; return k1 } + = failWithL (hang (ptext (sLit "Non-refl kind coercion")) + 2 (ppr co)) lintCoercion :: OutCoercion -> LintM (OutType, OutType) -- Check the kind of a coercion term, returning the kind @@ -732,14 +846,14 @@ lintCoercion co@(TyConAppCo tc cos) -- kis are the kind instantiations of tc ; kis <- mapM lintKindCoercion cokis ; (ss,ts) <- mapAndUnzipM lintCoercion cotys - ; check_co_app co ki (kis ++ ss) + ; lint_co_app co ki (kis ++ ss) ; return (mkTyConApp tc (kis ++ ss), mkTyConApp tc (kis ++ ts)) } lintCoercion co@(AppCo co1 co2) = do { (s1,t1) <- lintCoercion co1 ; (s2,t2) <- lintCoercion co2 - ; check_co_app co (typeKind s1) [s2] + ; lint_co_app co (typeKind s1) [s2] ; return (mkAppTy s1 s2, mkAppTy t1 t2) } lintCoercion (ForAllCo v co) @@ -808,97 +922,6 @@ lintCoercion (InstCo co arg_ty) | otherwise -> failWithL (ptext (sLit "Kind mis-match in inst coercion")) Nothing -> failWithL (ptext (sLit "Bad argument of inst")) } - ----------- -checkTcApp :: OutCoercion -> Int -> Type -> LintM OutType -checkTcApp co n ty - | Just tys <- tyConAppArgs_maybe ty - , n < length tys - = return (tys !! n) - | otherwise - = failWithL (hang (ptext (sLit "Bad getNth:") <+> ppr co) - 2 (ptext (sLit "Offending type:") <+> ppr ty)) - -------------------- -lintType :: OutType -> LintM Kind -lintType (TyVarTy tv) - = do { checkTyCoVarInScope tv - ; let kind = tyVarKind tv - ; lintKind kind - ; WARN( isSuperKind kind, msg ) - return kind } - where msg = hang (ptext (sLit "Expecting a type, but got a kind")) - 2 (ptext (sLit "Offending kind:") <+> ppr tv) - -lintType ty@(AppTy t1 t2) - = do { k1 <- lintType t1 - ; lint_ty_app ty k1 [t2] } - -lintType ty@(FunTy t1 t2) - = lint_ty_app ty (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind) [t1,t2] - -lintType ty@(TyConApp tc tys) - | tyConHasKind tc -- Guards for SuperKindOon - , not (isUnLiftedTyCon tc) || tys `lengthIs` tyConArity tc - -- Check that primitive types are saturated - -- See Note [The kind invariant] in TypeRep - = lint_ty_app ty (tyConKind tc) tys - | otherwise - = failWithL (hang (ptext (sLit "Malformed type:")) 2 (ppr ty)) - -lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty) - -lintType (ForAllTy tv ty) - = do { lintTyBndrKind tv - ; addInScopeVar tv (lintType ty) } - ---- - -lintTyLit :: TyLit -> LintM () -lintTyLit (NumTyLit n) - | n >= 0 = return () - | otherwise = failWithL msg - where msg = ptext (sLit "Negative type literal:") <+> integer n -lintTyLit (StrTyLit _) = return () - - ----------------- -lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind -lint_ty_app ty k tys = lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys - ----------------- -check_co_app :: Coercion -> Kind -> [OutType] -> LintM () -check_co_app ty k tys = lint_kind_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys >> return () - ----------------- -lint_kind_app :: SDoc -> Kind -> [OutType] -> LintM Kind --- Takes care of linting the OutTypes -lint_kind_app doc kfn tys = go kfn tys - where - fail_msg = vcat [ hang (ptext (sLit "Kind application error in")) 2 doc - , nest 2 (ptext (sLit "Function kind =") <+> ppr kfn) - , nest 2 (ptext (sLit "Arg types =") <+> ppr tys) ] - - go kfn [] = return kfn - go kfn (ty:tys) = - case splitKindFunTy_maybe kfn of - { Nothing -> - case splitForAllTy_maybe kfn of - { Nothing -> failWithL fail_msg - ; Just (kv, body) -> do - -- Something of kind (forall kv. body) gets instantiated - -- with ty. 'kv' is a kind variable and 'ty' is a kind. - { unless (isSuperKind (tyVarKind kv)) (addErrL fail_msg) - ; lintKind ty - ; go (substKiWith [kv] [ty] body) tys } } - ; Just (kfa, kfb) -> do - -- Something of kind (kfa -> kfb) is applied to ty. 'ty' is - -- a type accepting kind 'kfa'. - { k <- lintType ty - ; lintKind kfa - ; unless (k `isSubKind` kfa) (addErrL fail_msg) - ; go kfb tys } } - \end{code} %************************************************************************ diff --git a/compiler/deSugar/DsExpr.lhs-boot b/compiler/deSugar/DsExpr.lhs-boot index 2a6d09b48e..03a47ed41b 100644 --- a/compiler/deSugar/DsExpr.lhs-boot +++ b/compiler/deSugar/DsExpr.lhs-boot @@ -1,16 +1,9 @@ \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://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module DsExpr where -import HsSyn ( HsExpr, LHsExpr, HsLocalBinds ) -import Var ( Id ) -import DsMonad ( DsM ) -import CoreSyn ( CoreExpr ) +import HsSyn ( HsExpr, LHsExpr, HsLocalBinds ) +import Var ( Id ) +import DsMonad ( DsM ) +import CoreSyn ( CoreExpr ) dsExpr :: HsExpr Id -> DsM CoreExpr dsLExpr :: LHsExpr Id -> DsM CoreExpr diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 103f70f9e7..4105a9e56c 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -129,10 +129,12 @@ repTopDs group decls <- addBinds ss (do { val_ds <- rep_val_binds (hs_valds group) ; tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ; - inst_ds <- mapM repInstD' (hs_instds group) ; + inst_ds <- mapM repInstD (hs_instds group) ; for_ds <- mapM repForD (hs_fords group) ; -- more needed - return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ; + return (de_loc $ sort_by_loc $ + val_ds ++ catMaybes tycl_ds + ++ catMaybes inst_ds ++ for_ds) }) ; decl_ty <- lookupType decQTyConName ; let { core_list = coreList' decl_ty decls } ; @@ -307,8 +309,12 @@ repLAssocFamInst = liftM de_loc . mapMaybeM repTyClD -- represent instance declarations -- -repInstD' :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ) -repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now +repInstD :: LInstDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ)) +repInstD (L loc (FamInstDecl fi_decl)) + = repTyClD (L loc fi_decl) + + +repInstD (L loc (ClsInstDecl ty binds _ ats)) -- Ignore user pragmas for now = do { dec <- addTyVarBinds tvs $ \_ -> -- We must bring the type variables into scope, so their -- occurrences don't fail, even though the binders don't @@ -327,7 +333,7 @@ repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now ; ats1 <- repLAssocFamInst ats ; decls <- coreList decQTyConName (ats1 ++ binds1) ; repInst cxt1 inst_ty1 decls } - ; return (loc, dec) } + ; return (Just (loc, dec)) } where Just (tvs, cxt, cls, tys) = splitHsInstDeclTy_maybe (unLoc ty) diff --git a/compiler/deSugar/Match.lhs-boot b/compiler/deSugar/Match.lhs-boot index 31ee36b6e6..d10cda961e 100644 --- a/compiler/deSugar/Match.lhs-boot +++ b/compiler/deSugar/Match.lhs-boot @@ -1,42 +1,35 @@ \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://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module Match where -import Var ( Id ) -import TcType ( Type ) -import DsMonad ( DsM, EquationInfo, MatchResult ) -import CoreSyn ( CoreExpr ) -import HsSyn ( LPat, HsMatchContext, MatchGroup ) -import Name ( Name ) +import Var ( Id ) +import TcType ( Type ) +import DsMonad ( DsM, EquationInfo, MatchResult ) +import CoreSyn ( CoreExpr ) +import HsSyn ( LPat, HsMatchContext, MatchGroup ) +import Name ( Name ) -match :: [Id] +match :: [Id] -> Type - -> [EquationInfo] - -> DsM MatchResult + -> [EquationInfo] + -> DsM MatchResult matchWrapper - :: HsMatchContext Name + :: HsMatchContext Name -> MatchGroup Id - -> DsM ([Id], CoreExpr) + -> DsM ([Id], CoreExpr) matchSimply - :: CoreExpr - -> HsMatchContext Name - -> LPat Id - -> CoreExpr - -> CoreExpr - -> DsM CoreExpr + :: CoreExpr + -> HsMatchContext Name + -> LPat Id + -> CoreExpr + -> CoreExpr + -> DsM CoreExpr matchSinglePat - :: CoreExpr - -> HsMatchContext Name - -> LPat Id + :: CoreExpr + -> HsMatchContext Name + -> LPat Id -> Type - -> MatchResult - -> DsM MatchResult + -> MatchResult + -> DsM MatchResult \end{code} diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 51ae1542e3..3bb2f5cfc4 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -62,7 +62,7 @@ Library Build-Depends: base < 3 if flag(stage1) && impl(ghc < 7.5) - Build-Depends: old-time >= 1 && < 1.1 + Build-Depends: old-time >= 1 && < 1.2 if flag(base3) || flag(base4) Build-Depends: directory >= 1 && < 1.2, @@ -70,9 +70,9 @@ Library bytestring >= 0.9 && < 0.10, time < 1.5, containers >= 0.1 && < 0.5, - array >= 0.1 && < 0.4 + array >= 0.1 && < 0.5 - Build-Depends: filepath >= 1 && < 1.3 + Build-Depends: filepath >= 1 && < 1.4 Build-Depends: Cabal, hpc if os(windows) Build-Depends: Win32 diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 8790df361e..e305b36a8e 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -150,6 +150,10 @@ $(eval $(call clean-target,compiler,config_hs,compiler/main/Config.hs)) PLATFORM_H = ghc_boot_platform.h +ifeq "$(BuildingCrossCompiler)" "YES" +compiler/stage1/$(PLATFORM_H) : compiler/stage2/$(PLATFORM_H) + cp $< $@ +else compiler/stage1/$(PLATFORM_H) : mk/config.mk mk/project.mk | $$(dir $$@)/. $(call removeFiles,$@) @echo "Creating $@..." @@ -192,6 +196,7 @@ endif @echo >> $@ @echo "#endif /* __PLATFORM_H__ */" >> $@ @echo "Done." +endif # For stage2 and above, the BUILD platform is the HOST of stage1, and # the HOST platform is the TARGET of stage1. The TARGET remains the same @@ -489,13 +494,6 @@ $(eval $(call compiler-hs-dependency,PrimOp,$(PRIMOP_BITS))) compiler/prelude/PrimOp_HC_OPTS += -fforce-recomp compiler/main/Constants_HC_OPTS += -fforce-recomp -# Workaround for #4003 in GHC 6.12.2. It didn't happen in 6.12.1, and -# will be fixed in 6.12.3. Unfortunately we don't have a way to do -# this for just stage1 in the build system. -ifeq "$(GhcVersion)" "6.12.2" -compiler/hsSyn/HsLit_HC_OPTS += -fomit-interface-pragmas -endif - # LibFFI.hs #includes ffi.h compiler/stage2/build/LibFFI.hs : $(libffi_HEADERS) # On Windows it seems we also need to link directly to libffi diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 4292a112ff..5318c5be49 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -195,7 +195,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 (InstDecl inst_ty' binds' sigs' ats') } + ; returnL $ InstD (ClsInstDecl inst_ty' binds' sigs' ats') } cvtDec (ForeignD ford) = do { ford' <- cvtForD ford @@ -213,23 +213,25 @@ cvtDec (DataInstD ctxt tc tys constrs derivs) = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys ; cons' <- mapM cvtConstr constrs ; derivs' <- cvtDerivs derivs - ; returnL $ TyClD (TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt' - , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing - , tcdCons = cons', tcdDerivs = derivs' }) } + ; returnL $ InstD $ FamInstDecl $ + TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt' + , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing + , tcdCons = cons', tcdDerivs = derivs' } } cvtDec (NewtypeInstD ctxt tc tys constr derivs) = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys ; con' <- cvtConstr constr ; derivs' <- cvtDerivs derivs - ; returnL $ TyClD (TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt' - , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing - , tcdCons = [con'], tcdDerivs = derivs' }) - } + ; returnL $ InstD $ FamInstDecl $ + TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt' + , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing + , tcdCons = [con'], tcdDerivs = derivs' } } cvtDec (TySynInstD tc tys rhs) = do { (_, tc', tvs', tys') <- cvt_tyinst_hdr [] tc tys ; rhs' <- cvtType rhs - ; returnL $ TyClD (TySynonym tc' tvs' tys' rhs') } + ; returnL $ InstD $ FamInstDecl $ + TySynonym tc' tvs' tys' rhs' } ---------------- cvt_ci_decs :: MsgDoc -> [TH.Dec] diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index f8e6bc0e9d..e6d369c519 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -18,9 +18,11 @@ module HsDecls ( isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl, isFamInstDecl, tcdName, tyClDeclTyVars, countTyClDecls, + -- ** Instance declarations InstDecl(..), LInstDecl, NewOrData(..), FamilyFlavour(..), - instDeclATs, + FamInstDecl, LFamInstDecl, instDeclFamInsts, + -- ** Standalone deriving declarations DerivDecl(..), LDerivDecl, -- ** @RULE@ declarations @@ -128,12 +130,15 @@ data HsGroup id = HsGroup { hs_valds :: HsValBinds id, - hs_tyclds :: [[LTyClDecl id]], + hs_tyclds :: [[LTyClDecl id]], -- A list of mutually-recursive groups + -- No family-instances here; they are in hs_instds -- Parser generates a singleton list; -- renamer does dependency analysis - hs_instds :: [LInstDecl id], + hs_instds :: [LInstDecl id], + -- Both class and family instance declarations in here + hs_derivds :: [LDerivDecl id], hs_fixds :: [LFixitySig id], @@ -154,7 +159,8 @@ emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn } emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut } -emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [], +emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], + hs_derivds = [], hs_fixds = [], hs_defds = [], hs_annds = [], hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [], hs_valds = error "emptyGroup hs_valds: Can't happen", @@ -430,8 +436,9 @@ Interface file code: -- In both cases, 'tcdVars' collects all variables we need to quantify over. type LTyClDecl name = Located (TyClDecl name) -type TyClGroup name = [LTyClDecl name] -- this is used in TcTyClsDecls to represent +type TyClGroup name = [LTyClDecl name] -- This is used in TcTyClsDecls to represent -- strongly connected components of decls + -- No familiy instances in here -- | A type or class declaration. data TyClDecl name @@ -504,7 +511,7 @@ data TyClDecl name tcdMeths :: LHsBinds name, -- ^ Default methods tcdATs :: [LTyClDecl name], -- ^ Associated types; ie -- only 'TyFamily' - tcdATDefs :: [LTyClDecl name], -- ^ Associated type defaults; ie + tcdATDefs :: [LFamInstDecl name], -- ^ Associated type defaults; ie -- only 'TySynonym' tcdDocs :: [LDocDecl] -- ^ Haddock docs } @@ -602,15 +609,14 @@ tyClDeclTyVars (ForeignType {}) = [] \end{code} \begin{code} -countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int, Int) - -- class, synonym decls, data, newtype, family decls, family instances +countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int) + -- class, synonym decls, data, newtype, family decls countTyClDecls decls = (count isClassDecl decls, count isSynDecl decls, -- excluding... count isDataTy decls, -- ...family... count isNewTy decls, -- ...instances - count isFamilyDecl decls, - count isFamInstDecl decls) + count isFamilyDecl decls) where isDataTy TyData{tcdND = DataType, tcdTyPats = Nothing} = True isDataTy _ = False @@ -833,18 +839,25 @@ pprConDecl (ConDecl {con_name = con, con_details = InfixCon {}, con_res = ResTyG \begin{code} type LInstDecl name = Located (InstDecl name) -data InstDecl name - = InstDecl (LHsType name) -- Context => Class Instance-type - -- Using a polytype means that the renamer conveniently - -- figures out the quantified type variables for us. - (LHsBinds name) - [LSig name] -- User-supplied pragmatic info - [LTyClDecl name]-- Associated types (ie, 'TyData' and - -- 'TySynonym' only) +type LFamInstDecl name = Located (FamInstDecl name) +type FamInstDecl name = TyClDecl name -- Type or data family instance + +data InstDecl name -- Both class and family instances + = ClsInstDecl + (LHsType name) -- Context => Class Instance-type + -- Using a polytype means that the renamer conveniently + -- figures out the quantified type variables for us. + (LHsBinds name) + [LSig name] -- User-supplied pragmatic info + [LFamInstDecl name] -- Family instances for associated types + + | FamInstDecl -- type/data family instance + (FamInstDecl name) + deriving (Data, Typeable) instance (OutputableBndr name) => Outputable (InstDecl name) where - ppr (InstDecl inst_ty binds sigs ats) + ppr (ClsInstDecl inst_ty binds sigs ats) | null sigs && null ats && isEmptyBag binds -- No "where" part = top_matter @@ -855,10 +868,16 @@ instance (OutputableBndr name) => Outputable (InstDecl name) where where top_matter = ptext (sLit "instance") <+> ppr inst_ty + ppr (FamInstDecl decl) = ppr decl + -- Extract the declarations of associated types from an instance --- -instDeclATs :: [LInstDecl name] -> [LTyClDecl name] -instDeclATs inst_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats] + +instDeclFamInsts :: [LInstDecl name] -> [LTyClDecl name] +instDeclFamInsts inst_decls + = concatMap do_one inst_decls + where + do_one (L _ (ClsInstDecl _ _ _ fam_insts)) = fam_insts + do_one (L loc (FamInstDecl fam_inst)) = [L loc fam_inst] \end{code} %************************************************************************ diff --git a/compiler/hsSyn/HsExpr.lhs-boot b/compiler/hsSyn/HsExpr.lhs-boot index 6666243264..86032f5829 100644 --- a/compiler/hsSyn/HsExpr.lhs-boot +++ b/compiler/hsSyn/HsExpr.lhs-boot @@ -1,15 +1,8 @@ \begin{code} {-# LANGUAGE KindSignatures #-} -{-# 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://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module HsExpr where -import SrcLoc ( Located ) +import SrcLoc ( Located ) import Outputable ( SDoc, OutputableBndr ) import {-# SOURCE #-} HsPat ( LPat ) @@ -34,17 +27,17 @@ type LHsExpr a = Located (HsExpr a) type SyntaxExpr a = HsExpr a pprLExpr :: (OutputableBndr i) => - LHsExpr i -> SDoc + LHsExpr i -> SDoc pprExpr :: (OutputableBndr i) => - HsExpr i -> SDoc + HsExpr i -> SDoc pprSplice :: (OutputableBndr i) => - HsSplice i -> SDoc + HsSplice i -> SDoc pprPatBind :: (OutputableBndr b, OutputableBndr i) => - LPat b -> GRHSs i -> SDoc + LPat b -> GRHSs i -> SDoc pprFunBind :: (OutputableBndr idL, OutputableBndr idR) => - idL -> Bool -> MatchGroup idR -> SDoc + idL -> Bool -> MatchGroup idR -> SDoc \end{code} diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 3527d9139e..293f5b05a6 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -68,7 +68,7 @@ module HsUtils( collectLStmtBinders, collectStmtBinders, collectSigTysFromPats, collectSigTysFromPat, - hsTyClDeclBinders, hsTyClDeclsBinders, + hsLTyClDeclBinders, hsTyClDeclBinders, hsTyClDeclsBinders, hsForeignDeclsBinders, hsGroupBinders, -- Collecting implicit binders @@ -619,29 +619,33 @@ hsForeignDeclsBinders foreign_decls = [n | L _ (ForeignImport (L _ n) _ _ _) <- foreign_decls] hsTyClDeclsBinders :: [[LTyClDecl Name]] -> [Located (InstDecl Name)] -> [Name] +-- We need to look at instance declarations too, +-- because their associated types may bind data constructors hsTyClDeclsBinders tycl_decls inst_decls - = [n | d <- instDeclATs inst_decls ++ concat tycl_decls - , L _ n <- hsTyClDeclBinders d] + = [n | d <- instDeclFamInsts inst_decls ++ concat tycl_decls + , L _ n <- hsLTyClDeclBinders d] -hsTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name] +hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name] -- ^ Returns all the /binding/ names of the decl, along with their SrcLocs. -- The first one is guaranteed to be the name of the decl. For record fields -- mentioned in multiple constructors, the SrcLoc will be from the first -- occurence. We use the equality to filter out duplicate field names +hsLTyClDeclBinders (L _ d) = hsTyClDeclBinders d -hsTyClDeclBinders (L _ (TyFamily {tcdLName = name})) = [name] -hsTyClDeclBinders (L _ (ForeignType {tcdLName = name})) = [name] +hsTyClDeclBinders :: Eq name => TyClDecl name -> [Located name] +hsTyClDeclBinders (TyFamily {tcdLName = name}) = [name] +hsTyClDeclBinders (ForeignType {tcdLName = name}) = [name] -hsTyClDeclBinders (L _ (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats})) +hsTyClDeclBinders (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats}) = cls_name : - concatMap hsTyClDeclBinders ats ++ [n | L _ (TypeSig ns _) <- sigs, n <- ns] + concatMap hsLTyClDeclBinders ats ++ [n | L _ (TypeSig ns _) <- sigs, n <- ns] -hsTyClDeclBinders (L _ (TySynonym {tcdLName = name, tcdTyPats = mb_pats })) +hsTyClDeclBinders (TySynonym {tcdLName = name, tcdTyPats = mb_pats }) | isJust mb_pats = [] | otherwise = [name] -- See Note [Binders in family instances] -hsTyClDeclBinders (L _ (TyData {tcdLName = tc_name, tcdCons = cons, tcdTyPats = mb_pats })) +hsTyClDeclBinders (TyData {tcdLName = tc_name, tcdCons = cons, tcdTyPats = mb_pats }) | isJust mb_pats = hsConDeclsBinders cons | otherwise = tc_name : hsConDeclsBinders cons -- See Note [Binders in family instances] diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 1ffabb4f73..75b8d91881 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -15,7 +15,6 @@ module BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, - buildPromotedDataTyCon, TcMethInfo, buildClass, distinctAbstractTyConRhs, totallyAbstractTyConRhs, mkNewTyConRhs, mkDataTyConRhs, @@ -35,13 +34,11 @@ import MkId import Class import TyCon import Type -import Kind ( promoteType, isPromotableType ) import Coercion import TcRnMonad import Util ( isSingleton ) import Outputable -import Unique ( getUnique ) \end{code} @@ -184,11 +181,6 @@ mkDataConStupidTheta tycon arg_tys univ_tvs arg_tyvars = tyVarsOfTypes arg_tys in_arg_tys pred = not $ isEmptyVarSet $ tyVarsOfType pred `intersectVarSet` arg_tyvars - -buildPromotedDataTyCon :: DataCon -> TyCon -buildPromotedDataTyCon dc = ASSERT ( isPromotableType ty ) - mkPromotedDataTyCon dc (getName dc) (getUnique dc) (promoteType ty) - where ty = dataConUserType dc \end{code} diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs index b15b6f261d..32df9e3217 100644 --- a/compiler/llvmGen/Llvm.hs +++ b/compiler/llvmGen/Llvm.hs @@ -20,6 +20,9 @@ module Llvm ( LlvmBlocks, LlvmBlock(..), LlvmBlockId, LlvmParamAttr(..), LlvmParameter, + -- * Fence synchronization + LlvmSyncOrdering(..), + -- * Call Handling LlvmCallConvention(..), LlvmCallType(..), LlvmParameterListType(..), LlvmLinkageType(..), LlvmFuncAttr(..), diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs index a28734b152..9133447331 100644 --- a/compiler/llvmGen/Llvm/AbsSyn.hs +++ b/compiler/llvmGen/Llvm/AbsSyn.hs @@ -62,8 +62,24 @@ data LlvmFunction = LlvmFunction { funcBody :: LlvmBlocks } -type LlvmFunctions = [LlvmFunction] - +type LlvmFunctions = [LlvmFunction] + +-- | LLVM ordering types for synchronization purposes. (Introduced in LLVM +-- 3.0). Please see the LLVM documentation for a better description. +data LlvmSyncOrdering + -- | Some partial order of operations exists. + = SyncUnord + -- | A single total order for operations at a single address exists. + | SyncMonotonic + -- | Acquire synchronization operation. + | SyncAcquire + -- | Release synchronization operation. + | SyncRelease + -- | Acquire + Release synchronization operation. + | SyncAcqRel + -- | Full sequential Consistency operation. + | SyncSeqCst + deriving (Show, Eq) -- | Llvm Statements data LlvmStatement @@ -75,6 +91,11 @@ data LlvmStatement = Assignment LlvmVar LlvmExpression {- | + Memory fence operation + -} + | Fence Bool LlvmSyncOrdering + + {- | Always branch to the target label -} | Branch LlvmVar diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs index 2945777f96..c2177782f2 100644 --- a/compiler/llvmGen/Llvm/PpLlvm.hs +++ b/compiler/llvmGen/Llvm/PpLlvm.hs @@ -211,6 +211,7 @@ ppLlvmStatement stmt = let ind = (text " " <>) in case stmt of Assignment dst expr -> ind $ ppAssignment dst (ppLlvmExpression expr) + Fence st ord -> ind $ ppFence st ord Branch target -> ind $ ppBranch target BranchIf cond ifT ifF -> ind $ ppBranchIf cond ifT ifF Comment comments -> ind $ ppLlvmComments comments @@ -301,6 +302,19 @@ ppCmpOp op left right = ppAssignment :: LlvmVar -> Doc -> Doc ppAssignment var expr = (text $ getName var) <+> equals <+> expr +ppFence :: Bool -> LlvmSyncOrdering -> Doc +ppFence st ord = + let singleThread = case st of True -> text "singlethread" + False -> empty + in text "fence" <+> singleThread <+> ppSyncOrdering ord + +ppSyncOrdering :: LlvmSyncOrdering -> Doc +ppSyncOrdering SyncUnord = text "unordered" +ppSyncOrdering SyncMonotonic = text "monotonic" +ppSyncOrdering SyncAcquire = text "acquire" +ppSyncOrdering SyncRelease = text "release" +ppSyncOrdering SyncAcqRel = text "acq_rel" +ppSyncOrdering SyncSeqCst = text "seq_cst" ppLoad :: LlvmVar -> Doc ppLoad var = text "load" <+> texts var diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index d5037828c7..059328f868 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -137,16 +137,15 @@ stmtToInstrs env stmt = case stmt of -> return (env, unitOL $ Return Nothing, []) --- | Foreign Calls -genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual] - -> CmmReturnInfo -> UniqSM StmtData - --- Write barrier needs to be handled specially as it is implemented as an LLVM --- intrinsic function. -genCall env (CmmPrim MO_WriteBarrier) _ _ _ - | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC] - = return (env, nilOL, []) - | otherwise = do +-- | Memory barrier instruction for LLVM >= 3.0 +barrier :: LlvmEnv -> UniqSM StmtData +barrier env = do + let s = Fence False SyncSeqCst + return (env, unitOL s, []) + +-- | Memory barrier instruction for LLVM < 3.0 +oldBarrier :: LlvmEnv -> UniqSM StmtData +oldBarrier env = do let fname = fsLit "llvm.memory.barrier" let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid FixedArgs (tysToParams [i1, i1, i1, i1, i1]) llvmFunAlign @@ -167,6 +166,18 @@ genCall env (CmmPrim MO_WriteBarrier) _ _ _ lmTrue :: LlvmVar lmTrue = mkIntLit i1 (-1) +-- | Foreign Calls +genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual] + -> CmmReturnInfo -> UniqSM StmtData + +-- Write barrier needs to be handled specially as it is implemented as an LLVM +-- intrinsic function. +genCall env (CmmPrim MO_WriteBarrier) _ _ _ + | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC] + = return (env, nilOL, []) + | getLlvmVer env > 29 = barrier env + | otherwise = oldBarrier env + -- Handle popcnt function specifically since GHC only really has i32 and i64 -- types and things like Word8 are backed by an i32 and just present a logical -- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index ac4df37ac8..747b0b8f71 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -1717,9 +1717,9 @@ package_flags = [ , Flag "ignore-package" (HasArg ignorePackage) , Flag "syslib" (HasArg (\s -> do exposePackage s deprecate "Use -package instead")) + , Flag "distrust-all-packages" (NoArg (setDynFlag Opt_DistrustAllPackages)) , Flag "trust" (HasArg trustPackage) , Flag "distrust" (HasArg distrustPackage) - , Flag "distrust-all-packages" (NoArg (setDynFlag Opt_DistrustAllPackages)) ] type TurnOnFlag = Bool -- True <=> we are turning the flag on diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index fc53d9d544..1fe9077046 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -84,6 +84,8 @@ import DsMeta ( templateHaskellNames ) import VarSet import VarEnv ( emptyTidyEnv ) import Panic + +import GHC.Exts #endif import Id @@ -1351,72 +1353,58 @@ myCoreToStg dflags this_mod prepd_binds = do %********************************************************************* -} {- -When the UnlinkedBCOExpr is linked you get an HValue of type - IO [HValue] -When you run it you get a list of HValues that should be -the same length as the list of names; add them to the ClosureEnv. - -A naked expression returns a singleton Name [it]. - - What you type The IO [HValue] that hscStmt returns - ------------- ------------------------------------ - let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] - - pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] - - expr (of IO type) ==> expr >>= \ v -> return [v] - [NB: result not printed] bindings: [it] - +When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When +you run it you get a list of HValues that should be the same length as the list +of names; add them to the ClosureEnv. - expr (of non-IO type, - result showable) ==> let v = expr in print v >> return [v] - bindings: [it] - - expr (of non-IO type, - result not showable) ==> error +A naked expression returns a singleton Name [it]. The stmt is lifted into the +IO monad as explained in Note [Interactively-bound Ids in GHCi] in TcRnDriver -} #ifdef GHCI -- | Compile a stmt all the way to an HValue, but don't run it -hscStmt :: HscEnv - -> String -- ^ The statement - -> IO (Maybe ([Id], HValue)) -- ^ 'Nothing' <==> empty statement - -- (or comment only), but no parse error +-- +-- We return Nothing to indicate an empty statement (or comment only), not a +-- parse error. +hscStmt :: HscEnv -> String -> IO (Maybe ([Id], IO [HValue])) hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1 -- | Compile a stmt all the way to an HValue, but don't run it +-- +-- We return Nothing to indicate an empty statement (or comment only), not a +-- parse error. hscStmtWithLocation :: HscEnv -> String -- ^ The statement -> String -- ^ The source -> Int -- ^ Starting line - -> IO (Maybe ([Id], HValue)) -- ^ 'Nothing' <==> empty statement - -- (or comment only), but no parse error + -> IO (Maybe ([Id], IO [HValue])) hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do maybe_stmt <- hscParseStmtWithLocation source linenumber stmt case maybe_stmt of Nothing -> return Nothing - -- The real stuff Just parsed_stmt -> do - -- Rename and typecheck it - let icontext = hsc_IC hsc_env - (ids, tc_expr) <- ioMsgMaybe $ - tcRnStmt hsc_env icontext parsed_stmt + let icntxt = hsc_IC hsc_env + rdr_env = ic_rn_gbl_env icntxt + type_env = mkTypeEnvWithImplicits (ic_tythings icntxt) + src_span = srcLocSpan interactiveSrcLoc + + -- Rename and typecheck it + -- Here we lift the stmt into the IO monad, see Note + -- [Interactively-bound Ids in GHCi] in TcRnDriver + (ids, tc_expr) <- ioMsgMaybe $ tcRnStmt hsc_env icntxt parsed_stmt + -- Desugar it - let rdr_env = ic_rn_gbl_env icontext - type_env = mkTypeEnvWithImplicits (ic_tythings icontext) ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr handleWarnings -- Then code-gen, and link it - let src_span = srcLocSpan interactiveSrcLoc hsc_env <- getHscEnv hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr + let hval_io = unsafeCoerce# hval :: IO [HValue] - return $ Just (ids, hval) + return $ Just (ids, hval_io) -- | Compile a decls hscDecls :: HscEnv @@ -1442,8 +1430,8 @@ hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do -- We grab the whole environment because of the overlapping that may have -- been done. See the notes at the definition of InteractiveContext -- (ic_instances) for more details. - let finsts = famInstEnvElts $ tcg_fam_inst_env tc_gblenv - insts = instEnvElts $ tcg_inst_env tc_gblenv + let finsts = tcg_fam_insts tc_gblenv + insts = tcg_insts tc_gblenv {- Desugar it -} -- We use a basically null location for iNTERACTIVE @@ -1560,7 +1548,7 @@ hscParseThingWithLocation source linenumber parser str liftIO $ showPass dflags "Parser" let buf = stringToStringBuffer str - loc = mkRealSrcLoc (fsLit source) linenumber 1 + loc = mkRealSrcLoc (fsLit source) linenumber 1 case unP parser (mkPState dflags buf loc) of PFailed span err -> do diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs index f89903f75c..168e49af4a 100644 --- a/compiler/main/HscStats.lhs +++ b/compiler/main/HscStats.lhs @@ -52,7 +52,6 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) ("DataDecls ", data_ds), ("NewTypeDecls ", newt_ds), ("TypeFamilyDecls ", type_fam_ds), - ("FamilyInstDecls ", fam_inst_ds), ("DataConstrs ", data_constrs), ("DataDerivings ", data_derivs), ("ClassDecls ", class_ds), @@ -89,7 +88,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) -- in class decls. ToDo tycl_decls = [d | TyClD d <- decls] - (class_ds, type_ds, data_ds, newt_ds, type_fam_ds, fam_inst_ds) = + (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) = countTyClDecls tycl_decls inst_decls = [d | InstD d <- decls] @@ -153,7 +152,9 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl))))) class_info _ = (0,0) - inst_info (InstDecl _ inst_meths inst_sigs ats) + inst_info (FamInstDecl d) = case countATDecl d of + (tyd, dtd) -> (0,0,0,tyd,dtd) + inst_info (ClsInstDecl _ inst_meths inst_sigs ats) = case count_sigs (map unLoc inst_sigs) of (_,_,ss,is,_) -> case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of @@ -162,9 +163,9 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) (map (count_bind.unLoc) (bagToList inst_meths))), ss, is, tyDecl, dtDecl) where - countATDecl (TyData {}) = (0, 1) - countATDecl (TySynonym {}) = (1, 0) - countATDecl d = pprPanic "countATDecl: Unhandled decl" + countATDecl (TyData {}) = (0, 1) + countATDecl (TySynonym {}) = (1, 0) + countATDecl d = pprPanic "countATDecl: Unhandled decl" (ppr d) addpr :: (Int,Int) -> Int diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 3224acf0fe..9840b407ce 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -931,7 +931,8 @@ data InteractiveContext ic_tythings :: [TyThing], -- ^ TyThings defined by the user, in reverse order of - -- definition. + -- definition. At a breakpoint, this list includes the + -- local variables in scope at that point ic_sys_vars :: [Id], -- ^ Variables defined automatically by the system (e.g. @@ -1386,8 +1387,9 @@ lookupType dflags hpt pte name lookupNameEnv (md_types (hm_details hm)) name | otherwise = lookupNameEnv pte name - where mod = ASSERT( isExternalName name ) nameModule name - this_pkg = thisPackage dflags + where + mod = ASSERT2( isExternalName name, ppr name ) nameModule name + this_pkg = thisPackage dflags -- | As 'lookupType', but with a marginally easier-to-use interface -- if you have a 'HscEnv' diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index eee5c00255..cdc2ca501a 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -198,17 +198,18 @@ runStmtWithLocation source linenumber expr step = let dflags' = wopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds hsc_env' = hsc_env{ hsc_dflags = dflags' } + -- compile to value (IO [HValue]), don't run r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber case r of - Nothing -> return (RunOk []) -- empty statement / comment + -- empty statement / comment + Nothing -> return (RunOk []) Just (tyThings, hval) -> do status <- withVirtualCWD $ withBreakAction (isStep step) dflags' breakMVar statusMVar $ do - let thing_to_run = unsafeCoerce# hval :: IO [HValue] - liftIO $ sandboxIO dflags' statusMVar thing_to_run + liftIO $ sandboxIO dflags' statusMVar hval let ic = hsc_IC hsc_env bindings = (ic_tythings ic, ic_rn_gbl_env ic) @@ -942,20 +943,18 @@ typeKind normalise str = withSession $ \hsc_env -> do liftIO $ hscKcType hsc_env normalise str ----------------------------------------------------------------------------- --- cmCompileExpr: compile an expression and deliver an HValue +-- Compile an expression, run it and deliver the resulting HValue compileExpr :: GhcMonad m => String -> m HValue compileExpr expr = withSession $ \hsc_env -> do Just (ids, hval) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr) - -- Run it! - hvals <- liftIO (unsafeCoerce# hval :: IO [HValue]) - + hvals <- liftIO hval case (ids,hvals) of ([_],[hv]) -> return hv - _ -> panic "compileExpr" + _ -> panic "compileExpr" -- ----------------------------------------------------------------------------- --- Compile an expression into a dynamic +-- Compile an expression, run it and return the result as a dynamic dynCompileExpr :: GhcMonad m => String -> m Dynamic dynCompileExpr expr = do @@ -977,8 +976,8 @@ dynCompileExpr expr = do setContext iis vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic]) case (ids,vals) of - (_:[], v:[]) -> return v - _ -> panic "dynCompileExpr" + (_:[], v:[]) -> return v + _ -> panic "dynCompileExpr" ----------------------------------------------------------------------------- -- show a module and it's source/object filenames diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index d1fbe2f253..1d6ad4a472 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -272,7 +272,7 @@ setBatchPackageFlags dflags pkgs = (maybeDistrustAll . maybeHideAll) pkgs | otherwise = pkgs' hide pkg = pkg{ exposed = False } - distrust pkg = pkg{ exposed = False } + distrust pkg = pkg{ trusted = False } -- TODO: This code is duplicated in utils/ghc-pkg/Main.hs mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot index 0e639a3caf..7de92cb659 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot @@ -1,14 +1,7 @@ -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module SPARC.CodeGen.Gen32 ( - getSomeReg, - getRegister + getSomeReg, + getRegister ) where diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index c0f5041774..61eb5748a3 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -571,10 +571,7 @@ topdecls :: { OrdList (LHsDecl RdrName) } topdecl :: { OrdList (LHsDecl RdrName) } : cl_decl { unitOL (L1 (TyClD (unLoc $1))) } | ty_decl { unitOL (L1 (TyClD (unLoc $1))) } - | 'instance' inst_type where_inst - { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3) - in - unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats)))} + | inst_decl { unitOL (L1 (InstD (unLoc $1))) } | stand_alone_deriving { unitOL (LL (DerivD (unLoc $1))) } | 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) } | 'foreign' fdecl { unitOL (LL (unLoc $2)) } @@ -633,12 +630,6 @@ ty_decl :: { LTyClDecl RdrName } -- infix type constructors to be declared {% mkTyFamily (comb3 $1 $3 $4) TypeFamily $3 (unLoc $4) } - -- type instance declarations - | 'type' 'instance' type '=' ctype - -- Note the use of type for the head; this allows - -- infix type constructors and type patterns - {% mkTySynonym (comb2 $1 $5) True $3 $5 } - -- ordinary data type or newtype declaration | data_or_newtype tycl_hdr constrs deriving {% mkTyData (comb4 $1 $2 $3 $4) (unLoc $1) False $2 @@ -659,18 +650,32 @@ ty_decl :: { LTyClDecl RdrName } | 'data' 'family' type opt_kind_sig {% mkTyFamily (comb3 $1 $2 $4) DataFamily $3 (unLoc $4) } +inst_decl :: { LInstDecl RdrName } + : 'instance' inst_type where_inst + { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3) + in L (comb3 $1 $2 $3) (ClsInstDecl $2 binds sigs ats) } + + -- type instance declarations + | 'type' 'instance' type '=' ctype + -- Note the use of type for the head; this allows + -- infix type constructors and type patterns + {% do { L loc d <- mkTySynonym (comb2 $1 $5) True $3 $5 + ; return (L loc (FamInstDecl d)) } } + -- data/newtype instance declaration | data_or_newtype 'instance' tycl_hdr constrs deriving - {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $3 - Nothing (reverse (unLoc $4)) (unLoc $5) } + {% do { L loc d <- mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $3 + Nothing (reverse (unLoc $4)) (unLoc $5) + ; return (L loc (FamInstDecl d)) } } -- GADT instance declaration | data_or_newtype 'instance' tycl_hdr opt_kind_sig gadt_constrlist deriving - {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $3 - (unLoc $4) (unLoc $5) (unLoc $6) } - + {% do { L loc d <- mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $3 + (unLoc $4) (unLoc $5) (unLoc $6) + ; return (L loc (FamInstDecl d)) } } + -- Associated type family declarations -- -- * They have a different syntax than on the toplevel (no family special @@ -1071,8 +1076,8 @@ atype :: { LHsType RdrName } | SIMPLEQUOTE '(' ctype ',' comma_types1 ')' { LL $ HsExplicitTupleTy [] ($3 : $5) } | SIMPLEQUOTE '[' comma_types0 ']' { LL $ HsExplicitListTy placeHolderKind $3 } | '[' ctype ',' comma_types1 ']' { LL $ HsExplicitListTy placeHolderKind ($2 : $4) } - | INTEGER { LL $ HsTyLit $ HsNumberTy $ getINTEGER $1 } - | STRING { LL $ HsTyLit $ HsStringTy $ getSTRING $1 } + | INTEGER { LL $ HsTyLit $ HsNumTy $ getINTEGER $1 } + | STRING { LL $ HsTyLit $ HsStrTy $ getSTRING $1 } -- An inst_type is what occurs in the head of an instance decl -- e.g. (Foo a, Gaz b) => Wibble a b diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index ec760d7fae..162a7025c0 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -50,11 +50,12 @@ module TysWiredIn ( -- * List listTyCon, nilDataCon, consDataCon, listTyCon_RDR, consDataCon_RDR, listTyConName, - mkListTy, + mkListTy, mkPromotedListTy, -- * Tuples mkTupleTy, mkBoxedTupleTy, - tupleTyCon, tupleCon, + tupleTyCon, promotedTupleTyCon, + tupleCon, unitTyCon, unitDataCon, unitDataConId, pairTyCon, unboxedUnitTyCon, unboxedUnitDataCon, unboxedSingletonTyCon, unboxedSingletonDataCon, @@ -87,13 +88,14 @@ import TysPrim import Coercion import Constants ( mAX_TUPLE_SIZE ) import Module ( Module ) -import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity ) +import DataCon import Var import TyCon import TypeRep import RdrName import Name -import BasicTypes ( TupleSort(..), tupleSortBoxity, IPName(..), Arity, RecFlag(..), Boxity(..), HsBang(..) ) +import BasicTypes ( TupleSort(..), tupleSortBoxity, IPName(..), + Arity, RecFlag(..), Boxity(..), HsBang(..) ) import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique, mkPArrDataConUnique ) import Data.Array @@ -220,7 +222,6 @@ parrTyCon_RDR = nameRdrName parrTyConName eqTyCon_RDR = nameRdrName eqTyConName \end{code} - %************************************************************************ %* * \subsection{mkWiredInTyCon} @@ -322,6 +323,9 @@ tupleTyCon BoxedTuple i = fst (boxedTupleArr ! i) tupleTyCon UnboxedTuple i = fst (unboxedTupleArr ! i) tupleTyCon ConstraintTuple i = fst (factTupleArr ! i) +promotedTupleTyCon :: TupleSort -> Arity -> TyCon +promotedTupleTyCon sort i = buildPromotedTyCon (tupleTyCon sort i) + tupleCon :: TupleSort -> Arity -> DataCon tupleCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i) -- Build one specially tupleCon BoxedTuple i = snd (boxedTupleArr ! i) @@ -625,6 +629,12 @@ mkListTy ty = mkTyConApp listTyCon [ty] listTyCon :: TyCon listTyCon = pcRecDataTyCon listTyConName alpha_tyvar [nilDataCon, consDataCon] +mkPromotedListTy :: Type -> Type +mkPromotedListTy ty = mkTyConApp promotedListTyCon [ty] + +promotedListTyCon :: TyCon +promotedListTyCon = buildPromotedTyCon listTyCon + nilDataCon :: DataCon nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index bd424e87b8..ecd2cd3147 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -39,7 +39,7 @@ module RnEnv ( addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS, warnUnusedMatches, warnUnusedTopBinds, warnUnusedLocalBinds, - dataTcOccs, unknownNameErr, kindSigErr, polyKindsErr, perhapsForallMsg, + dataTcOccs, unknownNameErr, kindSigErr, dataKindsErr, perhapsForallMsg, HsDocContext(..), docOfHsDocContext ) where @@ -470,9 +470,9 @@ lookupPromotedOccRn rdr_name Nothing -> unboundName WL_Any rdr_name Just demoted_name | data_kinds -> return demoted_name - | otherwise -> unboundNameX WL_Any rdr_name suggest_pk }}} + | otherwise -> unboundNameX WL_Any rdr_name suggest_dk }}} where - suggest_pk = ptext (sLit "A data constructor of that name is in scope; did you mean -XDataKinds?") + suggest_dk = ptext (sLit "A data constructor of that name is in scope; did you mean -XDataKinds?") \end{code} Note [Demotion] @@ -507,7 +507,12 @@ lookupOccRn_maybe rdr_name { -- We allow qualified names on the command line to refer to -- *any* name exported by any module in scope, just as if there -- was an "import qualified M" declaration for every module. - allow_qual <- doptM Opt_ImplicitImportQualified + -- But we DONT allow it under Safe Haskell as we need to check + -- imports. We can and should instead check the qualified import + -- but at the moment this requires some refactoring so leave as a TODO + ; dflags <- getDynFlags + ; let allow_qual = dopt Opt_ImplicitImportQualified dflags && + not (safeDirectImpsReq dflags) ; is_ghci <- getIsGHCi -- This test is not expensive, -- and only happens for failed lookups @@ -1434,8 +1439,8 @@ kindSigErr thing = hang (ptext (sLit "Illegal kind signature for") <+> quotes (ppr thing)) 2 (ptext (sLit "Perhaps you intended to use -XKindSignatures")) -polyKindsErr :: Outputable a => a -> SDoc -polyKindsErr thing +dataKindsErr :: Outputable a => a -> SDoc +dataKindsErr thing = hang (ptext (sLit "Illegal kind:") <+> quotes (ppr thing)) 2 (ptext (sLit "Perhaps you intended to use -XDataKinds")) diff --git a/compiler/rename/RnExpr.lhs-boot b/compiler/rename/RnExpr.lhs-boot index 5ca81d6db4..70d891dcbf 100644 --- a/compiler/rename/RnExpr.lhs-boot +++ b/compiler/rename/RnExpr.lhs-boot @@ -1,24 +1,17 @@ \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://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module RnExpr where import HsSyn -import Name ( Name ) -import NameSet ( FreeVars ) -import RdrName ( RdrName ) +import Name ( Name ) +import NameSet ( FreeVars ) +import RdrName ( RdrName ) import TcRnTypes rnLExpr :: LHsExpr RdrName - -> RnM (LHsExpr Name, FreeVars) + -> RnM (LHsExpr Name, FreeVars) rnStmts :: --forall thing. - HsStmtContext Name -> [LStmt RdrName] + HsStmtContext Name -> [LStmt RdrName] -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([LStmt Name], thing), FreeVars) + -> RnM (([LStmt Name], thing), FreeVars) \end{code} diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 68e6d027e6..b1a61db2a2 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -486,12 +486,8 @@ getLocalNonValBinders fixity_env hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_fords = foreign_decls }) - = do { -- Separate out the family instance declarations - let (tyinst_decls, tycl_decls_noinsts) - = partition (isFamInstDecl . unLoc) (concat tycl_decls) - - -- Process all type/class decls *except* family instances - ; tc_avails <- mapM new_tc tycl_decls_noinsts + = do { -- Process all type/class decls *except* family instances + ; tc_avails <- mapM new_tc (concat tycl_decls) ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env ; setEnvs envs $ do { -- Bring these things into scope first @@ -499,7 +495,6 @@ getLocalNonValBinders fixity_env -- Process all family instances -- to bring new data constructors into scope - ; ti_avails <- mapM (new_ti Nothing) tyinst_decls ; nti_avails <- concatMapM new_assoc inst_decls -- Finish off with value binders: @@ -510,7 +505,7 @@ getLocalNonValBinders fixity_env | otherwise = for_hs_bndrs ; val_avails <- mapM new_simple val_bndrs - ; let avails = ti_avails ++ nti_avails ++ val_avails + ; let avails = nti_avails ++ val_avails new_bndrs = availsToNameSet avails `unionNameSets` availsToNameSet tc_avails ; envs <- extendGlobalRdrEnvRn avails fixity_env @@ -529,20 +524,25 @@ getLocalNonValBinders fixity_env ; return (Avail nm) } new_tc tc_decl -- NOT for type/data instances - = do { names@(main_name : _) <- mapM newTopSrcBinder (hsTyClDeclBinders tc_decl) + = do { let bndrs = hsTyClDeclBinders (unLoc tc_decl) + ; names@(main_name : _) <- mapM newTopSrcBinder bndrs ; return (AvailTC main_name names) } - new_ti :: Maybe Name -> LTyClDecl RdrName -> RnM AvailInfo + new_ti :: Maybe Name -> FamInstDecl RdrName -> RnM AvailInfo new_ti mb_cls ti_decl -- ONLY for type/data instances - = do { main_name <- lookupTcdName mb_cls (unLoc ti_decl) + = ASSERT( isFamInstDecl ti_decl ) + do { main_name <- lookupTcdName mb_cls ti_decl ; sub_names <- mapM newTopSrcBinder (hsTyClDeclBinders ti_decl) ; return (AvailTC (unLoc main_name) sub_names) } -- main_name is not bound here! new_assoc :: LInstDecl RdrName -> RnM [AvailInfo] - new_assoc (L _ (InstDecl inst_ty _ _ ats)) + new_assoc (L _ (FamInstDecl d)) + = do { avail <- new_ti Nothing d + ; return [avail] } + new_assoc (L _ (ClsInstDecl inst_ty _ _ ats)) = do { mb_cls_nm <- get_cls_parent inst_ty - ; mapM (new_ti mb_cls_nm) ats } + ; mapM (new_ti mb_cls_nm . unLoc) ats } where get_cls_parent inst_ty | Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty @@ -551,7 +551,8 @@ getLocalNonValBinders fixity_env = return Nothing lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name) --- Used for TyData and TySynonym only +-- Used for TyData and TySynonym only, +-- both ordinary ones and family instances -- See Note [Family instance binders] lookupTcdName mb_cls tc_decl | not (isFamInstDecl tc_decl) -- The normal case @@ -1511,7 +1512,10 @@ warnUnusedImport (L loc decl, used, unused) <+> ptext (sLit "import") <+> pp_mod <> parens empty ] msg2 = sep [pp_herald <+> quotes (pprWithCommas ppr unused), text "from module" <+> quotes pp_mod <+> pp_not_used] - pp_herald = text "The import of" + pp_herald = text "The" <+> pp_qual <+> text "import of" + pp_qual + | ideclQualified decl = text "qualified" + | otherwise = empty pp_mod = ppr (unLoc (ideclName decl)) pp_not_used = text "is redundant" \end{code} diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 175b9a7ba4..54f95016c7 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -424,7 +424,11 @@ patchCCallTarget packageId callTarget \begin{code} rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars) -rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) +rnSrcInstDecl (FamInstDecl ty_decl) + = do { (ty_decl', fvs) <- rnTyClDecl Nothing ty_decl + ; return (FamInstDecl ty_decl', fvs) } + +rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats) -- Used for both source and interface file decls = do { inst_ty' <- rnLHsInstType (text "In an instance declaration") inst_ty ; let Just (inst_tyvars, _, L _ cls,_) = splitLHsInstDeclTy_maybe inst_ty' @@ -460,7 +464,7 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) renameSigs (InstDeclCtxt cls) spec_inst_prags ; let uprags' = spec_inst_prags' ++ other_sigs' - ; return (InstDecl inst_ty' mbinds' uprags' ats', + ; return (ClsInstDecl inst_ty' mbinds' uprags' ats', meth_fvs `plusFV` more_fvs `plusFV` hsSigsFVs spec_inst_prags' `plusFV` extractHsTyNames inst_ty') } @@ -764,6 +768,7 @@ rnTyClDecls extra_deps tycl_ds all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs' + ; traceRn (text "rnTycl" <+> (ppr ds_w_fvs $$ ppr sccs)) ; return (map flattenSCC sccs, all_fvs) } @@ -995,12 +1000,16 @@ depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)] depAnalTyClDecls ds_w_fvs = stronglyConnCompFromEdgedVertices edges where - edges = [ (d, tcdName (unLoc d), map get_assoc (nameSetToList fvs)) + edges = [ (d, tcdName (unLoc d), map get_parent (nameSetToList fvs)) | (d, fvs) <- ds_w_fvs ] - get_assoc n = lookupNameEnv assoc_env n `orElse` n + + -- We also need to consider data constructor names since + -- they may appear in types because of promotion. + get_parent n = lookupNameEnv assoc_env n `orElse` n + + assoc_env :: NameEnv Name -- Maps a data constructor back + -- to its parent type constructor assoc_env = mkNameEnv assoc_env_list - -- We also need to consider data constructor names since they may - -- appear in types because of promotion. assoc_env_list = do (L _ d, _) <- ds_w_fvs case d of @@ -1210,7 +1219,7 @@ extendRecordFieldEnv tycl_decls inst_decls all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls , L _ con <- cons ] all_tycl_decls = at_tycl_decls ++ concat tycl_decls - at_tycl_decls = instDeclATs inst_decls -- Do not forget associated types! + at_tycl_decls = instDeclFamInsts inst_decls -- Do not forget associated types! get_con (ConDecl { con_name = con, con_details = RecCon flds }) (RecFields env fld_set) diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 7840c4ab3a..5275957ce0 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -197,7 +197,7 @@ rnHsTyKi isType doc (HsFunTy ty1 ty2) = do rnHsTyKi isType doc listTy@(HsListTy ty) = do data_kinds <- xoptM Opt_DataKinds - unless (data_kinds || isType) (addErr (polyKindsErr listTy)) + unless (data_kinds || isType) (addErr (dataKindsErr listTy)) ty' <- rnLHsTyKi isType doc ty return (HsListTy ty') @@ -217,7 +217,7 @@ rnHsTyKi isType doc (HsPArrTy ty) = ASSERT ( isType ) do -- sometimes crop up as a result of CPR worker-wrappering dictionaries. rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys) = do data_kinds <- xoptM Opt_DataKinds - unless (data_kinds || isType) (addErr (polyKindsErr tupleTy)) + unless (data_kinds || isType) (addErr (dataKindsErr tupleTy)) tys' <- mapM (rnLHsTyKi isType doc) tys return (HsTupleTy tup_con tys') @@ -225,7 +225,7 @@ rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys) = do -- 2. Check that the integer is positive? rnHsTyKi isType _ tyLit@(HsTyLit t) = do data_kinds <- xoptM Opt_DataKinds - unless (data_kinds || isType) (addErr (polyKindsErr tyLit)) + unless (data_kinds || isType) (addErr (dataKindsErr tyLit)) return (HsTyLit t) rnHsTyKi isType doc (HsAppTy ty1 ty2) = do diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index 98305e48a2..c873c631da 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -29,7 +29,7 @@ import Outputable import UniqFM import FastString import VarSet ( varSetElems ) - +import Util( filterOut ) import Maybes import Control.Monad import Data.Map (Map) @@ -237,35 +237,44 @@ with standalone deriving declrations. tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a tcExtendLocalFamInstEnv fam_insts thing_inside = do { env <- getGblEnv - ; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts - ; let env' = env { tcg_fam_insts = fam_insts ++ tcg_fam_insts env, - tcg_fam_inst_env = inst_env' } + ; (inst_env', fam_insts') <- foldlM addLocalFamInst + (tcg_fam_inst_env env, tcg_fam_insts env) + fam_insts + ; let env' = env { tcg_fam_insts = fam_insts' + , tcg_fam_inst_env = inst_env' } ; setGblEnv env' thing_inside } -- Check that the proposed new instance is OK, -- and then add it to the home inst env -addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv -addLocalFamInst home_fie famInst = do - -- Load imported instances, so that we report - -- overlaps correctly - eps <- getEps - let inst_envs = (eps_fam_inst_env eps, home_fie) - - -- Check for conflicting instance decls - skol_tvs <- tcInstSkolTyVars (varSetElems (famInstTyVars famInst)) - let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs - -- If there are any conflicts, we should probably error - -- But, if we're allowed to overwrite and the conflict is in the home FIE, - -- then overwrite instead of error. - traceTc "checkForConflicts" (ppr conflicts $$ ppr famInst $$ ppr inst_envs) - isGHCi <- getIsGHCi - case conflicts of - dup : _ -> case (isGHCi, home_conflicts) of - (True, _ : _) -> return (overwriteFamInstEnv home_fie famInst) - (_, _) -> conflictInstErr famInst (fst dup) >> return (extendFamInstEnv home_fie famInst) - where home_conflicts = lookupFamInstEnvConflicts' home_fie famInst skol_tvs - [] -> return (extendFamInstEnv home_fie famInst) +addLocalFamInst :: (FamInstEnv,[FamInst]) -> FamInst -> TcM (FamInstEnv, [FamInst]) +addLocalFamInst (home_fie, my_fis) fam_inst + -- home_fie includes home package and this module + -- my_fies is just the ones from this module + = do { isGHCi <- getIsGHCi + + -- In GHCi, we *override* any identical instances + -- that are also defined in the interactive context + ; let (home_fie', my_fis') + | isGHCi = (deleteFromFamInstEnv home_fie fam_inst, + filterOut (identicalFamInst fam_inst) my_fis) + | otherwise = (home_fie, my_fis) + + -- Load imported instances, so that we report + -- overlaps correctly + ; eps <- getEps + ; skol_tvs <- tcInstSkolTyVars (varSetElems (famInstTyVars fam_inst)) + ; let inst_envs = (eps_fam_inst_env eps, home_fie') + conflicts = lookupFamInstEnvConflicts inst_envs fam_inst skol_tvs + home_fie'' = extendFamInstEnv home_fie fam_inst + + -- Check for conflicting instance decls + ; traceTc "checkForConflicts" (ppr conflicts $$ ppr fam_inst $$ ppr inst_envs) + ; case conflicts of + [] -> return (home_fie'', fam_inst : my_fis') + dup : _ -> do { conflictInstErr fam_inst (fst dup) + ; return (home_fie, my_fis) } + } \end{code} %************************************************************************ diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 4db96c6e3c..7751ae49d2 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -459,7 +459,7 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls all_tydata :: [(LHsType Name, LTyClDecl Name)] -- Derived predicate paired with its data type declaration - all_tydata = extractTyDataPreds (instDeclATs inst_decls ++ tycl_decls) + all_tydata = extractTyDataPreds (instDeclFamInsts inst_decls ++ tycl_decls) deriv_locs = map (getLoc . snd) all_tydata ++ map getLoc deriv_decls diff --git a/compiler/typecheck/TcExpr.lhs-boot b/compiler/typecheck/TcExpr.lhs-boot index 7bd1e6c5c6..378a012f67 100644 --- a/compiler/typecheck/TcExpr.lhs-boot +++ b/compiler/typecheck/TcExpr.lhs-boot @@ -1,35 +1,28 @@ \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://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module TcExpr where -import HsSyn ( HsExpr, LHsExpr ) -import Name ( Name ) -import TcType ( TcType, TcRhoType, TcSigmaType ) +import HsSyn ( HsExpr, LHsExpr ) +import Name ( Name ) +import TcType ( TcType, TcRhoType, TcSigmaType ) import TcRnTypes( TcM, TcId, CtOrigin ) tcPolyExpr :: - LHsExpr Name + LHsExpr Name -> TcSigmaType -> TcM (LHsExpr TcId) tcMonoExpr, tcMonoExprNC :: - LHsExpr Name + LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId) tcInferRho, tcInferRhoNC :: - LHsExpr Name + LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType) tcSyntaxOp :: CtOrigin - -> HsExpr Name - -> TcType - -> TcM (HsExpr TcId) + -> HsExpr Name + -> TcType + -> TcM (HsExpr TcId) tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId) \end{code} diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 0df0a9b97c..7d6dfeb293 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -46,7 +46,7 @@ import {-# SOURCE #-} TcSplice( kcSpliceType ) import HsSyn import RnHsSyn import TcRnMonad -import RnEnv ( polyKindsErr ) +import RnEnv ( dataKindsErr ) import TcHsSyn ( mkZonkTcTyVar ) import TcEvidence( HsWrapper ) import TcEnv @@ -59,7 +59,7 @@ import Kind import Var import VarSet import TyCon -import DataCon ( DataCon, dataConUserType ) +import DataCon import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName ) import Class import RdrName ( rdrNameSpace, nameRdrName ) @@ -72,7 +72,6 @@ import DynFlags ( ExtensionFlag( Opt_DataKinds ) ) import Util import UniqSupply import Outputable -import BuildTyCl ( buildPromotedDataTyCon ) import FastString import Control.Monad ( unless ) \end{code} @@ -511,12 +510,13 @@ kc_hs_type (HsDocTy ty _) exp_kind kc_hs_type ty@(HsExplicitListTy _k tys) exp_kind = do { ty_k_s <- mapM kc_lhs_type_fresh tys ; kind <- unifyKinds (ptext (sLit "In a promoted list")) ty_k_s - ; checkExpectedKind ty (mkListTy kind) exp_kind + ; checkExpectedKind ty (mkPromotedListTy kind) exp_kind ; return (HsExplicitListTy kind (map fst ty_k_s)) } kc_hs_type ty@(HsExplicitTupleTy _ tys) exp_kind = do ty_k_s <- mapM kc_lhs_type_fresh tys - let tupleKi = mkTyConApp (tupleTyCon BoxedTuple (length tys)) (map snd ty_k_s) + let tycon = promotedTupleTyCon BoxedTuple (length tys) + tupleKi = mkTyConApp tycon (map snd ty_k_s) checkExpectedKind ty tupleKi exp_kind return (HsExplicitTupleTy (map snd ty_k_s) (map fst ty_k_s)) @@ -754,14 +754,14 @@ ds_type (HsExplicitListTy kind tys) = do kind' <- zonkTcKindToKind kind ds_tys <- mapM dsHsType tys return $ - foldr (\a b -> mkTyConApp (buildPromotedDataTyCon consDataCon) [kind', a, b]) - (mkTyConApp (buildPromotedDataTyCon nilDataCon) [kind']) ds_tys + foldr (\a b -> mkTyConApp (buildPromotedDataCon consDataCon) [kind', a, b]) + (mkTyConApp (buildPromotedDataCon nilDataCon) [kind']) ds_tys ds_type (HsExplicitTupleTy kis tys) = do MASSERT( length kis == length tys ) kis' <- mapM zonkTcKindToKind kis tys' <- mapM dsHsType tys - return $ mkTyConApp (buildPromotedDataTyCon (tupleCon BoxedTuple (length kis'))) (kis' ++ tys') + return $ mkTyConApp (buildPromotedDataCon (tupleCon BoxedTuple (length kis'))) (kis' ++ tys') ds_type (HsTyLit tl) = return $ case tl of HsNumTy n -> mkNumLitTy n @@ -820,7 +820,7 @@ ds_var_app name arg_tys = do { thing <- tcLookupGlobal name ; case thing of ATyCon tc -> return (mkTyConApp tc arg_tys) - ADataCon dc -> return (mkTyConApp (buildPromotedDataTyCon dc) arg_tys) + ADataCon dc -> return (mkTyConApp (buildPromotedDataCon dc) arg_tys) _ -> wrongThingErr "type" (AGlobal thing) name } addKcTypeCtxt :: LHsType Name -> TcM a -> TcM a @@ -1316,13 +1316,14 @@ sc_ds_hs_kind (HsFunTy ki1 ki2) = sc_ds_hs_kind (HsListTy ki) = do kappa <- sc_ds_lhs_kind ki checkWiredInTyCon listTyCon - return $ mkListTy kappa + return $ mkPromotedListTy kappa sc_ds_hs_kind (HsTupleTy _ kis) = do kappas <- mapM sc_ds_lhs_kind kis checkWiredInTyCon tycon return $ mkTyConApp tycon kappas - where tycon = tupleTyCon BoxedTuple (length kis) + where + tycon = promotedTupleTyCon BoxedTuple (length kis) -- Argument not kind-shaped sc_ds_hs_kind k = panic ("sc_ds_hs_kind: " ++ showPpr k) @@ -1339,15 +1340,16 @@ sc_ds_app ki _ = failWithTc (quotes (ppr ki) <+> -- IA0_TODO: With explicit kind polymorphism I might need to add ATyVar sc_ds_var_app :: Name -> [Kind] -> TcM Kind -- Special case for * and Constraint kinds +-- They are kinds already, so we don't need to promote them sc_ds_var_app name arg_kis - | name == liftedTypeKindTyConName - || name == constraintKindTyConName = do - unless (null arg_kis) - (failWithTc (text "Kind" <+> ppr name <+> text "cannot be applied")) - thing <- tcLookup name - case thing of - AGlobal (ATyCon tc) -> return (mkTyConApp tc []) - _ -> panic "sc_ds_var_app 1" + | name == liftedTypeKindTyConName + || name == constraintKindTyConName + = do { unless (null arg_kis) + (failWithTc (text "Kind" <+> ppr name <+> text "cannot be applied")) + ; thing <- tcLookup name + ; case thing of + AGlobal (ATyCon tc) -> return (mkTyConApp tc []) + _ -> panic "sc_ds_var_app 1" } -- General case sc_ds_var_app name arg_kis = do @@ -1356,23 +1358,24 @@ sc_ds_var_app name arg_kis = do Just (AGlobal (ATyCon tc)) | isAlgTyCon tc || isTupleTyCon tc -> do data_kinds <- xoptM Opt_DataKinds - unless data_kinds $ addErr (polyKindsErr name) - let tc_kind = tyConKind tc - case isPromotableKind tc_kind of + unless data_kinds $ addErr (dataKindsErr name) + case isPromotableTyCon tc of Just n | n == length arg_kis -> - return (mkTyConApp (mkPromotedTypeTyCon tc) arg_kis) - Just _ -> err tc_kind "is not fully applied" - Nothing -> err tc_kind "is not promotable" + return (mkTyConApp (buildPromotedTyCon tc) arg_kis) + Just _ -> err tc "is not fully applied" + Nothing -> err tc "is not promotable" + -- It is in scope, but not what we expected Just thing -> wrongThingErr "promoted type" thing name + -- It is not in scope, but it passed the renamer: staging error Nothing -> ASSERT2 ( isTyConName name, ppr name ) failWithTc (ptext (sLit "Promoted kind") <+> quotes (ppr name) <+> ptext (sLit "used in a mutually recursive group")) - - where err k m = failWithTc ( quotes (ppr name) <+> ptext (sLit "of kind") - <+> quotes (ppr k) <+> ptext (sLit m)) + where + err tc msg = failWithTc (quotes (ppr tc) <+> ptext (sLit "of kind") + <+> quotes (ppr (tyConKind tc)) <+> ptext (sLit msg)) \end{code} diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 8351b7b52d..89a034ba18 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -371,17 +371,16 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- round) -- (1) Do class and family instance declarations - ; fam_insts <- mapAndRecoverM tcTopFamInstDecl $ - filter (isFamInstDecl . unLoc) tycl_decls - ; inst_decl_stuff <- mapAndRecoverM tcLocalInstDecl1 inst_decls + ; inst_decl_stuff <- mapAndRecoverM tcLocalInstDecl1 inst_decls - ; let { (local_info, at_fam_insts_s) = unzip inst_decl_stuff - ; all_fam_insts = concat at_fam_insts_s ++ fam_insts } + ; let { (local_infos_s, fam_insts_s) = unzip inst_decl_stuff + ; all_fam_insts = concat fam_insts_s + ; local_infos = concat local_infos_s } -- (2) Next, construct the instance environment so far, consisting of -- (a) local instance decls -- (b) local family instance decls - ; addClsInsts local_info $ + ; addClsInsts local_infos $ addFamInsts all_fam_insts $ do -- (3) Compute instances from "deriving" clauses; @@ -403,13 +402,13 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls ; when (safeLanguageOn dflags) $ mapM_ (\x -> when (typInstCheck x) (addErrAt (getSrcSpan $ iSpec x) typInstErr)) - local_info + local_infos -- As above but for Safe Inference mode. ; when (safeInferOn dflags) $ - mapM_ (\x -> when (typInstCheck x) recordUnsafeInfer) local_info + mapM_ (\x -> when (typInstCheck x) recordUnsafeInfer) local_infos ; return ( gbl_env - , (bagToList deriv_inst_info) ++ local_info + , bagToList deriv_inst_info ++ local_infos , deriv_binds) }} where @@ -437,12 +436,18 @@ addFamInsts fam_insts thing_inside \begin{code} tcLocalInstDecl1 :: LInstDecl Name - -> TcM (InstInfo Name, [FamInst]) + -> TcM ([InstInfo Name], [FamInst]) -- A source-file instance declaration -- Type-check all the stuff before the "where" -- -- We check for respectable instance type, and context -tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) +tcLocalInstDecl1 (L loc (FamInstDecl decl)) + = setSrcSpan loc $ + tcAddDeclCtxt decl $ + do { fam_inst <- tcFamInstDecl TopLevel decl + ; return ([], [fam_inst]) } + +tcLocalInstDecl1 (L loc (ClsInstDecl poly_ty binds uprags ats)) = setSrcSpan loc $ addErrCtxt (instDeclCtxt1 poly_ty) $ @@ -500,7 +505,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) ispec = mkLocalInstance dfun overlap_flag inst_info = InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags False } - ; return ( inst_info, fam_insts0 ++ concat fam_insts1) } + ; return ( [inst_info], fam_insts0 ++ concat fam_insts1) } \end{code} %************************************************************************ @@ -515,12 +520,6 @@ lot of kinding and type checking code with ordinary algebraic data types (and GADTs). \begin{code} -tcTopFamInstDecl :: LTyClDecl Name -> TcM FamInst -tcTopFamInstDecl (L loc decl) - = setSrcSpan loc $ - tcAddDeclCtxt decl $ - tcFamInstDecl TopLevel decl - tcFamInstDecl :: TopLevelFlag -> TyClDecl Name -> TcM FamInst tcFamInstDecl top_lvl decl = do { -- Type family instances require -XTypeFamilies diff --git a/compiler/typecheck/TcMatches.lhs-boot b/compiler/typecheck/TcMatches.lhs-boot index f898f3deb7..8c421da6da 100644 --- a/compiler/typecheck/TcMatches.lhs-boot +++ b/compiler/typecheck/TcMatches.lhs-boot @@ -1,24 +1,17 @@ \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://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module TcMatches where -import HsSyn ( GRHSs, MatchGroup ) +import HsSyn ( GRHSs, MatchGroup ) import TcEvidence( HsWrapper ) -import Name ( Name ) -import TcType ( TcRhoType ) +import Name ( Name ) +import TcType ( TcRhoType ) import TcRnTypes( TcM, TcId ) tcGRHSsPat :: GRHSs Name - -> TcRhoType - -> TcM (GRHSs TcId) + -> TcRhoType + -> TcM (GRHSs TcId) tcMatchesFun :: Name -> Bool - -> MatchGroup Name - -> TcRhoType - -> TcM (HsWrapper, MatchGroup TcId) + -> MatchGroup Name + -> TcRhoType + -> TcM (HsWrapper, MatchGroup TcId) \end{code} diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 908588b8f6..8a5aab5437 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -5,26 +5,19 @@ \section[TcMovectle]{Typechecking a whole module} \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://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module TcRnDriver ( #ifdef GHCI - tcRnStmt, tcRnExpr, tcRnType, - tcRnImportDecls, - tcRnLookupRdrName, - getModuleInterface, - tcRnDeclsi, + tcRnStmt, tcRnExpr, tcRnType, + tcRnImportDecls, + tcRnLookupRdrName, + getModuleInterface, + tcRnDeclsi, #endif - tcRnLookupName, - tcRnGetInfo, - tcRnModule, - tcTopSrcDecls, - tcRnExtCore + tcRnLookupName, + tcRnGetInfo, + tcRnModule, + tcTopSrcDecls, + tcRnExtCore ) where #ifdef GHCI @@ -47,7 +40,7 @@ import FamInstEnv import TcAnnotations import TcBinds import HeaderInfo ( mkPrelImports ) -import TcType ( tidyTopType ) +import TcType ( tidyTopType ) import TcDefaults import TcEnv import TcRules @@ -84,7 +77,7 @@ import DataCon import Type import Class import TcType ( orphNamesOfDFunHead ) -import Inst ( tcGetInstEnvs ) +import Inst ( tcGetInstEnvs ) import Data.List ( sortBy ) import Data.IORef ( readIORef ) @@ -96,7 +89,7 @@ import RnTypes import RnExpr import MkId import BasicTypes -import TidyPgm ( globaliseAndTidyId ) +import TidyPgm ( globaliseAndTidyId ) import TysWiredIn ( unitTy, mkListTy ) #endif @@ -111,25 +104,25 @@ import Control.Monad \end{code} %************************************************************************ -%* * - Typecheck and rename a module -%* * +%* * + Typecheck and rename a module +%* * %************************************************************************ \begin{code} -- | Top level entry point for typechecker and renamer -tcRnModule :: HscEnv - -> HscSource - -> Bool -- True <=> save renamed syntax +tcRnModule :: HscEnv + -> HscSource + -> Bool -- True <=> save renamed syntax -> HsParsedModule - -> IO (Messages, Maybe TcGblEnv) + -> IO (Messages, Maybe TcGblEnv) tcRnModule hsc_env hsc_src save_rn_syntax HsParsedModule { hpm_module = (L loc (HsModule maybe_mod export_ies - import_decls local_decls mod_deprec + import_decls local_decls mod_deprec maybe_doc_hdr)), hpm_src_files = src_files @@ -137,17 +130,17 @@ tcRnModule hsc_env hsc_src save_rn_syntax = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; let { this_pkg = thisPackage (hsc_dflags hsc_env) ; - (this_mod, prel_imp_loc) + (this_mod, prel_imp_loc) = case maybe_mod of - Nothing -- 'module M where' is omitted - -> (mAIN, srcLocSpan (srcSpanStart loc)) - - Just (L mod_loc mod) -- The normal case + Nothing -- 'module M where' is omitted + -> (mAIN, srcLocSpan (srcSpanStart loc)) + + Just (L mod_loc mod) -- The normal case -> (mkModule this_pkg mod, mod_loc) } ; - - initTc hsc_env hsc_src save_rn_syntax this_mod $ + + initTc hsc_env hsc_src save_rn_syntax this_mod $ setSrcSpan loc $ - do { -- Deal with imports; first add implicit prelude + do { -- Deal with imports; first add implicit prelude implicit_prelude <- xoptM Opt_ImplicitPrelude; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc implicit_prelude import_decls } ; @@ -155,70 +148,70 @@ tcRnModule hsc_env hsc_src save_rn_syntax ifWOptM Opt_WarnImplicitPrelude $ when (notNull prel_imports) $ addWarn (implicitPreludeWarn) ; - tcg_env <- {-# SCC "tcRnImports" #-} + tcg_env <- {-# SCC "tcRnImports" #-} tcRnImports hsc_env this_mod (prel_imports ++ import_decls) ; - setGblEnv tcg_env $ do { - - -- Load the hi-boot interface for this module, if any - -- We do this now so that the boot_names can be passed - -- to tcTyAndClassDecls, because the boot_names are - -- automatically considered to be loop breakers - -- - -- Do this *after* tcRnImports, so that we know whether - -- a module that we import imports us; and hence whether to - -- look for a hi-boot file - boot_iface <- tcHiBootIface hsc_src this_mod ; - - -- Rename and type check the declarations - traceRn (text "rn1a") ; - tcg_env <- if isHsBoot hsc_src then - tcRnHsBootDecls local_decls - else - {-# SCC "tcRnSrcDecls" #-} + setGblEnv tcg_env $ do { + + -- Load the hi-boot interface for this module, if any + -- We do this now so that the boot_names can be passed + -- to tcTyAndClassDecls, because the boot_names are + -- automatically considered to be loop breakers + -- + -- Do this *after* tcRnImports, so that we know whether + -- a module that we import imports us; and hence whether to + -- look for a hi-boot file + boot_iface <- tcHiBootIface hsc_src this_mod ; + + -- Rename and type check the declarations + traceRn (text "rn1a") ; + tcg_env <- if isHsBoot hsc_src then + tcRnHsBootDecls local_decls + else + {-# SCC "tcRnSrcDecls" #-} tcRnSrcDecls boot_iface local_decls ; - setGblEnv tcg_env $ do { - - -- Report the use of any deprecated things - -- We do this *before* processsing the export list so - -- that we don't bleat about re-exporting a deprecated - -- thing (especially via 'module Foo' export item) - -- That is, only uses in the *body* of the module are complained about - traceRn (text "rn3") ; - failIfErrsM ; -- finishWarnings crashes sometimes - -- as a result of typechecker repairs (e.g. unboundNames) - tcg_env <- finishWarnings (hsc_dflags hsc_env) mod_deprec tcg_env ; - - -- Process the export list + setGblEnv tcg_env $ do { + + -- Report the use of any deprecated things + -- We do this *before* processsing the export list so + -- that we don't bleat about re-exporting a deprecated + -- thing (especially via 'module Foo' export item) + -- That is, only uses in the *body* of the module are complained about + traceRn (text "rn3") ; + failIfErrsM ; -- finishWarnings crashes sometimes + -- as a result of typechecker repairs (e.g. unboundNames) + tcg_env <- finishWarnings (hsc_dflags hsc_env) mod_deprec tcg_env ; + + -- Process the export list traceRn (text "rn4a: before exports"); - tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ; - traceRn (text "rn4b: after exports") ; + tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ; + traceRn (text "rn4b: after exports") ; -- Check that main is exported (must be after rnExports) checkMainExported tcg_env ; - -- Compare the hi-boot iface (if any) with the real thing - -- Must be done after processing the exports - tcg_env <- checkHiBootIface tcg_env boot_iface ; + -- Compare the hi-boot iface (if any) with the real thing + -- Must be done after processing the exports + tcg_env <- checkHiBootIface tcg_env boot_iface ; - -- The new type env is already available to stuff slurped from - -- interface files, via TcEnv.updateGlobalTypeEnv - -- It's important that this includes the stuff in checkHiBootIface, - -- because the latter might add new bindings for boot_dfuns, - -- which may be mentioned in imported unfoldings + -- The new type env is already available to stuff slurped from + -- interface files, via TcEnv.updateGlobalTypeEnv + -- It's important that this includes the stuff in checkHiBootIface, + -- because the latter might add new bindings for boot_dfuns, + -- which may be mentioned in imported unfoldings - -- Don't need to rename the Haddock documentation, - -- it's not parsed by GHC anymore. - tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ; + -- Don't need to rename the Haddock documentation, + -- it's not parsed by GHC anymore. + tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ; - -- Report unused names - reportUnusedNames export_ies tcg_env ; + -- Report unused names + reportUnusedNames export_ies tcg_env ; -- add extra source files to tcg_dependent_files addDependentFiles src_files ; -- Dump output and return - tcDump tcg_env ; - return tcg_env + tcDump tcg_env ; + return tcg_env }}}} @@ -229,94 +222,94 @@ implicitPreludeWarn %************************************************************************ -%* * - Import declarations -%* * +%* * + Import declarations +%* * %************************************************************************ \begin{code} -tcRnImports :: HscEnv -> Module +tcRnImports :: HscEnv -> Module -> [LImportDecl RdrName] -> TcM TcGblEnv tcRnImports hsc_env this_mod import_decls - = do { (rn_imports, rdr_env, imports,hpc_info) <- rnImports import_decls ; - - ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) - -- Make sure we record the dependencies from the DynFlags in the EPS or we - -- end up hitting the sanity check in LoadIface.loadInterface that - -- checks for unknown home-package modules being loaded. We put - -- these dependencies on the left so their (non-source) imports - -- take precedence over the (possibly-source) imports on the right. - -- We don't add them to any other field (e.g. the imp_dep_mods of - -- imports) because we don't want to load their instances etc. - ; dep_mods = listToUFM [(mod_nm, (mod_nm, False)) | mod_nm <- dynFlagDependencies (hsc_dflags hsc_env)] - `plusUFM` imp_dep_mods imports - - -- We want instance declarations from all home-package - -- modules below this one, including boot modules, except - -- ourselves. The 'except ourselves' is so that we don't - -- get the instances from this module's hs-boot file - ; want_instances :: ModuleName -> Bool - ; want_instances mod = mod `elemUFM` dep_mods - && mod /= moduleName this_mod - ; (home_insts, home_fam_insts) = hptInstances hsc_env + = do { (rn_imports, rdr_env, imports,hpc_info) <- rnImports import_decls ; + + ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) + -- Make sure we record the dependencies from the DynFlags in the EPS or we + -- end up hitting the sanity check in LoadIface.loadInterface that + -- checks for unknown home-package modules being loaded. We put + -- these dependencies on the left so their (non-source) imports + -- take precedence over the (possibly-source) imports on the right. + -- We don't add them to any other field (e.g. the imp_dep_mods of + -- imports) because we don't want to load their instances etc. + ; dep_mods = listToUFM [(mod_nm, (mod_nm, False)) | mod_nm <- dynFlagDependencies (hsc_dflags hsc_env)] + `plusUFM` imp_dep_mods imports + + -- We want instance declarations from all home-package + -- modules below this one, including boot modules, except + -- ourselves. The 'except ourselves' is so that we don't + -- get the instances from this module's hs-boot file + ; want_instances :: ModuleName -> Bool + ; want_instances mod = mod `elemUFM` dep_mods + && mod /= moduleName this_mod + ; (home_insts, home_fam_insts) = hptInstances hsc_env want_instances - } ; + } ; - -- Record boot-file info in the EPS, so that it's - -- visible to loadHiBootInterface in tcRnSrcDecls, - -- and any other incrementally-performed imports - ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ; + -- Record boot-file info in the EPS, so that it's + -- visible to loadHiBootInterface in tcRnSrcDecls, + -- and any other incrementally-performed imports + ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ; - -- Update the gbl env - ; updGblEnv ( \ gbl -> - gbl { + -- Update the gbl env + ; updGblEnv ( \ gbl -> + gbl { tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env, - tcg_imports = tcg_imports gbl `plusImportAvails` imports, + tcg_imports = tcg_imports gbl `plusImportAvails` imports, tcg_rn_imports = rn_imports, - tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, - tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) + tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, + tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) home_fam_insts, - tcg_hpc = hpc_info - }) $ do { - - ; traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) - -- Fail if there are any errors so far - -- The error printing (if needed) takes advantage - -- of the tcg_env we have now set --- ; traceIf (text "rdr_env: " <+> ppr rdr_env) - ; failIfErrsM - - -- Load any orphan-module and family instance-module - -- interfaces, so that their rules and instance decls will be - -- found. - ; loadModuleInterfaces (ptext (sLit "Loading orphan modules")) + tcg_hpc = hpc_info + }) $ do { + + ; traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) + -- Fail if there are any errors so far + -- The error printing (if needed) takes advantage + -- of the tcg_env we have now set +-- ; traceIf (text "rdr_env: " <+> ppr rdr_env) + ; failIfErrsM + + -- Load any orphan-module and family instance-module + -- interfaces, so that their rules and instance decls will be + -- found. + ; loadModuleInterfaces (ptext (sLit "Loading orphan modules")) (imp_orphs imports) -- Check type-family consistency - ; traceRn (text "rn1: checking family instance consistency") - ; let { dir_imp_mods = moduleEnvKeys - . imp_mods - $ imports } - ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ; + ; traceRn (text "rn1: checking family instance consistency") + ; let { dir_imp_mods = moduleEnvKeys + . imp_mods + $ imports } + ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ; - ; getGblEnv } } + ; getGblEnv } } \end{code} %************************************************************************ -%* * - Type-checking external-core modules -%* * +%* * + Type-checking external-core modules +%* * %************************************************************************ \begin{code} -tcRnExtCore :: HscEnv - -> HsExtCore RdrName - -> IO (Messages, Maybe ModGuts) - -- Nothing => some error occurred +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 + -- 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 { @@ -326,11 +319,11 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- 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 + -- (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 -} + (tc_envs, _bndrs) <- getLocalNonValBinders emptyFsEnv {- no fixity decls -} (mkFakeGroup ldecls) ; setEnvs tc_envs $ do { @@ -338,35 +331,35 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- 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 + -- 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 + -- 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 ; 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 + -- Make the new type env available to stuff slurped from interface files + + -- Now the core bindings core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ; - -- Wrap up + -- Wrap up let { - bndrs = bindersOfBinds core_binds ; - my_exports = map (Avail . idName) bndrs ; - -- ToDo: export the data types also? + 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_boot = False, mg_used_names = emptyNameSet, -- ToDo: compute usage mg_used_th = False, mg_dir_imps = emptyModuleEnv, -- ?? - mg_deps = noDependencies, -- ?? + mg_deps = noDependencies, -- ?? mg_exports = my_exports, mg_tcs = tcg_tcs tcg_env, mg_insts = tcg_insts tcg_env, @@ -402,43 +395,43 @@ mkFakeGroup decls -- Rather clumsy; lots of unused fields %************************************************************************ -%* * - Type-checking the top level of a module -%* * +%* * + Type-checking the top level of a module +%* * %************************************************************************ \begin{code} tcRnSrcDecls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv - -- Returns the variables free in the decls - -- Reason: solely to report unused imports and bindings + -- Returns the variables free in the decls + -- Reason: solely to report unused imports and bindings tcRnSrcDecls boot_iface decls - = do { -- Do all the declarations - ((tcg_env, tcl_env), lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ; + = do { -- Do all the declarations + ((tcg_env, tcl_env), lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ; ; traceTc "Tc8" empty ; - ; setEnvs (tcg_env, tcl_env) $ - do { - - -- Finish simplifying class constraints - -- - -- simplifyTop deals with constant or ambiguous InstIds. - -- How could there be ambiguous ones? They can only arise if a - -- top-level decl falls under the monomorphism restriction - -- and no subsequent decl instantiates its type. - -- - -- We do this after checkMain, so that we use the type info - -- that checkMain adds - -- - -- We do it with both global and local env in scope: - -- * the global env exposes the instances to simplifyTop - -- * the local env exposes the local Ids to simplifyTop, - -- so that we get better error messages (monomorphism restriction) - new_ev_binds <- {-# SCC "simplifyTop" #-} + ; setEnvs (tcg_env, tcl_env) $ + do { + + -- Finish simplifying class constraints + -- + -- simplifyTop deals with constant or ambiguous InstIds. + -- How could there be ambiguous ones? They can only arise if a + -- top-level decl falls under the monomorphism restriction + -- and no subsequent decl instantiates its type. + -- + -- We do this after checkMain, so that we use the type info + -- that checkMain adds + -- + -- We do it with both global and local env in scope: + -- * the global env exposes the instances to simplifyTop + -- * the local env exposes the local Ids to simplifyTop, + -- so that we get better error messages (monomorphism restriction) + new_ev_binds <- {-# SCC "simplifyTop" #-} simplifyTop lie ; traceTc "Tc9" empty ; - failIfErrsM ; -- Don't zonk if there have been errors - -- It's a waste of time; and we may get debug warnings - -- about strangely-typed TyCons! + failIfErrsM ; -- Don't zonk if there have been errors + -- It's a waste of time; and we may get debug warnings + -- about strangely-typed TyCons! -- Zonk the final code. This must be done last. -- Even simplifyTop may do some unification. @@ -453,76 +446,76 @@ tcRnSrcDecls boot_iface decls tcg_fords = fords } = tcg_env ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ; - (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') + (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') <- {-# SCC "zonkTopDecls" #-} zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords ; - + let { final_type_env = extendTypeEnvWithIds type_env bind_ids ; tcg_env' = tcg_env { tcg_binds = binds', tcg_ev_binds = ev_binds', tcg_imp_specs = imp_specs', - tcg_rules = rules', - tcg_vects = vects', + tcg_rules = rules', + tcg_vects = vects', tcg_fords = fords' } } ; setGlobalTypeEnv tcg_env' final_type_env } } -tc_rn_src_decls :: ModDetails - -> [LHsDecl RdrName] +tc_rn_src_decls :: ModDetails + -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) --- Loops around dealing with each top level inter-splice group +-- Loops around dealing with each top level inter-splice group -- in turn, until it's dealt with the entire module tc_rn_src_decls boot_details ds = {-# SCC "tc_rn_src_decls" #-} do { (first_group, group_tail) <- findSplice ds ; - -- If ds is [] we get ([], Nothing) - - -- The extra_deps are needed while renaming type and class declarations + -- If ds is [] we get ([], Nothing) + + -- The extra_deps are needed while renaming type and class declarations -- See Note [Extra dependencies from .hs-boot files] in RnSource - let { extra_deps = map tyConName (typeEnvTyCons (md_types boot_details)) } ; - -- Deal with decls up to, but not including, the first splice - (tcg_env, rn_decls) <- rnTopSrcDecls extra_deps first_group ; - -- rnTopSrcDecls fails if there are any errors - - (tcg_env, tcl_env) <- setGblEnv tcg_env $ - tcTopSrcDecls boot_details rn_decls ; - - -- If there is no splice, we're nearly done - setEnvs (tcg_env, tcl_env) $ - case group_tail of { - Nothing -> do { tcg_env <- checkMain ; -- Check for `main' - return (tcg_env, tcl_env) - } ; + let { extra_deps = map tyConName (typeEnvTyCons (md_types boot_details)) } ; + -- Deal with decls up to, but not including, the first splice + (tcg_env, rn_decls) <- rnTopSrcDecls extra_deps first_group ; + -- rnTopSrcDecls fails if there are any errors + + (tcg_env, tcl_env) <- setGblEnv tcg_env $ + tcTopSrcDecls boot_details rn_decls ; + + -- If there is no splice, we're nearly done + setEnvs (tcg_env, tcl_env) $ + case group_tail of { + Nothing -> do { tcg_env <- checkMain ; -- Check for `main' + return (tcg_env, tcl_env) + } ; #ifndef GHCI - -- There shouldn't be a splice - Just (SpliceDecl {}, _) -> do { - failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler") + -- There shouldn't be a splice + Just (SpliceDecl {}, _) -> do { + failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler") #else - -- If there's a splice, we must carry on - Just (SpliceDecl splice_expr _, rest_ds) -> do { + -- If there's a splice, we must carry on + Just (SpliceDecl splice_expr _, rest_ds) -> do { - -- Rename the splice expression, and get its supporting decls - (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ; - -- checkNoErrs: don't typecheck if renaming failed - rnDump (ppr rn_splice_expr) ; + -- Rename the splice expression, and get its supporting decls + (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ; + -- checkNoErrs: don't typecheck if renaming failed + rnDump (ppr rn_splice_expr) ; - -- Execute the splice - spliced_decls <- tcSpliceDecls rn_splice_expr ; + -- Execute the splice + spliced_decls <- tcSpliceDecls rn_splice_expr ; - -- Glue them on the front of the remaining decls and loop - setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ - tc_rn_src_decls boot_details (spliced_decls ++ rest_ds) + -- Glue them on the front of the remaining decls and loop + setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ + tc_rn_src_decls boot_details (spliced_decls ++ rest_ds) #endif /* GHCI */ } } } \end{code} %************************************************************************ -%* * - Compiling hs-boot source files, and - comparing the hi-boot interface with the real thing -%* * +%* * + Compiling hs-boot source files, and + comparing the hi-boot interface with the real thing +%* * %************************************************************************ \begin{code} @@ -530,69 +523,69 @@ tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv tcRnHsBootDecls decls = do { (first_group, group_tail) <- findSplice decls - -- Rename the declarations - ; (tcg_env, HsGroup { - hs_tyclds = tycl_decls, - hs_instds = inst_decls, - hs_derivds = deriv_decls, - hs_fords = for_decls, - hs_defds = def_decls, - hs_ruleds = rule_decls, - hs_vects = vect_decls, - hs_annds = _, - hs_valds = val_binds }) <- rnTopSrcDecls [] first_group + -- Rename the declarations + ; (tcg_env, HsGroup { + hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_derivds = deriv_decls, + hs_fords = for_decls, + hs_defds = def_decls, + hs_ruleds = rule_decls, + hs_vects = vect_decls, + hs_annds = _, + hs_valds = val_binds }) <- rnTopSrcDecls [] first_group -- The empty list is for extra dependencies coming from .hs-boot files -- See Note [Extra dependencies from .hs-boot files] in RnSource - ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do { - - - -- Check for illegal declarations - ; case group_tail of - Just (SpliceDecl d _, _) -> badBootDecl "splice" d - Nothing -> return () - ; mapM_ (badBootDecl "foreign") for_decls - ; mapM_ (badBootDecl "default") def_decls - ; mapM_ (badBootDecl "rule") rule_decls - ; mapM_ (badBootDecl "vect") vect_decls - - -- Typecheck type/class decls - ; traceTc "Tc2" empty - ; tcg_env <- tcTyAndClassDecls emptyModDetails tycl_decls - ; setGblEnv tcg_env $ do { - - -- Typecheck instance decls - -- Family instance declarations are rejected here - ; traceTc "Tc3" empty - ; (tcg_env, inst_infos, _deriv_binds) + ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do { + + + -- Check for illegal declarations + ; case group_tail of + Just (SpliceDecl d _, _) -> badBootDecl "splice" d + Nothing -> return () + ; mapM_ (badBootDecl "foreign") for_decls + ; mapM_ (badBootDecl "default") def_decls + ; mapM_ (badBootDecl "rule") rule_decls + ; mapM_ (badBootDecl "vect") vect_decls + + -- Typecheck type/class decls + ; traceTc "Tc2 (boot)" empty + ; tcg_env <- tcTyAndClassDecls emptyModDetails tycl_decls + ; setGblEnv tcg_env $ do { + + -- Typecheck instance decls + -- Family instance declarations are rejected here + ; traceTc "Tc3" empty + ; (tcg_env, inst_infos, _deriv_binds) <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls - ; setGblEnv tcg_env $ do { - - -- Typecheck value declarations - ; traceTc "Tc5" empty - ; val_ids <- tcHsBootSigs val_binds - - -- Wrap up - -- No simplification or zonking to do - ; traceTc "Tc7a" empty - ; gbl_env <- getGblEnv - - -- Make the final type-env - -- Include the dfun_ids so that their type sigs - -- are written into the interface file. - ; let { type_env0 = tcg_type_env gbl_env - ; type_env1 = extendTypeEnvWithIds type_env0 val_ids - ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids - ; dfun_ids = map iDFunId inst_infos - } - - ; setGlobalTypeEnv gbl_env type_env2 + ; setGblEnv tcg_env $ do { + + -- Typecheck value declarations + ; traceTc "Tc5" empty + ; val_ids <- tcHsBootSigs val_binds + + -- Wrap up + -- No simplification or zonking to do + ; traceTc "Tc7a" empty + ; gbl_env <- getGblEnv + + -- Make the final type-env + -- Include the dfun_ids so that their type sigs + -- are written into the interface file. + ; let { type_env0 = tcg_type_env gbl_env + ; type_env1 = extendTypeEnvWithIds type_env0 val_ids + ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids + ; dfun_ids = map iDFunId inst_infos + } + + ; setGlobalTypeEnv gbl_env type_env2 }}} ; traceTc "boot" (ppr lie); return gbl_env } badBootDecl :: String -> Located decl -> TcM () -badBootDecl what (L loc _) - = addErrAt loc (char 'A' <+> text what +badBootDecl what (L loc _) + = addErrAt loc (char 'A' <+> text what <+> ptext (sLit "declaration is not (currently) allowed in a hs-boot file")) \end{code} @@ -607,34 +600,34 @@ checkHiBootIface :: TcGblEnv -> ModDetails -> TcM TcGblEnv -- of boot_names is empty. -- -- The bindings we return give bindings for the dfuns defined in the --- hs-boot file, such as $fbEqT = $fEqT +-- hs-boot file, such as $fbEqT = $fEqT 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 }) - | isHsBoot hs_src -- Current module is already a hs-boot file! - = return tcg_env + 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 }) + | isHsBoot hs_src -- Current module is already a hs-boot file! + = return tcg_env | otherwise - = do { traceTc "checkHiBootIface" $ vcat + = do { traceTc "checkHiBootIface" $ vcat [ ppr boot_type_env, ppr boot_insts, ppr boot_exports] - -- Check the exports of the boot module, one by one - ; mapM_ check_export boot_exports + -- Check the exports of the boot module, one by one + ; mapM_ check_export boot_exports - -- Check for no family instances - ; unless (null boot_fam_insts) $ - panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++ - "instances in boot files yet...") + -- Check for no family instances + ; unless (null boot_fam_insts) $ + panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++ + "instances in boot files yet...") -- FIXME: Why? The actual comparison is not hard, but what would - -- be the equivalent to the dfun bindings returned for class - -- instances? We can't easily equate tycons... + -- be the equivalent to the dfun bindings returned for class + -- instances? We can't easily equate tycons... - -- Check instance declarations - ; mb_dfun_prs <- mapM check_inst boot_insts + -- 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) @@ -643,34 +636,34 @@ checkHiBootIface 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 + ; 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 where - check_export boot_avail -- boot_avail is exported by the boot iface - | name `elem` dfun_names = return () - | isWiredInName name = return () -- No checking for wired-in names. In particular, - -- 'error' is handled by a rather gross hack - -- (see comments in GHC.Err.hs-boot) + check_export boot_avail -- boot_avail is exported by the boot iface + | name `elem` dfun_names = return () + | isWiredInName name = return () -- No checking for wired-in names. In particular, + -- 'error' is handled by a rather gross hack + -- (see comments in GHC.Err.hs-boot) - -- Check that the actual module exports the same thing + -- Check that the actual module exports the same thing | not (null missing_names) - = addErrAt (nameSrcSpan (head missing_names)) + = addErrAt (nameSrcSpan (head missing_names)) (missingBootThing (head missing_names) "exported by") - -- If the boot module does not *define* the thing, we are done - -- (it simply re-exports it, and names match, so nothing further to do) + -- If the boot module does not *define* the thing, we are done + -- (it simply re-exports it, and names match, so nothing further to do) | isNothing mb_boot_thing = return () - -- Check that the actual module also defines the thing, and - -- then compare the definitions + -- Check that the actual module also defines the thing, and + -- then compare the definitions | Just real_thing <- lookupTypeEnv local_type_env name, Just boot_thing <- mb_boot_thing = when (not (checkBootDecl boot_thing real_thing)) $ addErrAt (nameSrcSpan (getName boot_thing)) - (let boot_decl = tyThingToIfaceDecl + (let boot_decl = tyThingToIfaceDecl (fromJust mb_boot_thing) real_decl = tyThingToIfaceDecl real_thing in bootMisMatch real_thing boot_decl real_decl) @@ -678,33 +671,33 @@ checkHiBootIface | otherwise = addErrTc (missingBootThing name "defined in") where - name = availName boot_avail - mb_boot_thing = lookupTypeEnv boot_type_env name - missing_names = case lookupNameEnv local_export_env name of - Nothing -> [name] - Just avail -> availNames boot_avail `minusList` availNames avail - + name = availName boot_avail + mb_boot_thing = lookupTypeEnv boot_type_env name + missing_names = case lookupNameEnv local_export_env name of + Nothing -> [name] + Just avail -> availNames boot_avail `minusList` availNames avail + dfun_names = map getName boot_insts local_export_env :: NameEnv AvailInfo local_export_env = availsToNameEnv local_exports check_inst :: ClsInst -> TcM (Maybe (Id, Id)) - -- Returns a pair of the boot dfun in terms of the equivalent real dfun + -- Returns a pair of the boot dfun in terms of the equivalent real dfun check_inst boot_inst - = case [dfun | inst <- local_insts, - let dfun = instanceDFunId inst, - idType dfun `eqType` boot_inst_ty ] of - [] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts) + = case [dfun | inst <- local_insts, + let dfun = instanceDFunId inst, + idType dfun `eqType` boot_inst_ty ] of + [] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts) , text "boot_inst" <+> ppr boot_inst , text "boot_inst_ty" <+> ppr boot_inst_ty - ]) + ]) ; addErrTc (instMisMatch boot_inst); return Nothing } - (dfun:_) -> return (Just (local_boot_dfun, dfun)) - where - boot_dfun = instanceDFunId boot_inst - boot_inst_ty = idType boot_dfun - local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty + (dfun:_) -> return (Just (local_boot_dfun, dfun)) + where + boot_dfun = instanceDFunId boot_inst + boot_inst_ty = idType boot_dfun + local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty -- This has to compare the TyThing from the .hi-boot file to the TyThing @@ -717,7 +710,7 @@ checkHiBootIface checkBootDecl :: TyThing -> TyThing -> Bool checkBootDecl (AnId id1) (AnId id2) - = ASSERT(id1 == id2) + = ASSERT(id1 == id2) (idType id1 `eqType` idType id2) checkBootDecl (ATyCon tc1) (ATyCon tc2) @@ -732,14 +725,14 @@ checkBootDecl _ _ = False -- probably shouldn't happen checkBootTyCon :: TyCon -> TyCon -> Bool checkBootTyCon tc1 tc2 | not (eqKind (tyConKind tc1) (tyConKind tc2)) - = False -- First off, check the kind + = False -- First off, check the kind | Just c1 <- tyConClass_maybe tc1 , Just c2 <- tyConClass_maybe tc2 - = let - (clas_tyvars1, clas_fds1, sc_theta1, _, ats1, op_stuff1) + = let + (clas_tyvars1, clas_fds1, sc_theta1, _, ats1, op_stuff1) = classExtraBigSig c1 - (clas_tyvars2, clas_fds2, sc_theta2, _, ats2, op_stuff2) + (clas_tyvars2, clas_fds2, sc_theta2, _, ats2, op_stuff2) = classExtraBigSig c2 env0 = mkRnEnv2 emptyInScopeSet @@ -766,7 +759,7 @@ checkBootTyCon tc1 tc2 eqTypeX env ty1 ty2 where env = rnBndrs2 env0 tvs1 tvs2 - eqFD (as1,bs1) (as2,bs2) = + eqFD (as1,bs1) (as2,bs2) = eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) @@ -779,7 +772,7 @@ checkBootTyCon tc1 tc2 || -- Above tests for an "abstract" class eqListBy (eqPredX env) sc_theta1 sc_theta2 && eqListBy eqSig op_stuff1 op_stuff2 && - eqListBy eqAT ats1 ats2) + eqListBy eqAT ats1 ats2) | isSynTyCon tc1 && isSynTyCon tc2 = ASSERT(tc1 == tc2) @@ -806,11 +799,11 @@ checkBootTyCon tc1 tc2 tyConExtName tc1 == tyConExtName tc2 | otherwise = False - where + where env0 = mkRnEnv2 emptyInScopeSet - eqAlgRhs (AbstractTyCon dis1) rhs2 - | dis1 = isDistinctAlgRhs rhs2 --Check compatibility + eqAlgRhs (AbstractTyCon dis1) rhs2 + | dis1 = isDistinctAlgRhs rhs2 --Check compatibility | otherwise = True eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} = @@ -829,14 +822,14 @@ checkBootTyCon tc1 tc2 ---------------- missingBootThing :: Name -> String -> SDoc missingBootThing name what - = ppr name <+> ptext (sLit "is exported by the hs-boot file, but not") - <+> text what <+> ptext (sLit "the module") + = ppr name <+> ptext (sLit "is exported by the hs-boot file, but not") + <+> text what <+> ptext (sLit "the module") bootMisMatch :: TyThing -> IfaceDecl -> IfaceDecl -> SDoc bootMisMatch thing boot_decl real_decl = vcat [ppr thing <+> ptext (sLit "has conflicting definitions in the module and its hs-boot file"), - ptext (sLit "Main module:") <+> ppr real_decl, - ptext (sLit "Boot file: ") <+> ppr boot_decl] + ptext (sLit "Main module:") <+> ppr real_decl, + ptext (sLit "Boot file: ") <+> ppr boot_decl] instMisMatch :: ClsInst -> SDoc instMisMatch inst @@ -846,9 +839,9 @@ instMisMatch inst %************************************************************************ -%* * - Type-checking the top level of a module -%* * +%* * + Type-checking the top level of a module +%* * %************************************************************************ tcRnGroup takes a bunch of top-level source-code declarations, and @@ -869,70 +862,70 @@ rnTopSrcDecls :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name) rnTopSrcDecls extra_deps group = do { -- Rename the source decls traceTc "rn12" empty ; - (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls extra_deps group ; + (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls extra_deps group ; traceTc "rn13" empty ; -- save the renamed syntax, if we want it - let { tcg_env' - | Just grp <- tcg_rn_decls tcg_env - = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) } - | otherwise - = tcg_env }; + let { tcg_env' + | Just grp <- tcg_rn_decls tcg_env + = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) } + | otherwise + = tcg_env }; - -- Dump trace of renaming part - rnDump (ppr rn_decls) ; + -- Dump trace of renaming part + rnDump (ppr rn_decls) ; - return (tcg_env', rn_decls) + return (tcg_env', rn_decls) } ------------------------------------------------ tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv) -tcTopSrcDecls boot_details - (HsGroup { hs_tyclds = tycl_decls, - hs_instds = inst_decls, +tcTopSrcDecls boot_details + (HsGroup { hs_tyclds = tycl_decls, + hs_instds = inst_decls, hs_derivds = deriv_decls, - hs_fords = foreign_decls, - hs_defds = default_decls, - hs_annds = annotation_decls, - hs_ruleds = rule_decls, - hs_vects = vect_decls, - hs_valds = val_binds }) - = do { -- Type-check the type and class decls, and all imported decls - -- The latter come in via tycl_decls - traceTc "Tc2" empty ; - - tcg_env <- tcTyAndClassDecls boot_details tycl_decls ; - setGblEnv tcg_env $ do { - - -- Source-language instances, including derivings, - -- and import the supporting declarations + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_annds = annotation_decls, + hs_ruleds = rule_decls, + hs_vects = vect_decls, + hs_valds = val_binds }) + = do { -- Type-check the type and class decls, and all imported decls + -- The latter come in via tycl_decls + traceTc "Tc2 (src)" empty ; + + tcg_env <- tcTyAndClassDecls boot_details tycl_decls ; + setGblEnv tcg_env $ do { + + -- Source-language instances, including derivings, + -- and import the supporting declarations traceTc "Tc3" empty ; - (tcg_env, inst_infos, deriv_binds) + (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls; - setGblEnv tcg_env $ do { + setGblEnv tcg_env $ do { - -- Foreign import declarations next. + -- Foreign import declarations next. traceTc "Tc4" empty ; - (fi_ids, fi_decls) <- tcForeignImports foreign_decls ; - tcExtendGlobalValEnv fi_ids $ do { + (fi_ids, fi_decls) <- tcForeignImports foreign_decls ; + tcExtendGlobalValEnv fi_ids $ do { - -- Default declarations + -- Default declarations traceTc "Tc4a" empty ; - default_tys <- tcDefaults default_decls ; - updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { - - -- Now GHC-generated derived bindings, generics, and selectors - -- Do not generate warnings from compiler-generated code; - -- hence the use of discardWarnings - tc_envs <- discardWarnings (tcTopBinds deriv_binds) ; + default_tys <- tcDefaults default_decls ; + updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { + + -- Now GHC-generated derived bindings, generics, and selectors + -- Do not generate warnings from compiler-generated code; + -- hence the use of discardWarnings + tc_envs <- discardWarnings (tcTopBinds deriv_binds) ; setEnvs tc_envs $ do { - -- Value declarations next + -- Value declarations next traceTc "Tc5" empty ; - tc_envs@(tcg_env, tcl_env) <- tcTopBinds val_binds; - setEnvs tc_envs $ do { -- Environment doesn't change now + tc_envs@(tcg_env, tcl_env) <- tcTopBinds val_binds; + setEnvs tc_envs $ do { -- Environment doesn't change now - -- Second pass over class and instance declarations, + -- Second pass over class and instance declarations, -- now using the kind-checked decls traceTc "Tc6" empty ; inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ; @@ -952,13 +945,13 @@ tcTopSrcDecls boot_details -- Wrap up traceTc "Tc7a" empty ; - let { all_binds = inst_binds `unionBags` - foe_binds + let { all_binds = inst_binds `unionBags` + foe_binds - ; sig_names = mkNameSet (collectHsValBinders val_binds) + ; sig_names = mkNameSet (collectHsValBinders val_binds) `minusNameSet` getTypeSigNames val_binds - -- Extend the GblEnv with the (as yet un-zonked) + -- Extend the GblEnv with the (as yet un-zonked) -- bindings, rules, foreign decls ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds , tcg_sigs = tcg_sigs tcg_env `unionNameSets` sig_names @@ -973,18 +966,18 @@ tcTopSrcDecls boot_details %************************************************************************ -%* * - Checking for 'main' -%* * +%* * + Checking for 'main' +%* * %************************************************************************ \begin{code} checkMain :: TcM TcGblEnv -- If we are in module Main, check that 'main' is defined. -checkMain +checkMain = do { tcg_env <- getGblEnv ; - dflags <- getDynFlags ; - check_main dflags tcg_env + dflags <- getDynFlags ; + check_main dflags tcg_env } check_main :: DynFlags -> TcGblEnv -> TcM TcGblEnv @@ -994,59 +987,59 @@ check_main dflags tcg_env return tcg_env | otherwise - = do { mb_main <- lookupGlobalOccRn_maybe main_fn - -- Check that 'main' is in scope - -- It might be imported from another module! - ; case mb_main of { - Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn) - ; complain_no_main - ; return tcg_env } ; - Just main_name -> do - - { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn) - ; let loc = srcLocSpan (getSrcLoc main_name) - ; ioTyCon <- tcLookupTyCon ioTyConName + = do { mb_main <- lookupGlobalOccRn_maybe main_fn + -- Check that 'main' is in scope + -- It might be imported from another module! + ; case mb_main of { + Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn) + ; complain_no_main + ; return tcg_env } ; + Just main_name -> do + + { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn) + ; let loc = srcLocSpan (getSrcLoc main_name) + ; ioTyCon <- tcLookupTyCon ioTyConName ; res_ty <- newFlexiTyVarTy liftedTypeKind - ; main_expr - <- addErrCtxt mainCtxt $ - tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty]) - - -- See Note [Root-main Id] - -- Construct the binding - -- :Main.main :: IO res_ty = runMainIO res_ty main - ; run_main_id <- tcLookupId runMainIOName - ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN - (mkVarOccFS (fsLit "main")) - (getSrcSpan main_name) - ; root_main_id = Id.mkExportedLocalId root_main_name - (mkTyConApp ioTyCon [res_ty]) - ; co = mkWpTyApps [res_ty] - ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr - ; main_bind = mkVarBind root_main_id rhs } - - ; return (tcg_env { tcg_main = Just main_name, + ; main_expr + <- addErrCtxt mainCtxt $ + tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty]) + + -- See Note [Root-main Id] + -- Construct the binding + -- :Main.main :: IO res_ty = runMainIO res_ty main + ; run_main_id <- tcLookupId runMainIOName + ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN + (mkVarOccFS (fsLit "main")) + (getSrcSpan main_name) + ; root_main_id = Id.mkExportedLocalId root_main_name + (mkTyConApp ioTyCon [res_ty]) + ; co = mkWpTyApps [res_ty] + ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr + ; main_bind = mkVarBind root_main_id rhs } + + ; return (tcg_env { tcg_main = Just main_name, tcg_binds = tcg_binds tcg_env - `snocBag` main_bind, - tcg_dus = tcg_dus tcg_env - `plusDU` usesOnly (unitFV main_name) - -- Record the use of 'main', so that we don't - -- complain about it being defined but not used - }) + `snocBag` main_bind, + tcg_dus = tcg_dus tcg_env + `plusDU` usesOnly (unitFV main_name) + -- Record the use of 'main', so that we don't + -- complain about it being defined but not used + }) }}} where - mod = tcg_mod tcg_env + mod = tcg_mod tcg_env main_mod = mainModIs dflags main_fn = getMainFun dflags complain_no_main | ghcLink dflags == LinkInMemory = return () - | otherwise = failWithTc noMainMsg - -- In interactive mode, don't worry about the absence of 'main' - -- In other modes, fail altogether, so that we don't go on - -- and complain a second time when processing the export list. + | otherwise = failWithTc noMainMsg + -- In interactive mode, don't worry about the absence of 'main' + -- In other modes, fail altogether, so that we don't go on + -- and complain a second time when processing the export list. mainCtxt = ptext (sLit "When checking the type of the") <+> pp_main_fn noMainMsg = ptext (sLit "The") <+> pp_main_fn - <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod) + <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod) pp_main_fn = ppMainFn main_fn ppMainFn :: RdrName -> SDoc @@ -1055,7 +1048,7 @@ ppMainFn main_fn = ptext (sLit "function") <+> quotes (ppr main_fn) | otherwise = ptext (sLit "main function") <+> quotes (ppr main_fn) - + -- | Get the unqualified name of the function to use as the \"main\" for the main module. -- Either returns the default name or the one configured on the command line with -main-is getMainFun :: DynFlags -> RdrName @@ -1081,7 +1074,7 @@ The function that the RTS invokes is always :Main.main, which we call root_main_id. (Because GHC allows the user to have a module not called Main as the main module, we can't rely on the main function being called "Main.main". That's why root_main_id has a fixed module -":Main".) +":Main".) This is unusual: it's a LocalId whose Name has a Module from another module. Tiresomely, we must filter it out again in MkIface, les we @@ -1089,16 +1082,16 @@ get two defns for 'main' in the interface file! %********************************************************* -%* * - GHCi stuff -%* * +%* * + GHCi stuff +%* * %********************************************************* \begin{code} setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a -setInteractiveContext hsc_env icxt thing_inside - = let -- Initialise the tcg_inst_env with instances from all home modules. - -- This mimics the more selective call to hptInstances in tcRnModule. +setInteractiveContext hsc_env icxt thing_inside + = let -- Initialise the tcg_inst_env with instances from all home modules. + -- This mimics the more selective call to hptInstances in tcRnImports (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True) (ic_insts, ic_finsts) = ic_instances icxt @@ -1150,9 +1143,11 @@ setInteractiveContext hsc_env icxt thing_inside (map getOccName visible_tmp_ids) -- Note [delete shadowed tcg_rdr_env entries] , tcg_type_env = type_env + , tcg_insts = ic_insts , tcg_inst_env = extendInstEnvList (extendInstEnvList (tcg_inst_env env) ic_insts) home_insts + , tcg_fam_insts = ic_finsts , tcg_fam_inst_env = extendFamInstEnvList (extendFamInstEnvList (tcg_fam_inst_env env) ic_finsts) @@ -1165,40 +1160,26 @@ setInteractiveContext hsc_env icxt thing_inside tcExtendGhciEnv visible_tmp_ids $ -- Note [GHCi temporary Ids] thing_inside -\end{code} - -\begin{code} #ifdef GHCI -tcRnStmt :: HscEnv - -> InteractiveContext - -> LStmt RdrName - -> IO (Messages, Maybe ([Id], LHsExpr Id)) - -- The returned [Id] is the list of new Ids bound by - -- this statement. It can be used to extend the - -- InteractiveContext via extendInteractiveContext. - -- - -- The returned TypecheckedHsExpr is of type IO [ () ], - -- a list of the bound values, coerced to (). - +-- | The returned [Id] is the list of new Ids bound by this statement. It can +-- be used to extend the InteractiveContext via extendInteractiveContext. +-- +-- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound +-- values, coerced to (). +tcRnStmt :: HscEnv -> InteractiveContext -> LStmt RdrName + -> IO (Messages, Maybe ([Id], LHsExpr Id)) tcRnStmt hsc_env ictxt rdr_stmt - = initTcPrintErrors hsc_env iNTERACTIVE $ + = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { - -- Rename; use CmdLineMode because tcRnStmt is only used interactively - (([rn_stmt], _), fvs) <- rnStmts GhciStmt [rdr_stmt] $ \_ -> - return ((), emptyFVs) ; - traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ; - failIfErrsM ; - rnDump (ppr rn_stmt) ; - -- The real work is done here - (bound_ids, tc_expr) <- mkPlan rn_stmt ; + (bound_ids, tc_expr) <- tcUserStmt rdr_stmt ; zonked_expr <- zonkTopLExpr tc_expr ; zonked_ids <- zonkTopBndrs bound_ids ; - - -- None of the Ids should be of unboxed type, because we - -- cast them all to HValues in the end! + + -- None of the Ids should be of unboxed type, because we + -- cast them all to HValues in the end! mapM_ bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ; traceTc "tcs 1" empty ; @@ -1210,37 +1191,37 @@ tcRnStmt hsc_env ictxt rdr_stmt they are inaccessible but might, I suppose, cause a space leak if we leave them there. However, with Template Haskell they aren't necessarily inaccessible. Consider this GHCi session - Prelude> let f n = n * 2 :: Int - Prelude> fName <- runQ [| f |] - Prelude> $(return $ AppE fName (LitE (IntegerL 7))) - 14 - Prelude> let f n = n * 3 :: Int - Prelude> $(return $ AppE fName (LitE (IntegerL 7))) + Prelude> let f n = n * 2 :: Int + Prelude> fName <- runQ [| f |] + Prelude> $(return $ AppE fName (LitE (IntegerL 7))) + 14 + Prelude> let f n = n * 3 :: Int + Prelude> $(return $ AppE fName (LitE (IntegerL 7))) In the last line we use 'fName', which resolves to the *first* 'f' in scope. If we delete it from the type env, GHCi crashes because it doesn't expect that. - + Hence this code is commented out -------------------------------------------------- -} - dumpOptTcRn Opt_D_dump_tc - (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, - text "Typechecked expr" <+> ppr zonked_expr]) ; + dumpOptTcRn Opt_D_dump_tc + (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, + text "Typechecked expr" <+> ppr zonked_expr]) ; return (global_ids, zonked_expr) } where bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"), - nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) + nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) \end{code} Note [Interactively-bound Ids in GHCi] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Ids bound by previous Stmts in GHCi are currently - a) GlobalIds + a) GlobalIds b) with an Internal Name (not External) - c) and a tidied type + c) and a tidied type (a) They must be GlobalIds (not LocalIds) otherwise when we come to compile an expression using these ids later, the byte code @@ -1248,163 +1229,189 @@ The Ids bound by previous Stmts in GHCi are currently global. (b) They retain their Internal names becuase we don't have a suitable - Module to name them with. We could revisit this choice. + Module to name them with. We could revisit this choice. - (c) Their types are tidied. This is important, because :info may ask + (c) Their types are tidied. This is important, because :info may ask to look at them, and :info expects the things it looks up to have tidy types - -------------------------------------------------------------------------- - Typechecking Stmts in GHCi + Typechecking Stmts in GHCi Here is the grand plan, implemented in tcUserStmt - What you type The IO [HValue] that hscStmt returns - ------------- ------------------------------------ - let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] + What you type The IO [HValue] that hscStmt returns + ------------- ------------------------------------ + let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] - pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] + pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] - expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it] - [NB: result not printed] bindings: [it] - - expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it] - result showable) bindings: [it] + expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it] + [NB: result not printed] bindings: [it] - expr (of non-IO type, - result not showable) ==> error + expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it] + result showable) bindings: [it] + expr (of non-IO type, + result not showable) ==> error \begin{code} ---------------------------- + +-- | A plan is an attempt to lift some code into the IO monad. type PlanResult = ([Id], LHsExpr Id) type Plan = TcM PlanResult -runPlans :: [Plan] -> TcM PlanResult --- Try the plans in order. If one fails (by raising an exn), try the next. +-- | Try the plans in order. If one fails (by raising an exn), try the next. -- If one succeeds, take it. +runPlans :: [Plan] -> TcM PlanResult runPlans [] = panic "runPlans" runPlans [p] = p runPlans (p:ps) = tryTcLIE_ (runPlans ps) p --------------------- -mkPlan :: LStmt Name -> TcM PlanResult -mkPlan (L loc (ExprStmt expr _ _ _)) -- An expression typed at the prompt - = do { uniq <- newUnique -- is treated very specially +-- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the +-- GHCi 'environemnt'. +-- +-- By 'lift' and 'environment we mean that the code is changed to execute +-- properly in an IO monad. See Note [Interactively-bound Ids in GHCi] above +-- for more details. We do this lifting by trying different ways ('plans') of +-- lifting the code into the IO monad and type checking each plan until one +-- succeeds. +tcUserStmt :: LStmt RdrName -> TcM PlanResult + +-- An expression typed at the prompt is treated very specially +tcUserStmt (L loc (ExprStmt expr _ _ _)) + = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) + -- Don't try to typecheck if the renamer fails! + ; uniq <- newUnique ; let fresh_it = itName uniq loc - the_bind = L loc $ mkTopFunBind (L loc fresh_it) matches - matches = [mkMatch [] expr emptyLocalBinds] - let_stmt = L loc $ LetStmt $ HsValBinds $ + matches = [mkMatch [] rn_expr emptyLocalBinds] + -- [it = expr] + the_bind = L loc $ (mkTopFunBind (L loc fresh_it) matches) { bind_fvs = fvs } + -- Care here! In GHCi the expression might have + -- free variables, and they in turn may have free type variables + -- (if we are at a breakpoint, say). We must put those free vars + + + -- [let it = expr] + let_stmt = L loc $ LetStmt $ HsValBinds $ ValBindsOut [(NonRecursive,unitBag the_bind)] [] - bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it)) expr - (HsVar bindIOName) noSyntaxExpr - print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it)) - (HsVar thenIOName) noSyntaxExpr placeHolderType - - -- The plans are: - -- [it <- e; print it] but not if it::() - -- [it <- e] - -- [let it = e; print it] - ; runPlans [ -- Plan A - do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] - ; it_ty <- zonkTcType (idType it_id) - ; when (isUnitTy it_ty) failM - ; return stuff }, - - -- Plan B; a naked bind statment - tcGhciStmts [bind_stmt], - - -- Plan C; check that the let-binding is typeable all by itself. - -- If not, fail; if so, try to print it. - -- The two-step process avoids getting two errors: one from - -- the expression itself, and one from the 'print it' part - -- This two-step story is very clunky, alas - do { _ <- checkNoErrs (tcGhciStmts [let_stmt]) - --- checkNoErrs defeats the error recovery of let-bindings - ; tcGhciStmts [let_stmt, print_it] } - ]} - -mkPlan stmt@(L loc (BindStmt {})) - | [v] <- collectLStmtBinders stmt -- One binder, for a bind stmt - = do { let print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) - (HsVar thenIOName) noSyntaxExpr placeHolderType - - ; print_bind_result <- doptM Opt_PrintBindResult - ; let print_plan = do - { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v] - ; v_ty <- zonkTcType (idType v_id) - ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM - ; return stuff } - - -- The plans are: - -- [stmt; print v] but not if v::() - -- [stmt] - ; runPlans ((if print_bind_result then [print_plan] else []) ++ - [tcGhciStmts [stmt]]) - } - -mkPlan stmt - = tcGhciStmts [stmt] - ---------------------------- + -- [it <- e] + bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it)) rn_expr + (HsVar bindIOName) noSyntaxExpr + -- [; print it] + print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it)) + (HsVar thenIOName) noSyntaxExpr placeHolderType + + -- The plans are: + -- A. [it <- e; print it] but not if it::() + -- B. [it <- e] + -- C. [let it = e; print it] + ; runPlans [ -- Plan A + do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] + ; it_ty <- zonkTcType (idType it_id) + ; when (isUnitTy it_ty) failM + ; return stuff }, + + -- Plan B; a naked bind statment + tcGhciStmts [bind_stmt], + + -- Plan C; check that the let-binding is typeable all by itself. + -- If not, fail; if so, try to print it. + -- The two-step process avoids getting two errors: one from + -- the expression itself, and one from the 'print it' part + -- This two-step story is very clunky, alas + do { _ <- checkNoErrs (tcGhciStmts [let_stmt]) + --- checkNoErrs defeats the error recovery of let-bindings + ; tcGhciStmts [let_stmt, print_it] } + ]} + +tcUserStmt rdr_stmt@(L loc _) + = do { (([rn_stmt], _), fvs) <- checkNoErrs $ + rnStmts GhciStmt [rdr_stmt] $ \_ -> + return ((), emptyFVs) ; + -- Don't try to typecheck if the renamer fails! + ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) + ; rnDump (ppr rn_stmt) ; + + ; opt_pr_flag <- doptM Opt_PrintBindResult + ; let print_result_plan + | opt_pr_flag -- The flag says "print result" + , [v] <- collectLStmtBinders rn_stmt -- One binder + = [mk_print_result_plan rn_stmt v] + | otherwise = [] + + -- The plans are: + -- [stmt; print v] if one binder and not v::() + -- [stmt] otherwise + ; runPlans (print_result_plan ++ [tcGhciStmts [rn_stmt]]) } + where + mk_print_result_plan rn_stmt v + = do { stuff@([v_id], _) <- tcGhciStmts [rn_stmt, print_v] + ; v_ty <- zonkTcType (idType v_id) + ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM + ; return stuff } + where + print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) + (HsVar thenIOName) noSyntaxExpr placeHolderType + +-- | Typecheck the statements given and then return the results of the +-- statement in the form 'IO [()]'. tcGhciStmts :: [LStmt Name] -> TcM PlanResult tcGhciStmts stmts = do { ioTyCon <- tcLookupTyCon ioTyConName ; - ret_id <- tcLookupId returnIOName ; -- return @ IO - let { - ret_ty = mkListTy unitTy ; - io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; - tc_io_stmts stmts = tcStmtsAndThen GhciStmt tcDoStmt stmts io_ret_ty ; - names = collectLStmtsBinders stmts ; - } ; - - -- OK, we're ready to typecheck the stmts - traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ; - ((tc_stmts, ids), lie) <- captureConstraints $ - tc_io_stmts stmts $ \ _ -> - mapM tcLookupId names ; - -- Look up the names right in the middle, - -- where they will all be in scope - - -- Simplify the context - traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ; - const_binds <- checkNoErrs (simplifyInteractive lie) ; - -- checkNoErrs ensures that the plan fails if context redn fails - - traceTc "TcRnDriver.tcGhciStmts: done" empty ; + ret_id <- tcLookupId returnIOName ; -- return @ IO + let { + ret_ty = mkListTy unitTy ; + io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; + tc_io_stmts = tcStmtsAndThen GhciStmt tcDoStmt stmts io_ret_ty ; + names = collectLStmtsBinders stmts ; + } ; + + -- OK, we're ready to typecheck the stmts + traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ; + ((tc_stmts, ids), lie) <- captureConstraints $ + tc_io_stmts $ \ _ -> + mapM tcLookupId names ; + -- Look up the names right in the middle, + -- where they will all be in scope + + -- Simplify the context + traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ; + const_binds <- checkNoErrs (simplifyInteractive lie) ; + -- checkNoErrs ensures that the plan fails if context redn fails + + traceTc "TcRnDriver.tcGhciStmts: done" empty ; let { -- mk_return builds the expression - -- returnIO @ [()] [coerce () x, .., coerce () z] - -- - -- Despite the inconvenience of building the type applications etc, - -- this *has* to be done in type-annotated post-typecheck form - -- because we are going to return a list of *polymorphic* values - -- coerced to type (). If we built a *source* stmt - -- return [coerce x, ..., coerce z] - -- then the type checker would instantiate x..z, and we wouldn't - -- get their *polymorphic* values. (And we'd get ambiguity errs - -- if they were overloaded, since they aren't applied to anything.) - ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) - (noLoc $ ExplicitList unitTy (map mk_item ids)) ; - mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy]) - (nlHsVar id) ; - stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] + -- returnIO @ [()] [coerce () x, .., coerce () z] + -- + -- Despite the inconvenience of building the type applications etc, + -- this *has* to be done in type-annotated post-typecheck form + -- because we are going to return a list of *polymorphic* values + -- coerced to type (). If we built a *source* stmt + -- return [coerce x, ..., coerce z] + -- then the type checker would instantiate x..z, and we wouldn't + -- get their *polymorphic* values. (And we'd get ambiguity errs + -- if they were overloaded, since they aren't applied to anything.) + ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) + (noLoc $ ExplicitList unitTy (map mk_item ids)) ; + mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy]) + (nlHsVar id) ; + stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] } ; - return (ids, mkHsDictLet (EvBinds const_binds) $ - noLoc (HsDo GhciStmt stmts io_ret_ty)) + return (ids, mkHsDictLet (EvBinds const_binds) $ + noLoc (HsDo GhciStmt stmts io_ret_ty)) } \end{code} - tcRnExpr just finds the type of an expression \begin{code} tcRnExpr :: HscEnv -> InteractiveContext - -> LHsExpr RdrName - -> IO (Messages, Maybe Type) + -> LHsExpr RdrName + -> IO (Messages, Maybe Type) tcRnExpr hsc_env ictxt rdr_expr = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { @@ -1412,12 +1419,12 @@ tcRnExpr hsc_env ictxt rdr_expr (rn_expr, _fvs) <- rnLExpr rdr_expr ; failIfErrsM ; - -- Now typecheck the expression; - -- it might have a rank-2 type (e.g. :t runST) + -- Now typecheck the expression; + -- it might have a rank-2 type (e.g. :t runST) uniq <- newUnique ; let { fresh_it = itName uniq (getLoc rdr_expr) } ; - ((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ; - ((qtvs, dicts, _, _), lie_top) <- captureConstraints $ + ((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ; + ((qtvs, dicts, _, _), lie_top) <- captureConstraints $ {-# SCC "simplifyInfer" #-} simplifyInfer True {- Free vars are closed -} False {- No MR for now -} @@ -1431,10 +1438,10 @@ tcRnExpr hsc_env ictxt rdr_expr -------------------------- tcRnImportDecls :: HscEnv - -> [LImportDecl RdrName] - -> IO (Messages, Maybe GlobalRdrEnv) + -> [LImportDecl RdrName] + -> IO (Messages, Maybe GlobalRdrEnv) tcRnImportDecls hsc_env import_decls - = initTcPrintErrors hsc_env iNTERACTIVE $ + = initTcPrintErrors hsc_env iNTERACTIVE $ do { gbl_env <- tcRnImports hsc_env iNTERACTIVE import_decls ; return (tcg_rdr_env gbl_env) } \end{code} @@ -1443,28 +1450,28 @@ tcRnType just finds the kind of a type \begin{code} tcRnType :: HscEnv - -> InteractiveContext - -> Bool -- Normalise the returned type - -> LHsType RdrName - -> IO (Messages, Maybe (Type, Kind)) + -> InteractiveContext + -> Bool -- Normalise the returned type + -> LHsType RdrName + -> IO (Messages, Maybe (Type, Kind)) tcRnType hsc_env ictxt normalise rdr_type - = initTcPrintErrors hsc_env iNTERACTIVE $ + = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { rn_type <- rnLHsType GHCiCtx rdr_type ; failIfErrsM ; - -- Now kind-check the type - -- It can have any rank or kind + -- Now kind-check the type + -- It can have any rank or kind ty <- tcHsSigType GhciCtxt rn_type ; - ty' <- if normalise - then do { fam_envs <- tcGetFamInstEnvs + ty' <- if normalise + then do { fam_envs <- tcGetFamInstEnvs ; return (snd (normaliseType fam_envs ty)) } - -- normaliseType returns a coercion - -- which we discard + -- normaliseType returns a coercion + -- which we discard else return ty ; - + return (ty', typeKind ty) } @@ -1473,16 +1480,16 @@ tcRnType hsc_env ictxt normalise rdr_type tcRnDeclsi exists to allow class, data, and other declarations in GHCi. \begin{code} -tcRnDeclsi :: HscEnv +tcRnDeclsi :: HscEnv -> InteractiveContext - -> [LHsDecl RdrName] - -> IO (Messages, Maybe TcGblEnv) + -> [LHsDecl RdrName] + -> IO (Messages, Maybe TcGblEnv) tcRnDeclsi hsc_env ictxt local_decls = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do - - ((tcg_env, tclcl_env), lie) <- + + ((tcg_env, tclcl_env), lie) <- captureConstraints $ tc_rn_src_decls emptyModDetails local_decls setEnvs (tcg_env, tclcl_env) $ do @@ -1498,16 +1505,16 @@ tcRnDeclsi hsc_env ictxt local_decls = tcg_fords = fords } = tcg_env all_ev_binds = cur_ev_binds `unionBags` new_ev_binds - (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') + (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') <- zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords - + let --global_ids = map globaliseAndTidyId bind_ids final_type_env = extendTypeEnvWithIds type_env bind_ids --global_ids tcg_env' = tcg_env { tcg_binds = binds', tcg_ev_binds = ev_binds', tcg_imp_specs = imp_specs', - tcg_rules = rules', - tcg_vects = vects', + tcg_rules = rules', + tcg_vects = vects', tcg_fords = fords' } tcg_env'' <- setGlobalTypeEnv tcg_env' final_type_env @@ -1520,9 +1527,9 @@ tcRnDeclsi hsc_env ictxt local_decls = %************************************************************************ -%* * - More GHCi stuff, to do with browsing and getting info -%* * +%* * + More GHCi stuff, to do with browsing and getting info +%* * %************************************************************************ \begin{code} @@ -1539,7 +1546,7 @@ getModuleInterface hsc_env mod tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Messages, Maybe [Name]) tcRnLookupRdrName hsc_env rdr_name = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext hsc_env (hsc_IC hsc_env) $ + setInteractiveContext hsc_env (hsc_IC hsc_env) $ lookup_rdr_name rdr_name lookup_rdr_name :: RdrName -> TcM [Name] @@ -1554,7 +1561,7 @@ lookup_rdr_name rdr_name = do traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]) -- The successful lookups will be (Just name) - let (warns_s, good_names) = unzip [ (msgs, name) + let (warns_s, good_names) = unzip [ (msgs, name) | (msgs, Just name) <- results] errs_s = [msgs | (msgs, Nothing) <- results] @@ -1564,9 +1571,9 @@ lookup_rdr_name rdr_name = do -- No lookup succeeded, so -- pick the first error message and report it -- ToDo: If one of the errors is "could be Foo.X or Baz.X", - -- while the other is "X is not in scope", - -- we definitely want the former; but we might pick the latter - else mapM_ addMessages warns_s + -- while the other is "X is not in scope", + -- we definitely want the former; but we might pick the latter + else mapM_ addMessages warns_s -- Add deprecation warnings return good_names @@ -1579,7 +1586,7 @@ tcRnLookupName hsc_env name tcRnLookupName' name -- To look up a name we have to look in the local environment (tcl_lcl) --- as well as the global environment, which is what tcLookup does. +-- as well as the global environment, which is what tcLookup does. -- But we also want a TyThing, so we have to convert: tcRnLookupName' :: Name -> TcRn TyThing @@ -1598,8 +1605,8 @@ tcRnGetInfo :: HscEnv -- -- Look up a RdrName and return all the TyThings it might be -- A capitalised RdrName is given to us in the DataName namespace, --- but we want to treat it as *both* a data constructor --- *and* as a type or class constructor; +-- but we want to treat it as *both* a data constructor +-- *and* as a type or class constructor; -- hence the call to dataTcOccs, and we return up to two results tcRnGetInfo hsc_env name = initTcPrintErrors hsc_env iNTERACTIVE $ @@ -1612,10 +1619,10 @@ tcRnGetInfo' hsc_env name = let ictxt = hsc_IC hsc_env in setInteractiveContext hsc_env ictxt $ do - -- Load the interface for all unqualified types and classes - -- That way we will find all the instance declarations - -- (Packages have not orphan modules, and we assume that - -- in the home package all relevant modules are loaded.) + -- Load the interface for all unqualified types and classes + -- That way we will find all the instance declarations + -- (Packages have not orphan modules, and we assume that + -- in the home package all relevant modules are loaded.) loadUnqualIfaces hsc_env ictxt thing <- tcRnLookupName' name @@ -1631,22 +1638,22 @@ lookupInsts (ATyCon tc) | otherwise = do { (pkg_ie, home_ie) <- tcGetInstEnvs - -- Load all instances for all classes that are - -- in the type environment (which are all the ones - -- we've seen in any interface file so far) - ; return [ ispec -- Search all - | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie - , let dfun = instanceDFunId ispec - , relevant dfun ] } + -- Load all instances for all classes that are + -- in the type environment (which are all the ones + -- we've seen in any interface file so far) + ; return [ ispec -- Search all + | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie + , let dfun = instanceDFunId ispec + , relevant dfun ] } where relevant df = tc_name `elemNameSet` orphNamesOfDFunHead (idType df) - tc_name = tyConName tc + tc_name = tyConName tc lookupInsts _ = return [] loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM () -- Load the interface for everything that is in scope unqualified --- This is so that we can accurately report the instances for +-- This is so that we can accurately report the instances for -- something loadUnqualIfaces hsc_env ictxt = initIfaceTcRn $ do @@ -1656,18 +1663,18 @@ loadUnqualIfaces hsc_env ictxt unqual_mods = filter ((/= this_pkg) . modulePackageId) [ nameModule name - | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt), - let name = gre_name gre, + | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt), + let name = gre_name gre, not (isInternalName name), - isTcOcc (nameOccName name), -- Types and classes only - unQualOK gre ] -- In scope unqualified + isTcOcc (nameOccName name), -- Types and classes only + unQualOK gre ] -- In scope unqualified doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified") \end{code} %************************************************************************ -%* * - Degugging output -%* * +%* * + Degugging output +%* * %************************************************************************ \begin{code} @@ -1679,60 +1686,60 @@ tcDump :: TcGblEnv -> TcRn () tcDump env = do { dflags <- getDynFlags ; - -- Dump short output if -ddump-types or -ddump-tc - when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) - (dumpTcRn short_dump) ; + -- Dump short output if -ddump-types or -ddump-tc + when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) + (dumpTcRn short_dump) ; - -- Dump bindings if -ddump-tc - dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) + -- Dump bindings if -ddump-tc + dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) } where short_dump = pprTcGblEnv env full_dump = pprLHsBinds (tcg_binds env) - -- NB: foreign x-d's have undefined's in their types; - -- hence can't show the tc_fords + -- 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)) ; + 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) } + -- 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, - tcg_insts = insts, - tcg_fam_insts = fam_insts, +pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, + tcg_insts = insts, + tcg_fam_insts = fam_insts, tcg_rules = rules, tcg_vects = vects, tcg_imports = imports }) = vcat [ ppr_types insts type_env - , ppr_tycons fam_insts type_env + , ppr_tycons fam_insts type_env , ppr_insts insts , ppr_fam_insts fam_insts , vcat (map ppr rules) , vcat (map ppr vects) - , ptext (sLit "Dependent modules:") <+> + , ptext (sLit "Dependent modules:") <+> ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports)) - , ptext (sLit "Dependent packages:") <+> - ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)] - where -- The two uses of sortBy are just to reduce unnecessary - -- wobbling in testsuite output + , ptext (sLit "Dependent packages:") <+> + ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)] + where -- The two uses of sortBy are just to reduce unnecessary + -- wobbling in testsuite output cmp_mp (mod_name1, is_boot1) (mod_name2, is_boot2) - = (mod_name1 `stableModuleNameCmp` mod_name2) - `thenCmp` - (is_boot1 `compare` is_boot2) + = (mod_name1 `stableModuleNameCmp` mod_name2) + `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_rules rules ] ppr_types :: [ClsInst] -> TypeEnv -> SDoc ppr_types insts type_env @@ -1741,27 +1748,27 @@ ppr_types insts type_env dfun_ids = map instanceDFunId insts ids = [id | id <- typeEnvIds type_env, want_sig id] want_sig id | opt_PprStyle_Debug = True - | otherwise = isLocalId id && - isExternalName (idName id) && - not (id `elem` dfun_ids) - -- isLocalId ignores data constructors, records selectors etc. - -- The isExternalName ignores local dictionary and method bindings - -- that the type checker has invented. Top-level user-defined things - -- have External names. + | otherwise = isLocalId id && + isExternalName (idName id) && + not (id `elem` dfun_ids) + -- isLocalId ignores data constructors, records selectors etc. + -- The isExternalName ignores local dictionary and method bindings + -- that the type checker has invented. Top-level user-defined things + -- have External names. ppr_tycons :: [FamInst] -> TypeEnv -> SDoc ppr_tycons fam_insts type_env = vcat [ text "TYPE CONSTRUCTORS" , nest 2 (ppr_tydecls tycons) - , text "COERCION AXIOMS" + , text "COERCION AXIOMS" , nest 2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ] where fi_tycons = famInstsRepTyCons fam_insts tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon] want_tycon tycon | opt_PprStyle_Debug = True - | otherwise = not (isImplicitTyCon tycon) && - isExternalName (tyConName tycon) && - not (tycon `elem` fi_tycons) + | otherwise = not (isImplicitTyCon tycon) && + isExternalName (tyConName tycon) && + not (tycon `elem` fi_tycons) ppr_insts :: [ClsInst] -> SDoc ppr_insts [] = empty @@ -1769,12 +1776,12 @@ ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs) ppr_fam_insts :: [FamInst] -> SDoc ppr_fam_insts [] = empty -ppr_fam_insts fam_insts = +ppr_fam_insts fam_insts = text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts) ppr_sigs :: [Var] -> SDoc ppr_sigs ids - -- Print type signatures; sort by OccName + -- Print type signatures; sort by OccName = vcat (map ppr_sig (sortLe le_sig ids)) where le_sig id1 id2 = getOccName id1 <= getOccName id2 @@ -1782,7 +1789,7 @@ ppr_sigs ids ppr_tydecls :: [TyCon] -> SDoc ppr_tydecls tycons - -- Print type constructor info; sort by OccName + -- Print type constructor info; sort by OccName = vcat (map ppr_tycon (sortLe le_sig tycons)) where le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2 @@ -1791,6 +1798,6 @@ ppr_tydecls tycons ppr_rules :: [CoreRule] -> SDoc ppr_rules [] = empty ppr_rules rs = vcat [ptext (sLit "{-# RULES"), - nest 2 (pprRules rs), - ptext (sLit "#-}")] + nest 2 (pprRules rs), + ptext (sLit "#-}")] \end{code} diff --git a/compiler/typecheck/TcSplice.lhs-boot b/compiler/typecheck/TcSplice.lhs-boot index 5cb871a3a1..18a31b0b93 100644 --- a/compiler/typecheck/TcSplice.lhs-boot +++ b/compiler/typecheck/TcSplice.lhs-boot @@ -1,32 +1,25 @@ \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://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module TcSplice where -import HsSyn ( HsSplice, HsBracket, HsQuasiQuote, +import HsSyn ( HsSplice, HsBracket, HsQuasiQuote, HsExpr, HsType, LHsType, LHsExpr, LPat, LHsDecl ) -import Name ( Name ) -import NameSet ( FreeVars ) -import RdrName ( RdrName ) +import Name ( Name ) +import NameSet ( FreeVars ) +import RdrName ( RdrName ) import TcRnTypes( TcM, TcId ) -import TcType ( TcRhoType, TcKind ) +import TcType ( TcRhoType, TcKind ) import Annotations ( Annotation, CoreAnnTarget ) import qualified Language.Haskell.TH as TH tcSpliceExpr :: HsSplice Name - -> TcRhoType - -> TcM (HsExpr TcId) + -> TcRhoType + -> TcM (HsExpr TcId) kcSpliceType :: HsSplice Name -> FreeVars - -> TcM (HsType Name, TcKind) + -> TcM (HsType Name, TcKind) tcBracket :: HsBracket Name - -> TcRhoType - -> TcM (LHsExpr TcId) + -> TcRhoType + -> TcM (LHsExpr TcId) tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 2c28655ccf..95d7d236a7 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -101,13 +101,10 @@ tcTyAndClassDecls :: ModDetails -> TcM TcGblEnv -- Input env extended by types and classes -- and their implicit Ids,DataCons -- Fails if there are any errors -tcTyAndClassDecls boot_details decls_s - = checkNoErrs $ do -- The code recovers internally, but if anything gave rise to +tcTyAndClassDecls boot_details tyclds_s + = checkNoErrs $ -- The code recovers internally, but if anything gave rise to -- an error we'd better stop now, to avoid a cascade - { let tyclds_s = map (filterOut (isFamInstDecl . unLoc)) decls_s - -- Remove family instance decls altogether - -- They are dealt with by TcInstDcls - ; fold_env tyclds_s } -- type check each group in dependency order folding the global env + fold_env tyclds_s -- type check each group in dependency order folding the global env where fold_env :: [TyClGroup Name] -> TcM TcGblEnv fold_env [] = getGblEnv @@ -379,7 +376,7 @@ kcTyClDecl decl@(TyFamily {}) = kcFamilyDecl [] decl -- the empty list signals a toplevel decl kcTyClDecl decl@(TyData {}) - = ASSERT( not . isFamInstDecl $ decl ) -- must not be a family instance + = ASSERT2( not . isFamInstDecl $ decl, ppr decl ) -- must not be a family instance kcTyClDeclBody decl $ \_ -> kcDataDecl decl kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats}) diff --git a/compiler/typecheck/TcUnify.lhs-boot b/compiler/typecheck/TcUnify.lhs-boot index f53b658f40..4d07229963 100644 --- a/compiler/typecheck/TcUnify.lhs-boot +++ b/compiler/typecheck/TcUnify.lhs-boot @@ -1,11 +1,4 @@ \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://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module TcUnify where import TcType ( TcTauType, TcKind, Type, Kind ) import VarEnv ( TidyEnv ) diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index b1ab2f6101..7df64c42d2 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -20,8 +20,8 @@ module FamInstEnv ( mkSynFamInst, mkDataFamInst, mkImportedFamInst, FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, - extendFamInstEnv, overwriteFamInstEnv, extendFamInstEnvList, - famInstEnvElts, familyInstances, + extendFamInstEnv, deleteFromFamInstEnv, extendFamInstEnvList, + identicalFamInst, famInstEnvElts, familyInstances, lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvConflicts', @@ -38,6 +38,7 @@ import TypeRep import TyCon import Coercion import VarSet +import VarEnv import Name import UniqFM import Outputable @@ -325,41 +326,26 @@ extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs}) (ins_tyvar || tyvar) ins_tyvar = not (any isJust mb_tcs) -overwriteFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv -overwriteFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs}) - = addToUFM_C add inst_env cls_nm (FamIE [ins_item] ins_tyvar) +deleteFromFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv +deleteFromFamInstEnv inst_env fam_inst@(FamInst {fi_fam = fam_nm}) + = adjustUFM adjust inst_env fam_nm + where + adjust :: FamilyInstEnv -> FamilyInstEnv + adjust (FamIE items tyvars) + = FamIE (filterOut (identicalFamInst fam_inst) items) tyvars + +identicalFamInst :: FamInst -> FamInst -> Bool +-- Same LHS, *and* the instance is defined in the same module +-- Used for overriding in GHCi +identicalFamInst (FamInst { fi_axiom = ax1 }) (FamInst { fi_axiom = ax2 }) + = nameModule (coAxiomName ax1) == nameModule (coAxiomName ax2) + && eqTypeX rn_env (coAxiomLHS ax1) (coAxiomLHS ax2) where - add (FamIE items tyvar) _ = FamIE (replaceFInst items) - (ins_tyvar || tyvar) - ins_tyvar = not (any isJust mb_tcs) - match _ tpl_tvs tpl_tys tys = tcMatchTys tpl_tvs tpl_tys tys - - inst_axiom = famInstAxiom ins_item - (fam, tys) = coAxiomSplitLHS inst_axiom - arity = tyConArity fam - n_tys = length tys - match_tys - | arity > n_tys = take arity tys - | otherwise = tys - rough_tcs = roughMatchTcs match_tys - - replaceFInst [] = [ins_item] - replaceFInst (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, - fi_tys = tpl_tys }) : rest) - -- Fast check for no match, uses the "rough match" fields - | instanceCantMatch rough_tcs mb_tcs - = item : replaceFInst rest - - -- Proper check - | Just _ <- match item tpl_tvs tpl_tys match_tys - = ins_item : rest - - -- No match => try next - | otherwise - = item : replaceFInst rest - - - + tvs1 = coAxiomTyVars ax1 + tvs2 = coAxiomTyVars ax2 + rn_env = ASSERT( equalLength tvs1 tvs2 ) + rnBndrs2 (mkRnEnv2 emptyInScopeSet) tvs1 tvs2 + \end{code} %************************************************************************ diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs index 0acc967507..e129cc60bc 100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@ -49,10 +49,7 @@ module Kind ( -- ** Functions on variables isKiVar, splitKiTyVars, partitionKiTyVars, - kiVarsOfKind, kiVarsOfKinds, - - -- ** Promotion related functions - promoteType, isPromotableType, isPromotableKind, + kiVarsOfKind, kiVarsOfKinds ) where @@ -252,8 +249,10 @@ isSubKind' duringTc k1@(TyConApp kc1 k1s) k2@(TyConApp kc2 k2s) | isSuperKindTyCon kc1 || isSuperKindTyCon kc2 -- handles BOX - = ASSERT2( isSuperKindTyCon kc2 && null k1s && null k2s, ppr kc1 <+> ppr kc2 ) - True + = WARN( not (isSuperKindTyCon kc2 && isSuperKindTyCon kc2 + && null k1s && null k2s), + ppr kc1 <+> ppr kc2 ) + kc1 == kc2 | otherwise = -- handles usual kinds (*, #, (#), etc.) ASSERT2( null k1s && null k2s, ppr k1 <+> ppr k2 ) @@ -314,54 +313,4 @@ kiVarsOfKind = tyVarsOfType kiVarsOfKinds :: [Kind] -> VarSet kiVarsOfKinds = tyVarsOfTypes - --- Datatype promotion -isPromotableType :: Type -> Bool -isPromotableType = go emptyVarSet - where - go vars (TyConApp tc tys) = ASSERT( not (isPromotedDataTyCon tc) ) all (go vars) tys - go vars (FunTy arg res) = all (go vars) [arg,res] - go vars (TyVarTy tvar) = tvar `elemVarSet` vars - go vars (ForAllTy tvar ty) = isPromotableTyVar tvar && go (vars `extendVarSet` tvar) ty - go _ _ = panic "isPromotableType" -- argument was not kind-shaped - -isPromotableTyVar :: TyVar -> Bool -isPromotableTyVar = isLiftedTypeKind . varType - --- | Promotes a type to a kind. Assumes the argument is promotable. -promoteType :: Type -> Kind -promoteType (TyConApp tc tys) = mkTyConApp (mkPromotedTypeTyCon tc) - (map promoteType tys) - -- T t1 .. tn ~~> 'T k1 .. kn where ti ~~> ki -promoteType (FunTy arg res) = mkArrowKind (promoteType arg) (promoteType res) - -- t1 -> t2 ~~> k1 -> k2 where ti ~~> ki -promoteType (TyVarTy tvar) = mkTyVarTy (promoteTyVar tvar) - -- a :: * ~~> a :: BOX -promoteType (ForAllTy tvar ty) = ForAllTy (promoteTyVar tvar) (promoteType ty) - -- forall (a :: *). t ~~> forall (a :: BOX). k where t ~~> k -promoteType _ = panic "promoteType" -- argument was not kind-shaped - -promoteTyVar :: TyVar -> KindVar -promoteTyVar tvar = mkKindVar (tyVarName tvar) tySuperKind - --- If kind is [ *^n -> * ] returns [ Just n ], else returns [ Nothing ] -isPromotableKind :: Kind -> Maybe Int -isPromotableKind kind = - let (args, res) = splitKindFunTys kind in - if all isLiftedTypeKind (res:args) - then Just $ length args - else Nothing - -{- Note [Promoting a Type to a Kind] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We only promote the followings. -- Type variables: a -- Fully applied arrow types: tau -> sigma -- Fully applied type constructors of kind: - n >= 0 - /-----------\ - * -> ... -> * -> * -- Polymorphic types over type variables of kind star: - forall (a::*). tau --} \end{code} diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index f5c05677e1..e2c192f435 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -39,7 +39,7 @@ module TyCon( mkSuperKindTyCon, mkForeignTyCon, mkPromotedDataTyCon, - mkPromotedTypeTyCon, + mkPromotedTyCon, -- ** Predicates on TyCons isAlgTyCon, @@ -94,7 +94,7 @@ module TyCon( #include "HsVersions.h" import {-# SOURCE #-} TypeRep ( Kind, Type, PredType ) -import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon, dataConName ) +import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon ) import {-# SOURCE #-} IParam ( ipTyConName ) import Var @@ -410,6 +410,7 @@ data TyCon | PromotedDataTyCon { -- See Note [Promoted data constructors] tyConUnique :: Unique, -- ^ Same Unique as the data constructor tyConName :: Name, -- ^ Same Name as the data constructor + tyConArity :: Arity, tc_kind :: Kind, -- ^ Translated type of the data constructor dataCon :: DataCon -- ^ Corresponding data constructor } @@ -419,6 +420,7 @@ data TyCon tyConUnique :: Unique, -- ^ Same Unique as the type constructor tyConName :: Name, -- ^ Same Name as the type constructor tyConArity :: Arity, -- ^ n if ty_con :: * -> ... -> * n times + tc_kind :: Kind, -- ^ Always tySuperKind ty_con :: TyCon -- ^ Corresponding type constructor } @@ -961,25 +963,30 @@ mkSuperKindTyCon name } -- | Create a promoted data constructor 'TyCon' -mkPromotedDataTyCon :: DataCon -> Name -> Unique -> Kind -> TyCon -mkPromotedDataTyCon con name unique kind +-- Somewhat dodgily, we give it the same Name +-- as the data constructor itself +mkPromotedDataTyCon :: DataCon -> Name -> Unique -> Kind -> Arity -> TyCon +mkPromotedDataTyCon con name unique kind arity = PromotedDataTyCon { - tyConName = name, + tyConName = name, tyConUnique = unique, - tc_kind = kind, - dataCon = con + tyConArity = arity, + tc_kind = kind, + dataCon = con } -- | Create a promoted type constructor 'TyCon' -mkPromotedTypeTyCon :: TyCon -> TyCon -mkPromotedTypeTyCon con +-- Somewhat dodgily, we give it the same Name +-- as the type constructor itself +mkPromotedTyCon :: TyCon -> Kind -> TyCon +mkPromotedTyCon tc kind = PromotedTypeTyCon { - tyConName = getName con, - tyConUnique = getUnique con, - tyConArity = tyConArity con, - ty_con = con + tyConName = getName tc, + tyConUnique = getUnique tc, + tyConArity = tyConArity tc, + tc_kind = kind, + ty_con = tc } - \end{code} \begin{code} @@ -1288,15 +1295,9 @@ expand tvs rhs tys \end{code} \begin{code} - tyConKind :: TyCon -> Kind -tyConKind (FunTyCon { tc_kind = k }) = k -tyConKind (AlgTyCon { tc_kind = k }) = k -tyConKind (TupleTyCon { tc_kind = k }) = k -tyConKind (SynTyCon { tc_kind = k }) = k -tyConKind (PrimTyCon { tc_kind = k }) = k -tyConKind (PromotedDataTyCon { tc_kind = k }) = k -tyConKind tc = pprPanic "tyConKind" (ppr tc) -- SuperKindTyCon and CoTyCon +tyConKind (SuperKindTyCon {}) = pprPanic "tyConKind" empty +tyConKind tc = tc_kind tc tyConHasKind :: TyCon -> Bool tyConHasKind (SuperKindTyCon {}) = False @@ -1499,8 +1500,7 @@ instance Uniquable TyCon where getUnique tc = tyConUnique tc instance Outputable TyCon where - ppr (PromotedDataTyCon {dataCon = dc}) = quote (ppr (dataConName dc)) - ppr tc = ppr (getName tc) + ppr tc = ppr (tyConName tc) instance NamedThing TyCon where getName = tyConName diff --git a/compiler/types/TyCon.lhs-boot b/compiler/types/TyCon.lhs-boot index dcf41dd545..d8ddff3f40 100644 --- a/compiler/types/TyCon.lhs-boot +++ b/compiler/types/TyCon.lhs-boot @@ -1,11 +1,4 @@ \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://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module TyCon where import Name (Name) @@ -13,9 +6,9 @@ import Unique (Unique) data TyCon -tyConName :: TyCon -> Name -tyConUnique :: TyCon -> Unique -isTupleTyCon :: TyCon -> Bool +tyConName :: TyCon -> Name +tyConUnique :: TyCon -> Unique +isTupleTyCon :: TyCon -> Bool isUnboxedTupleTyCon :: TyCon -> Bool -isFunTyCon :: TyCon -> Bool +isFunTyCon :: TyCon -> Bool \end{code} diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs index 7045f4b521..66f51e64e6 100644 --- a/compiler/utils/Platform.hs +++ b/compiler/utils/Platform.hs @@ -54,6 +54,7 @@ data OS | OSSolaris2 | OSMinGW32 | OSFreeBSD + | OSDragonFly | OSOpenBSD | OSNetBSD | OSKFreeBSD @@ -81,15 +82,16 @@ target32Bit p = platformWordSize p == 4 -- | This predicates tells us whether the OS supports ELF-like shared libraries. osElfTarget :: OS -> Bool -osElfTarget OSLinux = True -osElfTarget OSFreeBSD = True -osElfTarget OSOpenBSD = True -osElfTarget OSNetBSD = True -osElfTarget OSSolaris2 = True -osElfTarget OSDarwin = False -osElfTarget OSMinGW32 = False -osElfTarget OSKFreeBSD = True -osElfTarget OSUnknown = False +osElfTarget OSLinux = True +osElfTarget OSFreeBSD = True +osElfTarget OSDragonFly = True +osElfTarget OSOpenBSD = True +osElfTarget OSNetBSD = True +osElfTarget OSSolaris2 = True +osElfTarget OSDarwin = False +osElfTarget OSMinGW32 = False +osElfTarget OSKFreeBSD = True +osElfTarget OSUnknown = False -- Defaulting to False is safe; it means don't rely on any -- ELF-specific functionality. It is important to have a default for -- portability, otherwise we have to answer this question for every diff --git a/configure.ac b/configure.ac index bf7e84895a..7e2732c79c 100644 --- a/configure.ac +++ b/configure.ac @@ -333,19 +333,76 @@ then fi AC_SUBST([SplitObjsBroken]) +dnl ** Building a cross compiler? +dnl -------------------------------------------------------------- +BuildingCrossCompiler=NO +PortingCompiler=NO +CrossCompiling=NO +# If 'host' and 'target' differ, then this means we are building a cross-compiler. +if test "$host" != "$target" ; then + BuildingCrossCompiler=YES + CrossCompiling=YES + cross_compiling=yes # This tells configure that it can accept just 'target', + # otherwise you get + # configure: error: cannot run C compiled programs. + # If you meant to cross compile, use `--host'. +fi +if test "$build" != "$host" ; then + CrossCompiling=YES + PortingCompiler=YES +fi +# Note: cross_compiling is set to 'yes' in both 'port' and 'toolchain' cases +if ! test "$host" = "$target" -o "$host" = "$build" ; then + AC_MSG_ERROR([ +You've selected: + + build: $build (the architecture we're building on) + host: $host (the architecture the compiler we're building will execute on) + target: $target (the architecture the compiler we're building will produce code for) + +host must equal build or target. The two allowed cases are: + + --host=<arch> --target=<arch> to _port_ GHC to run on a foreign architecture + and produce code for that architecture + --target=<arch> to build a cross compiler _toolchain_ that runs + locally but produces code for a foreign + architecture +]) +fi +if test "$CrossCompiling" = "YES" +then + CrossCompilePrefix="${target}-" +else + CrossCompilePrefix="" +fi +TargetPlatformFull="${target}" +AC_SUBST(BuildingCrossCompiler) # 'toolchain' case +AC_SUBST(PortingCompiler) # 'port' case +AC_SUBST(CrossCompiling) # BuildingCrossCompiler OR PortingCompiler +AC_SUBST(CrossCompilePrefix) +AC_SUBST(TargetPlatformFull) +AC_ARG_WITH([alien], +[AC_HELP_STRING([--with-alien=ARG], + [Supply script for running target binaries locally when cross-compiling])], + [AlienScript="$withval"], + [AlienScript=""]) +AC_SUBST(AlienScript) + dnl ** Which gcc to use? dnl -------------------------------------------------------------- -FIND_GCC() +FIND_GCC([WhatGccIsCalled], [gcc], [gcc]) +CC="$WhatGccIsCalled" +export CC dnl ** Which ld to use? dnl -------------------------------------------------------------- -FP_ARG_WITH_PATH_GNU_PROG([LD], [ld]) +FP_ARG_WITH_PATH_GNU_PROG([LD], [ld], [ld]) LdCmd="$LD" AC_SUBST([LdCmd]) dnl ** Which nm to use? dnl -------------------------------------------------------------- -FP_ARG_WITH_PATH_GNU_PROG([NM], [nm]) +FP_ARG_WITH_PATH_GNU_PROG([NM], [nm], [nm]) NmCmd="$NM" AC_SUBST([NmCmd]) @@ -506,7 +563,7 @@ dnl ** check for dtrace (currently only implemented for Mac OS X) HaveDtrace=NO AC_PATH_PROG(DtraceCmd,dtrace) if test -n "$DtraceCmd"; then - if test "x$TargetOS_CPP-$TargetVendor_CPP" == "xdarwin-apple" -o "x$TargetOS_CPP-$TargetVendor_CPP" == "xsolaris2-unknown"; then + if test "x$TargetOS_CPP-$TargetVendor_CPP" = "xdarwin-apple" -o "x$TargetOS_CPP-$TargetVendor_CPP" = "xsolaris2-unknown"; then HaveDtrace=YES fi fi @@ -642,17 +699,19 @@ dnl ** check for more functions dnl ** The following have been verified to be used in ghc/, but might be used somewhere else, too. AC_CHECK_FUNCS([getclock getrusage gettimeofday setitimer siginterrupt sysconf times ctime_r sched_setaffinity setlocale]) -AC_TRY_RUN([ -#include <sys/types.h> -#include <sys/time.h> -int main(void) { - struct itimerval tval; - tval.it_value.tv_sec = 1; - tval.it_value.tv_usec = 0; - tval.it_interval = tval.it_value; - return setitimer(ITIMER_VIRTUAL, &tval, (void*)0) != 0; -} -],[AC_DEFINE([HAVE_SETITIMER_VIRTUAL], [1], [Define to 1 if setitimer accepts ITIMER_VIRTUAL, 0 else.])]) +if test "$cross_compiling" = "no" ; then + AC_TRY_RUN([ + #include <sys/types.h> + #include <sys/time.h> + int main(void) { + struct itimerval tval; + tval.it_value.tv_sec = 1; + tval.it_value.tv_usec = 0; + tval.it_interval = tval.it_value; + return setitimer(ITIMER_VIRTUAL, &tval, (void*)0) != 0; + } + ],[AC_DEFINE([HAVE_SETITIMER_VIRTUAL], [1], [Define to 1 if setitimer accepts ITIMER_VIRTUAL, 0 else.])]) +fi dnl ** On OS X 10.4 (at least), time.h doesn't declare ctime_r if dnl ** _POSIX_C_SOURCE is defined @@ -852,8 +911,11 @@ echo ["\ fi echo ["\ - Using GCC : $WhatGccIsCalled - which is version : $GccVersion + Using GCC : $WhatGccIsCalled + which is version : $GccVersion + Building a cross compiler : $BuildingCrossCompiler + Porting to foreign arch : $PortingCompiler + Alien script : $AlienScript ld : $LdCmd Happy : $HappyCmd ($HappyVersion) diff --git a/distrib/configure.ac.in b/distrib/configure.ac.in index 0037ff1ce8..8cb57c4509 100644 --- a/distrib/configure.ac.in +++ b/distrib/configure.ac.in @@ -21,6 +21,18 @@ FP_GMP bootstrap_target=`ghc/stage2/build/tmp/ghc-stage2 +RTS --info | grep '^ ,("Target platform"' | sed -e 's/.*, "//' -e 's/")//' | tr -d '\r'` FPTOOLS_SET_PLATFORM_VARS +BuildingCrossCompiler=NO +PortingCompiler=NO +CrossCompiling=NO +CrossCompilePrefix="" +TargetPlatformFull="${target}" + +AC_SUBST(BuildingCrossCompiler) # 'toolchain' case +AC_SUBST(PortingCompiler) # 'port' case +AC_SUBST(CrossCompiling) # BuildingCrossCompiler OR PortingCompiler +AC_SUBST(CrossCompilePrefix) +AC_SUBST(TargetPlatformFull) + # dnl ** Check Perl installation ** # @@ -51,7 +63,9 @@ XCODE_VERSION() dnl ** Which gcc to use? dnl -------------------------------------------------------------- -FIND_GCC() +FIND_GCC([WhatGccIsCalled], [gcc], [gcc]) +CC="$WhatGccIsCalled" +export CC FP_GCC_VERSION AC_PROG_CPP diff --git a/distrib/mkDocs/mkDocs b/distrib/mkDocs/mkDocs index 07faa3d647..4d030a5005 100644 --- a/distrib/mkDocs/mkDocs +++ b/distrib/mkDocs/mkDocs @@ -25,7 +25,7 @@ cd inst/share/doc/ghc/html/libraries mv ../../../../../../../windows/doc/html/libraries/Win32-* . sh gen_contents_index cd .. -for i in Cabal haddock libraries users_guide +for i in haddock libraries users_guide do tar -jcf ../../../../../../$i.html.tar.bz2 $i done diff --git a/distrib/remilestoning.pl b/distrib/remilestoning.pl new file mode 100644 index 0000000000..0207683e19 --- /dev/null +++ b/distrib/remilestoning.pl @@ -0,0 +1,118 @@ +#!/usr/bin/perl + +use strict; + +use DBI; + +# ===== Config: + +my $dbfile = "trac.db"; +my $milestone = "7.4.1"; +my $test = 0; + +# ===== Code: + +my $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile","","", {}); + +my %emailof; +my %ticketsfor; + +sub getUserAddress { + my $sth = $dbh->prepare("SELECT sid, value FROM session_attribute WHERE name = 'email'"); + $sth->execute(); + while (my $result = $sth->fetchrow_hashref("NAME_lc")) { + my $username = $result->{sid}; + my $email = $result->{value}; + if (defined($emailof{$username})) { + die "Two e-mail addresses found for $username"; + } + if ($email =~ /@/) { + $emailof{$username} = $email; + } + else { + # warn "The e-mail address $email for $username contains no @"; + } + } + $sth->finish; +} + +sub doTickets { + my $sth = $dbh->prepare("SELECT id, summary, reporter, cc FROM ticket WHERE milestone = ? AND status = 'new'"); + $sth->execute($milestone); + while (my $result = $sth->fetchrow_hashref("NAME_lc")) { + my $ticket = $result->{id}; + my $title = $result->{summary}; + my $reporter = $result->{reporter}; + my $cc = $result->{cc}; + my %addresses; + my $address_added; + for my $who ($reporter, split /[ ,]+/, $cc) { + $address_added = 0; + if ($who =~ /@/) { + $addresses{$who} = 1; + $address_added = 1; + } + if (defined($emailof{$who})) { + $addresses{$emailof{$who}} = 1; + $address_added = 1; + } + if ($who ne "nobody" && $address_added eq 0) { + # warn "No address found for $who"; + } + } + for my $address (keys(%addresses)) { + $ticketsfor{$address}{$ticket}{"title"} = $title; + } + } + $sth->finish; +} + +sub doEmails { + for my $email (sort (keys %ticketsfor)) { + if ($test ne 0) { + open FH, ">&STDOUT"; + } + else { + open(FH, '|-', 'mail', '-s', 'GHC bugs', '-a', 'From: glasgow-haskell-bugs@haskell.org', $email) or die "Running mail failed: $!"; + } + print FH <<'EOF'; + +Hello, + +You are receiving this mail because you are the reporter, or on the CC +list, for one or more GHC tickets that are automatically having their +priority reduced due to our post-release ticket handling policy: + http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions/BugTracker#Remilestoningticketsafterarelease + +The list of tickets for which you are the reporter or on the CC list is +given below. If any of these are causing problems for you, please let us +know on glasgow-haskell-bugs@haskell.org and we'll look at raising the +priority. + +Better still, if you are able to make any progress on any of the tickets +yourself (whether that be actually fixing the bug, or just making it +easier for someone else to - for example, by making a small, +self-contained test-case), then that would be a great help. We at GHC HQ +have limited resources, so if anything is waiting for us to make +progress then it can be waiting a long time! +EOF + for my $ticket (sort {$a <=> $b} (keys %{$ticketsfor{$email}})) { + my $title = $ticketsfor{$email}{$ticket}{"title"}; + print FH "\n"; + print FH "#$ticket $title:\n"; + print FH " http://hackage.haskell.org/trac/ghc/ticket/$ticket\n"; + } + print FH <<'EOF'; + +-- +The GHC Team +http://www.haskell.org/ghc/ +EOF + close FH or die "Close failed: $!"; + } +} + +&getUserAddress(); +&doTickets(); +&doEmails(); + diff --git a/docs/users_guide/7.6.1-notes.xml b/docs/users_guide/7.6.1-notes.xml new file mode 100644 index 0000000000..2ab5667601 --- /dev/null +++ b/docs/users_guide/7.6.1-notes.xml @@ -0,0 +1,427 @@ +<?xml version="1.0" encoding="iso-8859-1"?> +<sect1 id="release-7-6-1"> + <title>Release notes for version 7.6.1</title> + + <para> + The significant changes to the various parts of the compiler are + listed in the following sections. There have also been numerous bug + fixes and performance improvements over the 7.4 branch. + </para> + + <sect2> + <title>Highlights</title> + + <para> + The highlights, since the 7.4 branch, are: + </para> + + <itemizedlist> + <listitem> + <para> + TODO + </para> + </listitem> + </itemizedlist> + </sect2> + + <sect2> + <title>Full details</title> + <sect3> + <title>Language</title> + <itemizedlist> + <listitem> + <para> + TODO + </para> + </listitem> + + <listitem> + <para> + TODO + CAPI now supported (it was in 7.4, but not + documented or officially supported). + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>Compiler</title> + <itemizedlist> + <listitem> + <para> + TODO + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>GHCi</title> + <itemizedlist> + <listitem> + <para> + TODO + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>Template Haskell</title> + <itemizedlist> + <listitem> + <para> + TODO + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>Profiling</title> + <itemizedlist> + <listitem> + <para> + TODO + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>Event logging</title> + <itemizedlist> + + <listitem> + <para> + TODO + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>Runtime system</title> + <itemizedlist> + <listitem> + <para> + TODO + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>Build system</title> + <itemizedlist> + <listitem> + <para> + TODO + </para> + </listitem> + </itemizedlist> + </sect3> + </sect2> + + <sect2> + <title>Libraries</title> + + <para> + TODO + There have been some changes that have effected multiple + libraries: + </para> + + <itemizedlist> + <listitem> + <para> + TODO + </para> + </listitem> + </itemizedlist> + + <sect3> + <title>array</title> + <itemizedlist> + <listitem> + <para> + Version number TODO (was TODO) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>base</title> + <itemizedlist> + <listitem> + <para> + Version number TODO (was TODO) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>bin-package-db</title> + <itemizedlist> + <listitem> + <para> + This is an internal package, and should not be used. + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>binary</title> + <itemizedlist> + <listitem> + <para> + Version number TODO (was TODO) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>bytestring</title> + <itemizedlist> + <listitem> + <para> + Version number TODO (was TODO) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>Cabal</title> + <itemizedlist> + <listitem> + <para> + Version number TODO (was TODO) + </para> + </listitem> + + <listitem> + <para> + For details of the changes to the Cabal library, + plese see the Cabal changelog. + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>containers</title> + <itemizedlist> + <listitem> + <para> + Version number TODO (was TODO) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>deepseq</title> + <itemizedlist> + <listitem> + <para> + Version number TODO (was TODO) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>directory</title> + <itemizedlist> + <listitem> + <para> + Version number TODO (was TODO) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>extensible-exceptions</title> + <itemizedlist> + <listitem> + <para> + Version number TODO (was TODO) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>filepath</title> + <itemizedlist> + <listitem> + <para> + Version number TODO (was TODO) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>ghc-prim</title> + <itemizedlist> + <listitem> + <para> + This is an internal package, and should not be used. + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>haskell98</title> + <itemizedlist> + <listitem> + <para> + Version number TODO (was TODO) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>haskell2010</title> + <itemizedlist> + <listitem> + <para> + Version number TODO (was TODO) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>hoopl</title> + <itemizedlist> + <listitem> + <para> + Version number TODO (was TODO) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>hpc</title> + <itemizedlist> + <listitem> + <para> + Version number TODO (was TODO) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>integer-gmp</title> + <itemizedlist> + <listitem> + <para> + Version number TODO (was TODO) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>old-locale</title> + <itemizedlist> + <listitem> + <para> + Version number TODO (was TODO) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>old-time</title> + <itemizedlist> + <listitem> + <para> + Version number TODO (was TODO) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>pretty</title> + <itemizedlist> + <listitem> + <para> + Version number TODO (was TODO) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>process</title> + <itemizedlist> + <listitem> + <para> + Version number TODO (was TODO) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>template-haskell</title> + <itemizedlist> + <listitem> + <para> + Version number TODO (was TODO) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>time</title> + <itemizedlist> + <listitem> + <para> + Version number TODO (was TODO) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>unix</title> + <itemizedlist> + <listitem> + <para> + Version number TODO (was TODO) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>Win32</title> + <itemizedlist> + <listitem> + <para> + Version number TODO (was TODO) + </para> + </listitem> + </itemizedlist> + </sect3> + </sect2> +</sect1> + diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index a4041348b1..1ffd765046 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -809,9 +809,14 @@ <entry><option>-XNoConstraintKinds</option></entry> </row> <row> + <entry><option>-XDataKinds</option></entry> + <entry>Enable <link linkend="kind-polymorphism-and-promotion">datatype promotion</link>.</entry> + <entry>dynamic</entry> + <entry><option>-XNoDataKinds</option></entry> + </row> + <row> <entry><option>-XPolyKinds</option></entry> - <entry>Enable <link linkend="kind-polymorphism">kind polymorphism</link>. - Implies <option>-XKindSignatures</option>.</entry> + <entry>Enable <link linkend="kind-polymorphism-and-promotion">kind polymorphism</link>.</entry> <entry>dynamic</entry> <entry><option>-XNoPolyKinds</option></entry> </row> @@ -1296,11 +1301,11 @@ </row> <row> - <entry><option>-fwarn-orphans</option></entry> + <entry><option>-fwarn-orphans, -fwarn-auto-orphans</option></entry> <entry>warn when the module contains <link linkend="orphan-modules">orphan instance declarations or rewrite rules</link></entry> <entry>dynamic</entry> - <entry><option>-fno-warn-orphans</option></entry> + <entry><option>-fno-warn-orphans, -fno-warn-auto-orphans</option></entry> </row> <row> diff --git a/docs/users_guide/intro.xml b/docs/users_guide/intro.xml index e0ed2f373e..e219f9020c 100644 --- a/docs/users_guide/intro.xml +++ b/docs/users_guide/intro.xml @@ -346,7 +346,7 @@ </sect1> -<!-- &relnotes1; --> +&relnotes1; </chapter> diff --git a/docs/users_guide/safe_haskell.xml b/docs/users_guide/safe_haskell.xml index a8352aea6f..dc07b89bb8 100644 --- a/docs/users_guide/safe_haskell.xml +++ b/docs/users_guide/safe_haskell.xml @@ -156,7 +156,7 @@ <listitem>The design also relies on the Danger module not being able to access the <literal>UnsafeRIO</literal> constructor. Unfortunately Template Haskell can be used to subvert module - boundaries and so could be used gain access to this constructor. + boundaries and so could be used to gain access to this constructor. </listitem> <listitem>There is no way to place restrictions on the modules that the untrusted Danger module can import. This gives the author of diff --git a/docs/users_guide/ug-ent.xml.in b/docs/users_guide/ug-ent.xml.in index 0a90d03ab7..c83abaad52 100644 --- a/docs/users_guide/ug-ent.xml.in +++ b/docs/users_guide/ug-ent.xml.in @@ -3,7 +3,7 @@ <!ENTITY flags SYSTEM "flags.xml"> <!ENTITY license SYSTEM "license.xml"> <!ENTITY intro SYSTEM "intro.xml" > -<!-- <!ENTITY relnotes1 SYSTEM "7.0.1-notes.xml" > --> +<!ENTITY relnotes1 SYSTEM "7.6.1-notes.xml" > <!ENTITY using SYSTEM "using.xml" > <!ENTITY code-gens SYSTEM "codegens.xml" > <!ENTITY runtime SYSTEM "runtime_control.xml" > diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml index 169a5dfa23..ca28fc3888 100644 --- a/docs/users_guide/using.xml +++ b/docs/users_guide/using.xml @@ -1419,13 +1419,14 @@ module M where </varlistentry> <varlistentry> - <term><option>-fwarn-orphans</option>:</term> + <term><option>-fwarn-orphans, -fwarn-auto-orphans</option>:</term> <listitem> <indexterm><primary><option>-fwarn-orphans</option></primary></indexterm> + <indexterm><primary><option>-fwarn-auto-orphans</option></primary></indexterm> <indexterm><primary>orphan instances, warning</primary></indexterm> <indexterm><primary>orphan rules, warning</primary></indexterm> - <para>This option causes a warning to be emitted whenever the + <para>These flags cause a warning to be emitted whenever the module contains an "orphan" instance declaration or rewrite rule. An instance declaration is an orphan if it appears in a module in which neither the class nor the type being instanced are declared @@ -1437,6 +1438,11 @@ module M where play a role, whether or not the module's interface would otherwise be of any use. See <xref linkend="orphan-modules"/> for details. </para> + <para>The flag <option>-fwarn-orphans</option> warns about user-written + orphan rules or instances. The flag <option>-fwarn-auto-orphans</option> + warns about automatically-generated orphan rules, notably as a result of + specialising functions, for type classes (<literal>Specialise</literal>) + or argument values (<literal>SpecConstr</literal>).</para> </listitem> </varlistentry> @@ -380,7 +380,9 @@ endef define addPackage # args: $1 = package, $2 = condition ifneq "$(filter $1,$(PKGS_THAT_USE_TH)) $(GhcProfiled)" "$1 YES" ifeq "$(filter $1,$(PKGS_THAT_BUILD_WITH_STAGE2))" "$1" +ifneq "$(BuildingCrossCompiler)" "YES" $(call addPackageGeneral,PACKAGES_STAGE2,$1,$2) +endif else $(call addPackageGeneral,PACKAGES_STAGE1,$1,$2) endif @@ -574,9 +576,15 @@ BUILD_DIRS += \ $(GHC_GENPRIMOP_DIR) endif +ifeq "$(BuildingCrossCompiler)-$(phase)" "YES-final" +MAYBE_GHCI= +else +MAYBE_GHCI=driver/ghci +endif + BUILD_DIRS += \ driver \ - driver/ghci \ + $(MAYBE_GHCI) \ driver/ghc \ driver/haddock \ libffi \ @@ -600,24 +608,38 @@ else ifneq "$(findstring clean,$(MAKECMDGOALS))" "" BUILD_DIRS += libraries/integer-gmp/gmp endif +ifeq "$(BuildingCrossCompiler)-$(phase)" "YES-final" +MAYBE_COMPILER= +MAYBE_GHCTAGS= +MAYBE_HPC= +MAYBE_RUNGHC= +else +MAYBE_COMPILER=compiler +MAYBE_GHCTAGS=utils/ghctags +MAYBE_HPC=utils/hpc +MAYBE_RUNGHC=utils/runghc +endif + BUILD_DIRS += \ utils/haddock \ utils/haddock/doc \ - compiler \ + $(MAYBE_COMPILER) \ $(GHC_HSC2HS_DIR) \ $(GHC_PKG_DIR) \ utils/testremove \ - utils/ghctags \ + $(MAYBE_GHCTAGS) \ utils/ghc-pwd \ $(GHC_CABAL_DIR) \ - utils/hpc \ - utils/runghc \ + $(MAYBE_HPC) \ + $(MAYBE_RUNGHC) \ ghc ifneq "$(BINDIST)" "YES" +ifneq "$(BuildingCrossCompiler)-$(phase)" "YES-final" BUILD_DIRS += \ utils/mkUserGuidePart endif +endif BUILD_DIRS += utils/count_lines BUILD_DIRS += utils/compare_sizes @@ -810,7 +832,7 @@ else done # We rename ghc-stage2, so that the right program name is used in error # messages etc. - "$(MV)" "$(DESTDIR)$(ghclibexecdir)/ghc-stage2" "$(DESTDIR)$(ghclibexecdir)/ghc" + "$(MV)" "$(DESTDIR)$(ghclibexecdir)/ghc-stage$(INSTALL_GHC_STAGE)" "$(DESTDIR)$(ghclibexecdir)/ghc" endif install_topdirs: $(INSTALL_TOPDIRS) @@ -855,9 +877,11 @@ INSTALLED_GHC_REAL=$(DESTDIR)$(bindir)/ghc.exe INSTALLED_GHC_PKG_REAL=$(DESTDIR)$(bindir)/ghc-pkg.exe endif -INSTALLED_PKG_DIRS := $(addprefix libraries/,$(PACKAGES_STAGE1)) \ - compiler \ - $(addprefix libraries/,$(PACKAGES_STAGE2)) +INSTALLED_PKG_DIRS := $(addprefix libraries/,$(PACKAGES_STAGE1)) +ifeq "$(BuildingCrossCompiler)" "NO" +INSTALLED_PKG_DIRS := $(INSTALLED_PKG_DIRS) compiler +endif +INSTALLED_PKG_DIRS := $(INSTALLED_PKG_DIRS) $(addprefix libraries/,$(PACKAGES_STAGE2)) ifeq "$(InstallExtraPackages)" "NO" INSTALLED_PKG_DIRS := $(filter-out $(addprefix libraries/,$(EXTRA_PACKAGES)),\ $(INSTALLED_PKG_DIRS)) @@ -879,6 +903,7 @@ install_packages: rts/package.conf.install "$(INSTALLED_GHC_PKG_REAL)" --force --global-conf "$(INSTALLED_PACKAGE_CONF)" update rts/package.conf.install $(foreach p, $(INSTALLED_PKG_DIRS), \ $(call make-command, \ + CROSS_COMPILE="$(CrossCompilePrefix)" \ "$(GHC_CABAL_INPLACE)" install \ "$(INSTALLED_GHC_REAL)" \ "$(INSTALLED_GHC_PKG_REAL)" \ diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index be9a9f6b2f..f1767c3ea5 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -9,7 +9,21 @@ -- ----------------------------------------------------------------------------- -module GhciMonad where +module GhciMonad ( + GHCi(..), startGHCi, + GHCiState(..), setGHCiState, getGHCiState, modifyGHCiState, + GHCiOption(..), isOptionSet, setOption, unsetOption, + Command, + BreakLocation(..), + TickArray, + setDynFlags, + + runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs, + + printForUser, printForUserPartWay, prettyLocations, + initInterpBuffering, turnOffBuffering, flushInterpBuffers, + ghciHandleGhcException, + ) where #include "HsVersions.h" @@ -249,6 +263,7 @@ printForUserPartWay doc = do unqual <- GHC.getPrintUnqual liftIO $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc +-- | Run a single Haskell expression runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.RunResult) runStmt expr step = do st <- getGHCiState diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 1836087577..3d0adacf6b 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -487,6 +487,7 @@ runGHCiInput f = do (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile}) f +-- | How to get the next input line from the user nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String) nextInputLine show_prompt is_tty | is_tty = do @@ -601,6 +602,7 @@ queryQueue = do c:cs -> do setGHCiState st{ cmdqueue = cs } return (Just c) +-- | The main read-eval-print loop runCommands :: InputT GHCi (Maybe String) -> InputT GHCi () runCommands = runCommands' handler @@ -620,9 +622,12 @@ runCommands' eh gCmd = do Nothing -> return () Just _ -> runCommands' eh gCmd +-- | Evaluate a single line of user input (either :<command> or Haskell code) runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String) -> InputT GHCi (Maybe Bool) runOneCommand eh gCmd = do + -- run a previously queued command if there is one, otherwise get new + -- input from user mb_cmd0 <- noSpace (lift queryQueue) mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0 case mb_cmd1 of @@ -666,12 +671,19 @@ runOneCommand eh gCmd = do normSpace x = x -- SDM (2007-11-07): is userError the one to use here? collectError = userError "unterminated multiline command :{ .. :}" + + -- | Handle a line of input + doCommand :: String -> InputT GHCi (Maybe Bool) + + -- command doCommand (':' : cmd) = do result <- specialCommand cmd case result of True -> return Nothing _ -> return $ Just True - doCommand stmt = do + + -- haskell + doCommand stmt = do ml <- lift $ isOptionSet Multiline if ml then do @@ -736,16 +748,23 @@ declPrefixes :: [String] declPrefixes = ["class ","data ","newtype ","type ","instance ", "deriving ", "foreign "] +-- | Entry point to execute some haskell code from user runStmt :: String -> SingleStep -> GHCi Bool runStmt stmt step + -- empty | null (filter (not.isSpace) stmt) = return False + + -- import | "import " `isPrefixOf` stmt = do addImportToContext stmt; return False + + -- data, class, newtype... | any (flip isPrefixOf stmt) declPrefixes = do _ <- liftIO $ tryIO $ hFlushAll stdin result <- GhciMonad.runDecls stmt afterRunStmt (const True) (GHC.RunOk result) + | otherwise = do -- In the new IO library, read handles buffer data even if the Handle -- is set to NoBuffering. This causes problems for GHCi where there @@ -758,8 +777,7 @@ runStmt stmt step Nothing -> return False Just result -> afterRunStmt (const True) result ---afterRunStmt :: GHC.RunResult -> GHCi Bool - -- False <=> the statement failed to compile +-- | Clean up the GHCi environment after a statement has run afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool afterRunStmt _ (GHC.RunException e) = throw e afterRunStmt step_here run_result = do @@ -830,6 +848,7 @@ printTypeOfName n data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand +-- | Entry point for execution a ':<command>' input from user specialCommand :: String -> InputT GHCi Bool specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str) specialCommand str = do @@ -1621,31 +1640,31 @@ remModulesFromContext as bs = do addImportToContext :: String -> GHCi () addImportToContext str = do idecl <- GHC.parseImportDecl str + _ <- GHC.lookupModule (unLoc (ideclName idecl)) Nothing -- #5836 modifyGHCiState $ \st -> st { remembered_ctx = addNotSubsumed (IIDecl idecl) (remembered_ctx st) } setGHCContextFromGHCiState -setContext :: [String] -> [String] -> GHCi () -setContext starred not_starred = do - is1 <- mapM (checkAdd True) starred - is2 <- mapM (checkAdd False) not_starred - let iss = foldr addNotSubsumed [] (is1++is2) - modifyGHCiState $ \st -> st { remembered_ctx = iss, transient_ctx = [] } - -- delete the transient context - setGHCContextFromGHCiState - -checkAdd :: Bool -> String -> GHCi InteractiveImport +-- TODO: ARGH! This is a mess! 'checkAdd' is called from many places and we +-- have about 4 different variants of setGHCContext. All this import code needs +-- to be refactored to something saner. We should do the sanity check on an +-- import in 'checkAdd' and checkAdd only and only need to call checkAdd from +-- one place ('setGHCContetFromGHCiState'). The code isn't even logically +-- ordered! +checkAdd :: Bool -> String -> GHCi (InteractiveImport) checkAdd star mstr = do dflags <- getDynFlags case safeLanguageOn dflags of - True | star -> ghcError $ CmdLineError "can't use * imports with Safe Haskell" + True | star -> do + liftIO $ putStrLn "Warning: can't use * imports with Safe Haskell; ignoring *" + checkAdd False mstr True -> do m <- lookupModule mstr s <- GHC.isModuleTrusted m case s of True -> return $ IIDecl (simpleImportDecl $ moduleName m) - False -> ghcError $ CmdLineError $ "can't import " ++ mstr - ++ " as it isn't trusted." + False -> ghcError $ CmdLineError $ + "can't import " ++ mstr ++ " as it isn't trusted." False | star -> do m <- wantInterpretedModule mstr return $ IIModule m @@ -1667,12 +1686,28 @@ checkAdd star mstr = do -- setGHCContextFromGHCiState :: GHCi () setGHCContextFromGHCiState = do - let ok (IIModule m) = checkAdd True (moduleNameString (moduleName m)) - ok (IIDecl d) = checkAdd False (moduleNameString (unLoc (ideclName d))) st <- getGHCiState - iidecls <- filterM (tryBool . ok) (transient_ctx st ++ remembered_ctx st) - setGHCContext iidecls + goodTran <- mapMaybeM (tryBool . ok) $ transient_ctx st + goodRemb <- mapMaybeM (tryBool . ok) $ remembered_ctx st + -- drop bad imports so we don't keep replaying it to the user! + modifyGHCiState $ \s -> s { transient_ctx = goodTran } + modifyGHCiState $ \s -> s { remembered_ctx = goodRemb } + setGHCContext (goodTran ++ goodRemb) + + where + ok (IIModule m) = checkAdd True (moduleNameString (moduleName m)) + ok (IIDecl d) = checkAdd False (moduleNameString (unLoc (ideclName d))) + mapMaybeM f xs = catMaybes `fmap` sequence (map f xs) + +setContext :: [String] -> [String] -> GHCi () +setContext starred not_starred = do + is1 <- mapM (checkAdd True) starred + is2 <- mapM (checkAdd False) not_starred + let iss = foldr addNotSubsumed [] (is1++is2) + modifyGHCiState $ \st -> st { remembered_ctx = iss, transient_ctx = [] } + -- delete the transient context + setGHCContextFromGHCiState -- | Sets the GHC contexts to the given set of imports, adding a Prelude -- import if there isn't an explicit one already. @@ -2721,12 +2756,12 @@ ghciHandle h m = Haskeline.catch m $ \e -> unblock (h e) ghciTry :: GHCi a -> GHCi (Either SomeException a) ghciTry (GHCi m) = GHCi $ \s -> gtry (m s) -tryBool :: GHCi a -> GHCi Bool +tryBool :: GHCi a -> GHCi (Maybe a) tryBool m = do r <- ghciTry m case r of - Left _ -> return False - Right _ -> return True + Left e -> showException e >> return Nothing + Right a -> return $ Just a -- ---------------------------------------------------------------------------- -- Utils diff --git a/ghc/Main.hs b/ghc/Main.hs index b9de7b1f97..a1943cff50 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -537,8 +537,7 @@ mode_flags = addFlag "-no-link" f)) , Flag "M" (PassFlag (setMode doMkDependHSMode)) , Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc))) - , Flag "C" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f - addFlag "-fvia-C" f)) + , Flag "C" (PassFlag setGenerateC) , Flag "S" (PassFlag (setMode (stopBeforeMode As))) , Flag "-make" (PassFlag (setMode doMakeMode)) , Flag "-interactive" (PassFlag (setMode doInteractiveMode)) @@ -546,6 +545,14 @@ mode_flags = , Flag "e" (SepArg (\s -> setMode (doEvalMode s) "-e")) ] +setGenerateC :: String -> EwM ModeM () +setGenerateC f + | cGhcUnregisterised /= "YES" = do + addWarn ("Compiler not unregisterised, so ignoring " ++ f) + | otherwise = do + setMode (stopBeforeMode HCc) f + addFlag "-fvia-C" f + setMode :: Mode -> String -> EwM ModeM () setMode newMode newFlag = liftEwM $ do (mModeFlag, errs, flags') <- getCmdLineState diff --git a/ghc/ghc-bin.cabal.in b/ghc/ghc-bin.cabal.in index ba17150e9a..0cf51d05e1 100644 --- a/ghc/ghc-bin.cabal.in +++ b/ghc/ghc-bin.cabal.in @@ -26,11 +26,11 @@ Flag ghci Executable ghc Main-Is: Main.hs Build-Depends: base >= 3 && < 5, - array >= 0.1 && < 0.4, + array >= 0.1 && < 0.5, bytestring >= 0.9 && < 0.10, directory >= 1 && < 1.2, process >= 1 && < 1.2, - filepath >= 1 && < 1.3, + filepath >= 1 && < 1.4, ghc if os(windows) Build-Depends: Win32 diff --git a/ghc/ghc.mk b/ghc/ghc.mk index 2af90bed28..022ee85a84 100644 --- a/ghc/ghc.mk +++ b/ghc/ghc.mk @@ -86,6 +86,10 @@ endif ifneq "$(filter-out 2,$(stage))" "" ghc_stage2_NOT_NEEDED = YES endif +# When cross-compiling, the stage 1 compiler is our release compiler, so omit stage 2 +ifeq "$(BuildingCrossCompiler)" "YES" +ghc_stage2_NOT_NEEDED = YES +endif # stage 3 has to be requested explicitly with stage=3 ifneq "$(stage)" "3" ghc_stage3_NOT_NEEDED = YES @@ -147,7 +151,7 @@ install: install_ghc_link .PNONY: install_ghc_link install_ghc_link: $(call removeFiles,"$(DESTDIR)$(bindir)/ghc") - $(LN_S) ghc-$(ProjectVersion) "$(DESTDIR)$(bindir)/ghc" + $(LN_S) $(CrossCompilePrefix)ghc-$(ProjectVersion) "$(DESTDIR)$(bindir)/$(CrossCompilePrefix)ghc" else # On Windows we install the main binary as $(bindir)/ghc.exe # To get ghc-<version>.exe we have a little C program in driver/ghc @@ -155,6 +159,6 @@ install: install_ghc_post .PHONY: install_ghc_post install_ghc_post: install_bins $(call removeFiles,$(DESTDIR)$(bindir)/ghc.exe) - "$(MV)" -f $(DESTDIR)$(bindir)/ghc-stage$(INSTALL_GHC_STAGE).exe $(DESTDIR)$(bindir)/ghc.exe + "$(MV)" -f $(DESTDIR)$(bindir)/ghc-stage$(INSTALL_GHC_STAGE).exe $(DESTDIR)$(bindir)/$(CrossCompilePrefix)ghc.exe endif diff --git a/includes/ghc.mk b/includes/ghc.mk index ef994f2329..74edf55b1c 100644 --- a/includes/ghc.mk +++ b/includes/ghc.mk @@ -129,7 +129,7 @@ endif includes_DERIVEDCONSTANTS = includes/dist-derivedconstants/header/DerivedConstants.h -ifeq "$(PORTING_HOST)" "YES" +ifeq "$(PORTING_HOST)-$(AlienScript)" "YES-" DerivedConstants.h : @echo "*** Cross-compiling: please copy DerivedConstants.h from the target system" @@ -145,9 +145,18 @@ $(eval $(call build-prog,includes,dist-derivedconstants,0)) $(includes_dist-derivedconstants_depfile_c_asm) : $(includes_H_CONFIG) $(includes_H_PLATFORM) $(includes_H_FILES) $$(rts_H_FILES) includes/dist-derivedconstants/build/mkDerivedConstants.o : $(includes_H_CONFIG) $(includes_H_PLATFORM) +ifneq "$(AlienScript)" "" +$(INPLACE_BIN)/mkDerivedConstants$(exeext): includes/$(includes_dist-derivedconstants_C_SRCS) | $$(dir $$@)/. + $(WhatGccIsCalled) -o $@ $< $(CFLAGS) $(includes_CC_OPTS) +endif + ifneq "$(BINDIST)" "YES" $(includes_DERIVEDCONSTANTS) : $(INPLACE_BIN)/mkDerivedConstants$(exeext) | $$(dir $$@)/. +ifeq "$(AlienScript)" "" ./$< >$@ +else + $(AlienScript) run ./$< >$@ +endif endif endif @@ -157,7 +166,7 @@ endif includes_GHCCONSTANTS = includes/dist-ghcconstants/header/GHCConstants.h -ifeq "$(PORTING_HOST)" "YES" +ifeq "$(PORTING_HOST)-$(AlienScript)" "YES-" $(includes_GHCCONSTANTS) : @echo "*** Cross-compiling: please copy DerivedConstants.h from the target system" @@ -176,8 +185,17 @@ $(includes_dist-ghcconstants_depfile_c_asm) : $(includes_H_CONFIG) $(includes_H_ includes/dist-ghcconstants/build/mkDerivedConstants.o : $(includes_H_CONFIG) $(includes_H_PLATFORM) +ifneq "$(AlienScript)" "" +$(INPLACE_BIN)/mkGHCConstants$(exeext): includes/$(includes_dist-ghcconstants_C_SRCS) | $$(dir $$@)/. + $(WhatGccIsCalled) -o $@ $< $(CFLAGS) $(includes_CC_OPTS) $(includes_dist-ghcconstants_CC_OPTS) +endif + $(includes_GHCCONSTANTS) : $(INPLACE_BIN)/mkGHCConstants$(exeext) | $$(dir $$@)/. +ifeq "$(AlienScript)" "" ./$< >$@ +else + $(AlienScript) run ./$< >$@ +endif endif endif diff --git a/libffi/ghc.mk b/libffi/ghc.mk index d9224108b4..879d482da8 100644 --- a/libffi/ghc.mk +++ b/libffi/ghc.mk @@ -82,7 +82,7 @@ $(libffi_STAMP_CONFIGURE): $(TOUCH_DEP) --prefix=$(TOP)/libffi/build/inst \ --enable-static=yes \ --enable-shared=$(libffi_EnableShared) \ - --host=$(HOSTPLATFORM) --build=$(BUILDPLATFORM) + --host=$(TargetPlatformFull) # wc on OS X has spaces in its output, which libffi's Makefile # doesn't expect, so we tweak it to sed them out diff --git a/mk/compiler-ghc.mk b/mk/compiler-ghc.mk index 4a0fd816d2..c92c254f65 100644 --- a/mk/compiler-ghc.mk +++ b/mk/compiler-ghc.mk @@ -10,7 +10,6 @@ # # ----------------------------------------------------------------------------- -dir = ghc TOP = .. SPEC_TARGETS = 1 2 3 re1 re2 re3 include $(TOP)/mk/sub-makefile.mk diff --git a/mk/config.mk.in b/mk/config.mk.in index 58e22cb664..2b5bd46aba 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -139,7 +139,7 @@ PlatformSupportsSharedLibs = $(if $(filter $(TARGETPLATFORM),\ # the compiler you build with is generating registerised binaries), but # the stage2 compiler will be an unregisterised binary. # -ifneq "$(findstring $(HostArch_CPP), i386 x86_64 powerpc arm)" "" +ifneq "$(findstring $(TargetArch_CPP), i386 x86_64 powerpc arm)" "" GhcUnregisterised=NO else GhcUnregisterised=YES @@ -151,8 +151,8 @@ endif # Target platforms supported: # i386, powerpc # AIX is not supported -ArchSupportsNCG=$(strip $(patsubst $(HostArch_CPP), YES, $(findstring $(HostArch_CPP), i386 x86_64 powerpc sparc))) -OsSupportsNCG=$(strip $(patsubst $(HostOS_CPP), YES, $(patsubst aix,,$(HostOS_CPP)))) +ArchSupportsNCG=$(strip $(patsubst $(TargetArch_CPP), YES, $(findstring $(TargetArch_CPP), i386 x86_64 powerpc sparc))) +OsSupportsNCG=$(strip $(patsubst $(TargetOS_CPP), YES, $(patsubst aix,,$(TargetOS_CPP)))) # lazy test, because $(GhcUnregisterised) might be set in build.mk later. GhcWithNativeCodeGen=$(strip\ @@ -163,7 +163,7 @@ HaveLibDL = @HaveLibDL@ # ArchSupportsSMP should be set iff there is support for that arch in # includes/stg/SMP.h -ArchSupportsSMP=$(strip $(patsubst $(HostArch_CPP), YES, $(findstring $(HostArch_CPP), i386 x86_64 sparc powerpc arm))) +ArchSupportsSMP=$(strip $(patsubst $(TargetArch_CPP), YES, $(findstring $(TargetArch_CPP), i386 x86_64 sparc powerpc arm))) # lazy test, because $(GhcUnregisterised) might be set in build.mk later. GhcWithSMP=$(strip $(if $(filter YESNO, $(ArchSupportsSMP)$(GhcUnregisterised)),YES,NO)) @@ -171,8 +171,8 @@ GhcWithSMP=$(strip $(if $(filter YESNO, $(ArchSupportsSMP)$(GhcUnregisterised)), # Whether to include GHCi in the compiler. Depends on whether the RTS linker # has support for this OS/ARCH combination. -OsSupportsGHCi=$(strip $(patsubst $(HostOS_CPP), YES, $(findstring $(HostOS_CPP), mingw32 cygwin32 linux solaris2 freebsd dragonfly netbsd openbsd darwin kfreebsdgnu))) -ArchSupportsGHCi=$(strip $(patsubst $(HostArch_CPP), YES, $(findstring $(HostArch_CPP), i386 x86_64 powerpc sparc sparc64))) +OsSupportsGHCi=$(strip $(patsubst $(TargetOS_CPP), YES, $(findstring $(TargetOS_CPP), mingw32 cygwin32 linux solaris2 freebsd dragonfly netbsd openbsd darwin kfreebsdgnu))) +ArchSupportsGHCi=$(strip $(patsubst $(TargetArch_CPP), YES, $(findstring $(TargetArch_CPP), i386 x86_64 powerpc sparc sparc64))) ifeq "$(OsSupportsGHCi)$(ArchSupportsGHCi)" "YESYES" GhcWithInterpreter=YES @@ -194,7 +194,7 @@ endif # Whether to use libffi for adjustors (foreign import "wrapper") or # not. If we have built-in support (rts/Adjustor.c) then we use that, # otherwise we fall back on libffi, which is slightly slower. -ArchHasAdjustorSupport = $(if $(findstring $(HostArch_CPP),i386 x86_64),YES,NO) +ArchHasAdjustorSupport = $(if $(findstring $(TargetArch_CPP),i386 x86_64),YES,NO) ifeq "$(ArchHasAdjustorSupport)" "YES" UseLibFFIForAdjustors=NO else @@ -515,9 +515,6 @@ GHC_STAGE1 = $(INPLACE_BIN)/ghc-stage1$(exeext) GHC_STAGE2 = $(INPLACE_BIN)/ghc-stage2$(exeext) GHC_STAGE3 = $(INPLACE_BIN)/ghc-stage3$(exeext) -# Install stage 2 by default, can be changed to 3 -INSTALL_GHC_STAGE=2 - BOOTSTRAPPING_CONF = libraries/bootstrapping.conf INPLACE_PACKAGE_CONF = $(INPLACE_LIB)/package.conf.d @@ -553,8 +550,17 @@ endif # the flag --with-gcc=<blah> instead. The reason is that the configure script # needs to know which gcc you're using in order to perform its tests. -WhatGccIsCalled = @WhatGccIsCalled@ -GccVersion = @GccVersion@ +WhatGccIsCalled = @WhatGccIsCalled@ +GccVersion = @GccVersion@ +AlienScript = @AlienScript@ +ifeq "$(phase)" "0" +CrossCompilePrefix = +else +CrossCompilePrefix = @CrossCompilePrefix@ +endif +# TargetPlatformFull retains the string passed to configure so we have it in +# the necessary format to pass to libffi's configure. +TargetPlatformFull = @TargetPlatformFull@ GccLT34 = @GccLT34@ GccLT46 = @GccLT46@ CC = $(WhatGccIsCalled) @@ -568,6 +574,22 @@ AS_STAGE1 = $(AS) AS_STAGE2 = $(AS) AS_STAGE3 = $(AS) +# Cross-compiling options +# +# The 'toolchain' case: Cross-compiler to run locally: +BuildingCrossCompiler = @BuildingCrossCompiler@ +# The 'port' case: Porting to a foreign architecture: +PortingCompiler = @PortingCompiler@ +# BuildingCrossCompiler OR PortingCompiler +CrossCompiling = @CrossCompiling@ + +# Install stage 2 by default, or stage 1 in the cross compiler case. Can be changed to 3 +ifeq "$(BuildingCrossCompiler)" "YES" +INSTALL_GHC_STAGE=1 +else +INSTALL_GHC_STAGE=2 +endif + # C compiler and linker flags from configure (e.g. -m<blah> to select # correct C compiler backend). The stage number is the stage of GHC # that is being used to compile with. @@ -596,6 +618,9 @@ SRC_HSC2HS_OPTS += --cross-safe endif SRC_HSC2HS_OPTS += $(addprefix --cflag=,$(filter-out -O,$(SRC_CC_OPTS) $(CONF_CC_OPTS_STAGE0))) SRC_HSC2HS_OPTS += $(foreach d,$(GMP_INCLUDE_DIRS),-I$(d)) +ifeq "$(CrossCompiling)" "YES" +SRC_HSC2HS_OPTS += --cross-compile +endif #----------------------------------------------------------------------------- # Mingwex Library diff --git a/mk/validate-settings.mk b/mk/validate-settings.mk index 303b6ec018..119dce10bb 100644 --- a/mk/validate-settings.mk +++ b/mk/validate-settings.mk @@ -16,9 +16,6 @@ endif SRC_HC_OPTS += -Wall $(WERROR) -H64m -O0 -# Safe by default -#SRC_HC_OPTS += -Dsh_SAFE_DEFAULT - GhcStage1HcOpts += -O -fwarn-tabs GhcStage2HcOpts += -O -fwarn-tabs -dcore-lint diff --git a/rts/Capability.h b/rts/Capability.h index 91b4567186..2ae2fcf6d7 100644 --- a/rts/Capability.h +++ b/rts/Capability.h @@ -96,7 +96,11 @@ struct Capability_ { Task *spare_workers; nat n_spare_workers; // count of above - // This lock protects running_task, returning_tasks_{hd,tl}, wakeup_queue. + // This lock protects: + // running_task + // returning_tasks_{hd,tl} + // wakeup_queue + // inbox Mutex lock; // Tasks waiting to return from a foreign call, or waiting to make @@ -108,6 +112,7 @@ struct Capability_ { Task *returning_tasks_tl; // Messages, or END_TSO_QUEUE. + // Locks required: cap->lock Message *inbox; SparkPool *sparks; diff --git a/rts/PosixSource.h b/rts/PosixSource.h index d139dd50af..56e08abb0e 100644 --- a/rts/PosixSource.h +++ b/rts/PosixSource.h @@ -11,7 +11,7 @@ #include <ghcplatform.h> -#if defined(freebsd_HOST_OS) +#if defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS) #define _POSIX_C_SOURCE 200112L #define _XOPEN_SOURCE 600 #else diff --git a/rts/RtsUtils.c b/rts/RtsUtils.c index e04b9846be..b880f8c9e5 100644 --- a/rts/RtsUtils.c +++ b/rts/RtsUtils.c @@ -130,7 +130,7 @@ heapOverflow(void) { /* don't fflush(stdout); WORKAROUND bug in Linux glibc */ OutOfHeapHook(0/*unknown request size*/, - RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE); + (lnat)RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE); heap_overflow = rtsTrue; } diff --git a/rts/StgCRun.c b/rts/StgCRun.c index c302efba2c..17aefb6c88 100644 --- a/rts/StgCRun.c +++ b/rts/StgCRun.c @@ -632,7 +632,7 @@ StgRun(StgFunPtr f, StgRegTable *basereg) { /* * save callee-saves registers on behalf of the STG code. */ - "stmfd sp!, {r4-r10, fp, ip, lr}\n\t" + "stmfd sp!, {r4-r11, fp, ip, lr}\n\t" #if !defined(arm_HOST_ARCH_PRE_ARMv6) "vstmdb sp!, {d8-d11}\n\t" #endif @@ -669,10 +669,10 @@ StgRun(StgFunPtr f, StgRegTable *basereg) { #if !defined(arm_HOST_ARCH_PRE_ARMv6) "vldmia sp!, {d8-d11}\n\t" #endif - "ldmfd sp!, {r4-r10, fp, ip, lr}\n\t" + "ldmfd sp!, {r4-r11, fp, ip, lr}\n\t" : "=r" (r) : "r" (f), "r" (basereg), "i" (RESERVED_C_STACK_BYTES) - : + : "%r4", "%r5", "%r6", "%r8", "%r9", "%r10", "%r11", "%fp", "%ip", "%lr" ); return r; } diff --git a/rules/build-package-data.mk b/rules/build-package-data.mk index 6755a2cd9b..d535e34cbe 100644 --- a/rules/build-package-data.mk +++ b/rules/build-package-data.mk @@ -67,6 +67,8 @@ $1_$2_CONFIGURE_OPTS += --with-gcc="$$(CC_STAGE$3)" $1_$2_CONFIGURE_OPTS += --configure-option=--with-cc="$$(CC_STAGE$3)" $1_$2_CONFIGURE_OPTS += --with-ar="$$(AR_STAGE$3)" $1_$2_CONFIGURE_OPTS += --with-ranlib="$$(RANLIB)" +$1_$2_CONFIGURE_OPTS += $$(if $$(ALEX),--with-alex="$$(ALEX)") +$1_$2_CONFIGURE_OPTS += $$(if $$(HAPPY),--with-happy="$$(HAPPY)") ifneq "$$(BINDIST)" "YES" ifneq "$$(NO_GENERATED_MAKEFILE_RULES)" "YES" @@ -77,7 +79,7 @@ $1/$2/build/autogen/cabal_macros.h : $1/$2/package-data.mk # for our build system, and registers the package for use in-place in # the build tree. $1/$2/package-data.mk : $$(GHC_CABAL_INPLACE) $$($1_$2_GHC_PKG_DEP) $1/$$($1_PACKAGE).cabal $$(wildcard $1/configure) $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_CONFIG_DEP) - "$$(GHC_CABAL_INPLACE)" configure --with-ghc="$$($1_$2_HC_CONFIG)" --with-ghc-pkg="$$($1_$2_GHC_PKG)" $$($1_CONFIGURE_OPTS) $$($1_$2_CONFIGURE_OPTS) -- $2 $1 + CROSS_COMPILE="$(CrossCompilePrefix)" "$$(GHC_CABAL_INPLACE)" configure --with-ghc="$$($1_$2_HC_CONFIG)" --with-ghc-pkg="$$($1_$2_GHC_PKG)" $$($1_CONFIGURE_OPTS) $$($1_$2_CONFIGURE_OPTS) -- $2 $1 ifeq "$$($1_$2_PROG)" "" ifneq "$$($1_$2_REGISTER_PACKAGE)" "NO" "$$($1_$2_GHC_PKG)" update --force $$($1_$2_GHC_PKG_OPTS) $1/$2/inplace-pkg-config diff --git a/rules/build-package.mk b/rules/build-package.mk index d83a79d89d..ccd1659c30 100644 --- a/rules/build-package.mk +++ b/rules/build-package.mk @@ -133,7 +133,7 @@ CHECKED_$1 = YES check_packages: check_$1 .PHONY: check_$1 check_$1: $$(GHC_CABAL_INPLACE) - $$(GHC_CABAL_INPLACE) check $1 + CROSS_COMPILE="$(CrossCompilePrefix)" $$(GHC_CABAL_INPLACE) check $1 endif ifneq "$3" "0" diff --git a/rules/haddock.mk b/rules/haddock.mk index ff922ae978..0fc2043d67 100644 --- a/rules/haddock.mk +++ b/rules/haddock.mk @@ -42,7 +42,7 @@ endif ifneq "$$(BINDIST)" "YES" $$($$($1_PACKAGE)-$$($1_$2_VERSION)_HADDOCK_FILE) : $$(INPLACE_BIN)/haddock$$(exeext) $$(GHC_CABAL_INPLACE) $$($1_$2_HS_SRCS) $$($$($1_PACKAGE)-$$($1_$2_VERSION)_HADDOCK_DEPS) | $$$$(dir $$$$@)/. ifeq "$$(HSCOLOUR_SRCS)" "YES" - "$$(GHC_CABAL_INPLACE)" hscolour $2 $1 + CROSS_COMPILE="$(CrossCompilePrefix)" "$$(GHC_CABAL_INPLACE)" hscolour $2 $1 endif "$$(TOP)/$$(INPLACE_BIN)/haddock" \ --odir="$1/$2/doc/html/$$($1_PACKAGE)" \ diff --git a/rules/shell-wrapper.mk b/rules/shell-wrapper.mk index 2376db137f..a291d852fe 100644 --- a/rules/shell-wrapper.mk +++ b/rules/shell-wrapper.mk @@ -62,7 +62,7 @@ BINDIST_WRAPPERS += $$($1_$2_SHELL_WRAPPER_NAME) install: install_$1_$2_wrapper .PHONY: install_$1_$2_wrapper -install_$1_$2_wrapper: WRAPPER=$$(DESTDIR)$$(bindir)/$$($1_$2_INSTALL_SHELL_WRAPPER_NAME) +install_$1_$2_wrapper: WRAPPER=$$(DESTDIR)$$(bindir)/$(CrossCompilePrefix)$$($1_$2_INSTALL_SHELL_WRAPPER_NAME) install_$1_$2_wrapper: $$(call INSTALL_DIR,"$$(DESTDIR)$$(bindir)") $$(call removeFiles, "$$(WRAPPER)") @@ -421,6 +421,9 @@ sub scmall { scm ($localpath, $scm, "gc", @args) unless $scm eq "darcs"; } + elsif ($command =~ /^tag$/) { + scm ($localpath, $scm, "tag", @args); + } else { die "Unknown command: $command"; } @@ -514,6 +517,7 @@ any extra arguments to git: reset send status + tag -------------- Flags ------------------- These flags are given *before* the command and modify the way sync-all behaves. diff --git a/utils/ghc-cabal/ghc-cabal.cabal b/utils/ghc-cabal/ghc-cabal.cabal index 0c45b8357a..7bbab037e4 100644 --- a/utils/ghc-cabal/ghc-cabal.cabal +++ b/utils/ghc-cabal/ghc-cabal.cabal @@ -18,5 +18,5 @@ Executable ghc-cabal Build-Depends: base >= 3 && < 5, Cabal >= 1.10 && < 1.16, directory >= 1.1 && < 1.2, - filepath >= 1.2 && < 1.3 + filepath >= 1.2 && < 1.4 diff --git a/utils/ghc-pkg/ghc.mk b/utils/ghc-pkg/ghc.mk index b6e762530a..b4302cc8e0 100644 --- a/utils/ghc-pkg/ghc.mk +++ b/utils/ghc-pkg/ghc.mk @@ -30,7 +30,7 @@ endif else -$(GHC_PKG_INPLACE) : utils/ghc-pkg/dist/build/$(utils/ghc-pkg_dist_PROG)$(exeext) | $$(dir $$@)/. $(INPLACE_PACKAGE_CONF)/. +$(GHC_PKG_INPLACE) : utils/ghc-pkg/dist/build/tmp/$(utils/ghc-pkg_dist_PROG)$(exeext) | $$(dir $$@)/. $(INPLACE_PACKAGE_CONF)/. $(call removeFiles,$(wildcard $(INPLACE_PACKAGE_CONF)/*)) ifeq "$(Windows)" "YES" cp $< $@ @@ -51,7 +51,7 @@ endif # # ToDo: we might want to do this using ghc-cabal instead. # -utils/ghc-pkg/dist/build/$(utils/ghc-pkg_dist_PROG)$(exeext): utils/ghc-pkg/Main.hs utils/ghc-pkg/Version.hs | bootstrapping/. $$(dir $$@)/. $(GHC_CABAL_INPLACE) +utils/ghc-pkg/dist/build/tmp/$(utils/ghc-pkg_dist_PROG)$(exeext): utils/ghc-pkg/Main.hs utils/ghc-pkg/Version.hs | bootstrapping/. $$(dir $$@)/. $(GHC_CABAL_INPLACE) "$(GHC)" $(SRC_HC_OPTS) --make utils/ghc-pkg/Main.hs -o $@ \ -no-user-package-conf \ -Wall -fno-warn-unused-imports -fno-warn-warnings-deprecations \ @@ -82,30 +82,41 @@ $(eval $(call clean-target,utils/ghc-pkg,dist,\ utils/ghc-pkg/Version.hs)) # ----------------------------------------------------------------------------- -# Building ghc-pkg with stage 1 +# Cross-compile case: Install our dist version +# Normal case: Build ghc-pkg with stage 1 -utils/ghc-pkg_dist-install_USES_CABAL = YES +ifeq "$(BuildingCrossCompiler)" "YES" +GHC_PKG_DISTDIR=dist +else +GHC_PKG_DISTDIR=dist-install +endif + +utils/ghc-pkg_$(GHC_PKG_DISTDIR)_USES_CABAL = YES utils/ghc-pkg_PACKAGE = ghc-pkg -utils/ghc-pkg_dist-install_PROG = ghc-pkg -utils/ghc-pkg_dist-install_SHELL_WRAPPER = YES -utils/ghc-pkg_dist-install_INSTALL_SHELL_WRAPPER = YES -utils/ghc-pkg_dist-install_INSTALL_SHELL_WRAPPER_NAME = ghc-pkg-$(ProjectVersion) -utils/ghc-pkg_dist-install_INSTALL_INPLACE = NO +utils/ghc-pkg_$(GHC_PKG_DISTDIR)_PROG = ghc-pkg +utils/ghc-pkg_$(GHC_PKG_DISTDIR)_SHELL_WRAPPER = YES +utils/ghc-pkg_$(GHC_PKG_DISTDIR)_INSTALL_SHELL_WRAPPER = YES +utils/ghc-pkg_$(GHC_PKG_DISTDIR)_INSTALL_SHELL_WRAPPER_NAME = ghc-pkg-$(ProjectVersion) +utils/ghc-pkg_$(GHC_PKG_DISTDIR)_INSTALL_INPLACE = NO ifeq "$(BootingFromHc)" "YES" utils/ghc-pkg_dist-install_OTHER_OBJS += $(ALL_STAGE1_LIBS) $(ALL_STAGE1_LIBS) $(ALL_STAGE1_LIBS) $(ALL_RTS_LIBS) $(libffi_STATIC_LIB) endif +ifeq "$(BuildingCrossCompiler)" "YES" +$(eval $(call shell-wrapper,utils/ghc-pkg,dist)) +else $(eval $(call build-prog,utils/ghc-pkg,dist-install,1)) +endif ifeq "$(Windows)" "NO" install: install_utils/ghc-pkg_link -.PNONY: install_utils/ghc-pkg_link +.PHONY: install_utils/ghc-pkg_link install_utils/ghc-pkg_link: $(call INSTALL_DIR,"$(DESTDIR)$(bindir)") $(call removeFiles,"$(DESTDIR)$(bindir)/ghc-pkg") - $(LN_S) ghc-pkg-$(ProjectVersion) "$(DESTDIR)$(bindir)/ghc-pkg" + $(LN_S) $(CrossCompilePrefix)ghc-pkg-$(ProjectVersion) "$(DESTDIR)$(bindir)/$(CrossCompilePrefix)ghc-pkg" endif diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index 95d4323d00..c0e51802a1 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -253,7 +253,7 @@ boundValues mod group = , bind <- bagToList binds , x <- boundThings mod bind ] _other -> error "boundValues" - tys = [ n | ns <- map hsTyClDeclBinders (concat (hs_tyclds group)) + tys = [ n | ns <- map hsLTyClDeclBinders (concat (hs_tyclds group)) , n <- map found ns ] fors = concat $ map forBound (hs_fords group) where forBound lford = case unLoc lford of |