diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2013-02-27 09:57:09 +0000 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2013-02-27 09:57:09 +0000 |
| commit | 47d226544fc3fb11d024740a162f8ae4e1d044c9 (patch) | |
| tree | 8a024b97de71216f6b3606d3cda7bf16ae1f98a6 | |
| parent | 7b5e514d85c086be8dc6d938b526c97b6ced56eb (diff) | |
| parent | 0ee31659afe7a6819f9eb5e233f98e5592f1b439 (diff) | |
| download | haskell-tc-arrows.tar.gz | |
Merge remote-tracking branch 'origin/master' into tc-arrowstc-arrows
112 files changed, 1483 insertions, 1126 deletions
diff --git a/aclocal.m4 b/aclocal.m4 index 942d6bbab6..268e6311f5 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -36,7 +36,7 @@ AC_DEFUN([FPTOOLS_SET_PLATFORM_VARS], else GHC_CONVERT_CPU([$build_cpu], [BuildArch]) GHC_CONVERT_VENDOR([$build_vendor], [BuildVendor]) - GHC_CONVERT_OS([$build_os], [BuildOS]) + GHC_CONVERT_OS([$build_os], [$BuildArch], [BuildOS]) fi if test "$host_alias" = "" @@ -56,7 +56,7 @@ AC_DEFUN([FPTOOLS_SET_PLATFORM_VARS], else GHC_CONVERT_CPU([$host_cpu], [HostArch]) GHC_CONVERT_VENDOR([$host_vendor], [HostVendor]) - GHC_CONVERT_OS([$host_os], [HostOS]) + GHC_CONVERT_OS([$host_os], [$HostArch], [HostOS]) fi if test "$target_alias" = "" @@ -65,7 +65,7 @@ AC_DEFUN([FPTOOLS_SET_PLATFORM_VARS], then GHC_CONVERT_CPU([$host_cpu], [TargetArch]) GHC_CONVERT_VENDOR([$host_vendor], [TargetVendor]) - GHC_CONVERT_OS([$host_os], [TargetOS]) + GHC_CONVERT_OS([$host_os], [$TargetArch],[TargetOS]) else if test "$bootstrap_target" != "" then @@ -83,7 +83,7 @@ AC_DEFUN([FPTOOLS_SET_PLATFORM_VARS], else GHC_CONVERT_CPU([$target_cpu], [TargetArch]) GHC_CONVERT_VENDOR([$target_vendor], [TargetVendor]) - GHC_CONVERT_OS([$target_os], [TargetOS]) + GHC_CONVERT_OS([$target_os], [$TargetArch], [TargetOS]) fi windows=NO @@ -215,6 +215,9 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS], linux) test -z "[$]2" || eval "[$]2=OSLinux" ;; + ios) + test -z "[$]2" || eval "[$]2=OSiOS" + ;; darwin) test -z "[$]2" || eval "[$]2=OSDarwin" ;; @@ -302,11 +305,11 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS], HaskellHaveGnuNonexecStack=False]) CFLAGS="$CFLAGS2" - checkArch "$BuildArch" "" + checkArch "$BuildArch" "HaskellBuildArch" checkVendor "$BuildVendor" checkOS "$BuildOS" "" - checkArch "$HostArch" "" + checkArch "$HostArch" "HaskellHostArch" checkVendor "$HostVendor" checkOS "$HostOS" "" @@ -458,10 +461,12 @@ AC_DEFUN([FP_SETTINGS], SettingsOptCommand="$OptCmd" fi fi - SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2 $CONF_GCC_LINKER_OPTS_STAGE2" + SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2" + SettingsCCompilerLinkFlags="$CONF_GCC_LINKER_OPTS_STAGE2" SettingsLdFlags="$CONF_LD_LINKER_OPTS_STAGE2" AC_SUBST(SettingsCCompilerCommand) AC_SUBST(SettingsCCompilerFlags) + AC_SUBST(SettingsCCompilerLinkFlags) AC_SUBST(SettingsLdCommand) AC_SUBST(SettingsLdFlags) AC_SUBST(SettingsArCommand) @@ -772,6 +777,7 @@ x86_64-unknown-mingw32) fptools_cv_leading_underscore=no;; # HACK: Apple doesn't seem to provide nlist in the 64-bit-libraries x86_64-apple-darwin*) fptools_cv_leading_underscore=yes;; +*-apple-ios) fptools_cv_leading_underscore=yes;; *) AC_RUN_IFELSE([AC_LANG_SOURCE([[#ifdef HAVE_NLIST_H #include <nlist.h> @@ -1724,35 +1730,6 @@ AC_DEFUN([FP_GMP], AC_SUBST(GMP_LIB_DIRS) ])# FP_GMP -# FP_CHECK_MACOSX_DEPLOYMENT_TARGET -# --------------------------------- -AC_DEFUN([FP_CHECK_MACOSX_DEPLOYMENT_TARGET], -[ -if test "x$TargetOS_CPP-$TargetVendor_CPP" = "xdarwin-apple"; then - AC_MSG_CHECKING([Mac OS X deployment target]) - case $FP_MACOSX_DEPLOYMENT_TARGET in - none) ;; - 10.4) MACOSX_DEPLOYMENT_VERSION=10.4 - MACOSX_DEPLOYMENT_SDK=/Developer/SDKs/MacOSX10.4u.sdk - ;; - 10.4u) MACOSX_DEPLOYMENT_VERSION=10.4 - MACOSX_DEPLOYMENT_SDK=/Developer/SDKs/MacOSX10.4u.sdk - ;; - *) MACOSX_DEPLOYMENT_VERSION=$FP_MACOSX_DEPLOYMENT_TARGET - MACOSX_DEPLOYMENT_SDK=/Developer/SDKs/MacOSX${FP_MACOSX_DEPLOYMENT_TARGET}.sdk - ;; - esac - if test "x$FP_MACOSX_DEPLOYMENT_TARGET" = "xnone"; then - AC_MSG_RESULT(none) - else - if test ! -d $MACOSX_DEPLOYMENT_SDK; then - AC_MSG_ERROR([Unknown deployment target $FP_MACOSX_DEPLOYMENT_TARGET]) - fi - AC_MSG_RESULT([${MACOSX_DEPLOYMENT_VERSION} (${MACOSX_DEPLOYMENT_SDK})]) - fi -fi -]) - # -------------------------------------------------------------- # Calculate absolute path to build tree # -------------------------------------------------------------- @@ -1889,33 +1866,40 @@ AC_DEFUN([GHC_CONVERT_VENDOR],[ esac ]) -# GHC_CONVERT_OS(os, target_var) +# GHC_CONVERT_OS(os, converted_cpu, target_var) # -------------------------------- # converts os from gnu to ghc naming, and assigns the result to $target_var AC_DEFUN([GHC_CONVERT_OS],[ -case "$1" in - linux-android*) - $2="linux-android" - ;; - linux-*|linux) - $2="linux" - ;; - # As far as I'm aware, none of these have relevant variants - freebsd|netbsd|openbsd|dragonfly|osf1|osf3|hpux|linuxaout|kfreebsdgnu|freebsd2|solaris2|cygwin32|mingw32|darwin|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku) - $2="$1" - ;; - freebsd*) # like i686-gentoo-freebsd7 - # i686-gentoo-freebsd8 - # i686-gentoo-freebsd8.2 - $2="freebsd" - ;; - nto-qnx*) - $2="nto-qnx" +case "$1-$2" in + darwin10-arm) + $3="ios" ;; *) - echo "Unknown OS $1" - exit 1 - ;; + case "$1" in + linux-android*) + $3="linux-android" + ;; + linux-*|linux) + $3="linux" + ;; + # As far as I'm aware, none of these have relevant variants + freebsd|netbsd|openbsd|dragonfly|osf1|osf3|hpux|linuxaout|kfreebsdgnu|freebsd2|solaris2|cygwin32|mingw32|darwin|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku) + $3="$1" + ;; + freebsd*) # like i686-gentoo-freebsd7 + # i686-gentoo-freebsd8 + # i686-gentoo-freebsd8.2 + $3="freebsd" + ;; + nto-qnx*) + $3="nto-qnx" + ;; + *) + echo "Unknown OS $1" + exit 1 + ;; + esac + ;; esac ]) @@ -1981,9 +1965,18 @@ AC_DEFUN([XCODE_VERSION],[ # AC_DEFUN([FIND_LLVM_PROG],[ FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL([$1], [$2], [$3]) - if test "$1" == ""; then - GOOD_PATH=`echo $PATH | tr ':,;' ' '` - $1=`${FindCmd} ${GOOD_PATH} -type f -perm +111 -maxdepth 1 -regex '.*/$3-[[0-9]]\.[[0-9]]' | ${SortCmd} -n | tail -1` + if test "$$1" != ""; then + save_IFS=$IFS + IFS=":;" + for p in ${PATH}; do + if [ -d "${p}" ]; then + $1=`${FindCmd} "${p}" -type f -perm +111 -maxdepth 1 -regex '.*/$3-[[0-9]]\.[[0-9]]' -or -type l -perm +111 -maxdepth 1 -regex '.*/$3-[[0-9]]\.[[0-9]]' | ${SortCmd} -n | tail -1` + if test -n "$1"; then + break + fi + fi + done + IFS=$save_IFS fi ]) diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index 281ae938ed..e11262568e 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -73,6 +73,7 @@ module Name ( #include "Typeable.h" import {-# SOURCE #-} TypeRep( TyThing ) +import {-# SOURCE #-} PrelNames( liftedTypeKindTyConKey ) import OccName import Module @@ -566,7 +567,26 @@ getOccString = occNameString . getOccName pprInfixName, pprPrefixName :: (Outputable a, NamedThing a) => a -> SDoc -- See Outputable.pprPrefixVar, pprInfixVar; -- add parens or back-quotes as appropriate -pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n) -pprPrefixName n = pprPrefixVar (isSymOcc (getOccName n)) (ppr n) +pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n) + +pprPrefixName thing + | name `hasKey` liftedTypeKindTyConKey + = ppr name -- See Note [Special treatment for kind *] + | otherwise + = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name) + where + name = getName thing \end{code} +Note [Special treatment for kind *] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do not put parens around the kind '*'. Even though it looks like +an operator, it is really a special case. + +This pprPrefixName stuff is really only used when printing HsSyn, +which has to be polymorphic in the name type, and hence has to go via +the overloaded function pprPrefixOcc. It's easier where we know the +type being pretty printed; eg the pretty-printing code in TypeRep. + +See Trac #7645, which led to this. + diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index 3ff3bbb82f..ff98923eb8 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -277,7 +277,11 @@ instance OutputableBndr RdrName where | otherwise = ppr n pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) - pprPrefixOcc rdr = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + pprPrefixOcc rdr + | Just name <- isExact_maybe rdr = pprPrefixName name + -- pprPrefixName has some special cases, so + -- we delegate to them rather than reproduce them + | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) instance Eq RdrName where (Exact n1) == (Exact n2) = n1==n2 diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 4005f6d9b4..05ef2b270c 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -880,6 +880,10 @@ translateOp dflags IntLeOp = Just (mo_wordSLe dflags) translateOp dflags IntGtOp = Just (mo_wordSGt dflags) translateOp dflags IntLtOp = Just (mo_wordSLt dflags) +translateOp dflags AndIOp = Just (mo_wordAnd dflags) +translateOp dflags OrIOp = Just (mo_wordOr dflags) +translateOp dflags XorIOp = Just (mo_wordXor dflags) +translateOp dflags NotIOp = Just (mo_wordNot dflags) translateOp dflags ISllOp = Just (mo_wordShl dflags) translateOp dflags ISraOp = Just (mo_wordSShr dflags) translateOp dflags ISrlOp = Just (mo_wordUShr dflags) diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index 2932b01822..081960466f 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -141,8 +141,9 @@ untidy b (L loc p) = L loc (untidy' b p) untidy' _ (LitPat lit) = LitPat (untidy_lit lit) untidy' _ p@(ConPatIn _ (PrefixCon [])) = p untidy' b (ConPatIn name ps) = pars b (L loc (ConPatIn name (untidy_con ps))) - untidy' _ (ListPat pats ty) = ListPat (map untidy_no_pars pats) ty + untidy' _ (ListPat pats ty Nothing) = ListPat (map untidy_no_pars pats) ty Nothing untidy' _ (TuplePat pats box ty) = TuplePat (map untidy_no_pars pats) box ty + untidy' _ (ListPat _ _ (Just _)) = panic "Check.untidy: Overloaded ListPat" untidy' _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!" untidy' _ (SigPatIn _ _) = panic "Check.untidy: SigPat" untidy' _ (LazyPat {}) = panic "Check.untidy: LazyPat" @@ -568,15 +569,15 @@ is_nil (ConPatIn con (PrefixCon [])) = unLoc con == getName nilDataCon is_nil _ = False is_list :: Pat Name -> Bool -is_list (ListPat _ _) = True +is_list (ListPat _ _ Nothing) = True is_list _ = False return_list :: DataCon -> Pat Name -> Bool return_list id q = id == consDataCon && (is_nil q || is_list q) make_list :: LPat Name -> Pat Name -> Pat Name -make_list p q | is_nil q = ListPat [p] placeHolderType -make_list p (ListPat ps ty) = ListPat (p:ps) ty +make_list p q | is_nil q = ListPat [p] placeHolderType Nothing +make_list p (ListPat ps ty Nothing) = ListPat (p:ps) ty Nothing make_list _ _ = panic "Check.make_list: Invalid argument" make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat @@ -647,7 +648,8 @@ might_fail_pat (ViewPat _ p _) = not (isIrrefutableHsPat p) might_fail_pat (ParPat p) = might_fail_lpat p might_fail_pat (AsPat _ p) = might_fail_lpat p might_fail_pat (SigPatOut p _ ) = might_fail_lpat p -might_fail_pat (ListPat ps _) = any might_fail_lpat ps +might_fail_pat (ListPat ps _ Nothing) = any might_fail_lpat ps +might_fail_pat (ListPat _ _ (Just _)) = True might_fail_pat (TuplePat ps _ _) = any might_fail_lpat ps might_fail_pat (PArrPat ps _) = any might_fail_lpat ps might_fail_pat (BangPat p) = might_fail_lpat p @@ -682,11 +684,12 @@ tidy_pat (CoPat _ pat _) = tidy_pat pat -- guard says "this equation might fall through". tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id)) tidy_pat (ViewPat _ _ ty) = WildPat ty +tidy_pat (ListPat _ _ (Just (ty,_))) = WildPat ty tidy_pat pat@(ConPatOut { pat_con = L _ id, pat_args = ps }) = pat { pat_args = tidy_con id ps } -tidy_pat (ListPat ps ty) +tidy_pat (ListPat ps ty Nothing) = unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty) (mkNilPat list_ty) (map tidy_lpat ps) diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 5cd85139e2..bdcf9c9f78 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -519,10 +519,14 @@ addTickHsExpr (HsDo cxt stmts srcloc) forQual = case cxt of ListComp -> Just $ BinBox QualBinBox _ -> Nothing -addTickHsExpr (ExplicitList ty es) = - liftM2 ExplicitList +addTickHsExpr (ExplicitList ty wit es) = + liftM3 ExplicitList (return ty) - (mapM (addTickLHsExpr) es) + (addTickWit wit) + (mapM (addTickLHsExpr) es) + where addTickWit Nothing = return Nothing + addTickWit (Just fln) = do fln' <- addTickHsExpr fln + return (Just fln') addTickHsExpr (ExplicitPArr ty es) = liftM2 ExplicitPArr (return ty) @@ -543,10 +547,14 @@ addTickHsExpr (ExprWithTySigOut e ty) = (addTickLHsExprNever e) -- No need to tick the inner expression -- for expressions with signatures (return ty) -addTickHsExpr (ArithSeq ty arith_seq) = - liftM2 ArithSeq +addTickHsExpr (ArithSeq ty wit arith_seq) = + liftM3 ArithSeq (return ty) + (addTickWit wit) (addTickArithSeqInfo arith_seq) + where addTickWit Nothing = return Nothing + addTickWit (Just fl) = do fl' <- addTickHsExpr fl + return (Just fl') addTickHsExpr (HsTickPragma _ (L pos e0)) = do e2 <- allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index 76f167d0f4..b825acb836 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -1155,7 +1155,7 @@ collectl (L _ pat) bndrs go (AsPat (L _ a) pat) = a : collectl pat bndrs go (ParPat pat) = collectl pat bndrs - go (ListPat pats _) = foldr collectl bndrs pats + go (ListPat pats _ _) = foldr collectl bndrs pats go (PArrPat pats _) = foldr collectl bndrs pats go (TuplePat pats _ _) = foldr collectl bndrs pats diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index cfda20adda..226eee27bd 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -350,8 +350,8 @@ dsExpr (HsMultiIf res_ty alts) \underline{\bf Various data construction things} % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -dsExpr (ExplicitList elt_ty xs) - = dsExplicitList elt_ty xs +dsExpr (ExplicitList elt_ty wit xs) + = dsExplicitList elt_ty wit xs -- We desugar [:x1, ..., xn:] as -- singletonP x1 +:+ ... +:+ singletonP xn @@ -368,17 +368,13 @@ dsExpr (ExplicitPArr ty xs) = do unary fn x = mkApps (Var fn) [Type ty, x] binary fn x y = mkApps (Var fn) [Type ty, x, y] -dsExpr (ArithSeq expr (From from)) - = App <$> dsExpr expr <*> dsLExpr from - -dsExpr (ArithSeq expr (FromTo from to)) - = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to] - -dsExpr (ArithSeq expr (FromThen from thn)) - = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn] - -dsExpr (ArithSeq expr (FromThenTo from thn to)) - = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to] +dsExpr (ArithSeq expr witness seq) + = case witness of + Nothing -> dsArithSeq expr seq + Just fl -> do { + ; fl' <- dsExpr fl + ; newArithSeq <- dsArithSeq expr seq + ; return (App fl' newArithSeq)} dsExpr (PArrSeq expr (FromTo from to)) = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to] @@ -673,9 +669,9 @@ makes all list literals be generated via the simple route. \begin{code} -dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr +dsExplicitList :: PostTcType -> Maybe (SyntaxExpr Id) -> [LHsExpr Id] -> DsM CoreExpr -- See Note [Desugaring explicit lists] -dsExplicitList elt_ty xs +dsExplicitList elt_ty Nothing xs = do { dflags <- getDynFlags ; xs' <- mapM dsLExpr xs ; let (dynamic_prefix, static_suffix) = spanTail is_static xs' @@ -700,9 +696,25 @@ dsExplicitList elt_ty xs ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix' ; return (foldr (App . App (Var c)) folded_suffix prefix) } +dsExplicitList elt_ty (Just fln) xs + = do { fln' <- dsExpr fln + ; list <- dsExplicitList elt_ty Nothing xs + ; dflags <- getDynFlags + ; return (App (App fln' (mkIntExprInt dflags (length xs))) list) } + spanTail :: (a -> Bool) -> [a] -> ([a], [a]) spanTail f xs = (reverse rejected, reverse satisfying) where (satisfying, rejected) = span f $ reverse xs + +dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr +dsArithSeq expr (From from) + = App <$> dsExpr expr <*> dsLExpr from +dsArithSeq expr (FromTo from to) + = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to] +dsArithSeq expr (FromThen from thn) + = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn] +dsArithSeq expr (FromThenTo from thn to) + = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to] \end{code} Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 4f5ba2df17..ae7a3cc271 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -970,7 +970,7 @@ repE e@(HsDo ctxt sts _) | otherwise = notHandled "mdo, monad comprehension and [: :]" (ppr e) -repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs } +repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs } repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e) repE e@(ExplicitTuple es boxed) | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e) @@ -987,7 +987,7 @@ repE (RecordUpd e flds _ _ _) repRecUpd x fs } repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 } -repE (ArithSeq _ aseq) = +repE (ArithSeq _ _ aseq) = case aseq of From e -> do { ds1 <- repLE e; repFrom ds1 } FromThen e1 e2 -> do @@ -1259,7 +1259,8 @@ repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 } repP (BangPat p) = do { p1 <- repLP p; repPbang p1 } repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 } repP (ParPat p) = repLP p -repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs } +repP (ListPat ps _ Nothing) = do { qs <- repLPs ps; repPlist qs } +repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE e; repPview e' p} repP (TuplePat ps boxed _) | isBoxed boxed = do { qs <- repLPs ps; repPtup qs } | otherwise = do { qs <- repLPs ps; repPunboxedTup qs } diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 5b0f3b1ff6..43a3af7a4c 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -17,7 +17,7 @@ module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat #include "HsVersions.h" -import {-#SOURCE#-} DsExpr (dsLExpr) +import {-#SOURCE#-} DsExpr (dsLExpr, dsExpr) import DynFlags import HsSyn @@ -53,7 +53,7 @@ import qualified Data.Map as Map \end{code} This function is a wrapper of @match@, it must be called from all the parts where -it was called match, but only substitutes the firs call, .... +it was called match, but only substitutes the first call, .... if the associated flags are declared, warnings will be issued. It can not be called matchWrapper because this name already exists :-( @@ -327,12 +327,13 @@ match vars@(v:_) ty eqns -- Eqns *can* be empty PgBang -> matchBangs vars ty (dropGroup eqns) PgCo _ -> matchCoercion vars ty (dropGroup eqns) PgView _ _ -> matchView vars ty (dropGroup eqns) - + PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns) + -- FIXME: we should also warn about view patterns that should be -- commoned up but are not -- print some stuff to see what's getting grouped - -- use -dppr-debug to see the resolution of overloaded lits + -- use -dppr-debug to see the resolution of overloaded literals debug eqns = let gs = map (\group -> foldr (\ (p,_) -> \acc -> case p of PgView e _ -> e:acc @@ -391,19 +392,33 @@ matchView (var:vars) ty (eqns@(eqn1:_)) ; return (mkViewMatchResult var' viewExpr' var match_result) } matchView _ _ _ = panic "matchView" +matchOverloadedList :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +matchOverloadedList (var:vars) ty (eqns@(eqn1:_)) +-- Since overloaded list patterns are treated as view patterns, +-- the code is roughly the same as for matchView + = do { let ListPat _ elt_ty (Just (_,e)) = firstPat eqn1 + ; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand + ; match_result <- match (var':vars) ty $ + map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern + ; e' <- dsExpr e + ; return (mkViewMatchResult var' e' var match_result) } +matchOverloadedList _ _ _ = panic "matchOverloadedList" + -- decompose the first pattern and leave the rest alone decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats })) = eqn { eqn_pats = extractpat pat : pats} decomposeFirstPat _ _ = panic "decomposeFirstPat" -getCoPat, getBangPat, getViewPat :: Pat Id -> Pat Id +getCoPat, getBangPat, getViewPat, getOLPat :: Pat Id -> Pat Id getCoPat (CoPat _ pat _) = pat getCoPat _ = panic "getCoPat" getBangPat (BangPat pat ) = unLoc pat getBangPat _ = panic "getBangPat" getViewPat (ViewPat _ pat _) = unLoc pat -getViewPat _ = panic "getBangPat" +getViewPat _ = panic "getViewPat" +getOLPat (ListPat pats ty (Just _)) = ListPat pats ty Nothing +getOLPat _ = panic "getOLPat" \end{code} Note [Empty case alternatives] @@ -536,7 +551,7 @@ tidy1 v (LazyPat pat) ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] ; return (mkCoreLets sel_binds, WildPat (idType v)) } -tidy1 _ (ListPat pats ty) +tidy1 _ (ListPat pats ty Nothing) = return (idDsWrapper, unLoc list_ConPat) where list_ty = mkListTy ty @@ -831,7 +846,8 @@ data PatGroup | PgView (LHsExpr Id) -- view pattern (e -> p): -- the LHsExpr is the expression e Type -- the Type is the type of p (equivalently, the result type of e) - + | PgOverloadedList + groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]] -- If the result is of form [g1, g2, g3], -- (a) all the (pg,eq) pairs in g1 have the same pg @@ -885,7 +901,7 @@ sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2 -- always have the same type, so this boils down to saying that -- the two coercions are identical. sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2) - -- ViewPats are in the same gorup iff the expressions + -- ViewPats are in the same group iff the expressions -- are "equal"---conservatively, we use syntactic equality sameGroup _ _ = False @@ -1002,6 +1018,7 @@ patGroup _ (NPat olit mb_neg _) = PgN (hsOverLitKey olit (isJust patGroup _ (NPlusKPat _ olit _ _) = PgNpK (hsOverLitKey olit False) patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) +patGroup _ (ListPat _ _ (Just _)) = PgOverloadedList patGroup _ pat = pprPanic "patGroup" (ppr pat) \end{code} diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 9621f1de4b..fe6779bd01 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -24,14 +24,19 @@ compiler_stage3_MKDEPENDC_OPTS = -DMAKING_GHC_BUILD_SYSTEM_DEPENDENCIES compiler_stage1_C_FILES_NODEPS = compiler/parser/cutils.c +# This package doesn't pass the Cabal checks because include-dirs +# points outside the source directory. This isn't a real problem, so +# we just skip the check. +compiler_NO_CHECK = YES + ifneq "$(BINDIST)" "YES" compiler/stage1/package-data.mk : compiler/stage1/build/Config.hs compiler/stage2/package-data.mk : compiler/stage2/build/Config.hs compiler/stage3/package-data.mk : compiler/stage3/build/Config.hs -compiler/stage1/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_TYPE) -compiler/stage2/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_TYPE) -compiler/stage3/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_TYPE) +compiler/stage1/build/PlatformConstants.o: $(includes_GHCCONSTANTS_HASKELL_TYPE) +compiler/stage2/build/PlatformConstants.o: $(includes_GHCCONSTANTS_HASKELL_TYPE) +compiler/stage3/build/PlatformConstants.o: $(includes_GHCCONSTANTS_HASKELL_TYPE) compiler/stage1/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_EXPORTS) compiler/stage2/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_EXPORTS) compiler/stage3/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_EXPORTS) @@ -253,7 +258,6 @@ compiler/stage$1/build/Parser.y: compiler/parser/Parser.y.pp compiler/stage$1/build/primops.txt: compiler/prelude/primops.txt.pp compiler/stage$1/$$(PLATFORM_H) $$(CPP) $$(RAWCPP_FLAGS) -P $$(compiler_CPP_OPTS) -Icompiler/stage$1 -x c $$< | grep -v '^#pragma GCC' > $$@ -ifneq "$$(BootingFromHc)" "YES" compiler/stage$1/build/primop-data-decl.hs-incl: compiler/stage$1/build/primops.txt $$(GENPRIMOP_INPLACE) "$$(GENPRIMOP_INPLACE)" --data-decl < $$< > $$@ compiler/stage$1/build/primop-tag.hs-incl: compiler/stage$1/build/primops.txt $$(GENPRIMOP_INPLACE) @@ -281,7 +285,6 @@ compiler/stage$1/build/primop-primop-info.hs-incl: compiler/stage$1/build/primop # can still generate them if we want them back compiler/stage$1/build/primop-usage.hs-incl: compiler/stage$1/build/primops.txt $$(GENPRIMOP_INPLACE) "$$(GENPRIMOP_INPLACE)" --usage < $$< > $$@ -endif endef @@ -490,11 +493,11 @@ $(compiler_stage1_depfile_haskell) : $(COMPILER_INCLUDES_DEPS) $(PRIMOP_BITS_STA $(compiler_stage2_depfile_haskell) : $(COMPILER_INCLUDES_DEPS) $(PRIMOP_BITS_STAGE2) $(compiler_stage3_depfile_haskell) : $(COMPILER_INCLUDES_DEPS) $(PRIMOP_BITS_STAGE3) -$(foreach way,$$(compiler_stage1_WAYS),\ +$(foreach way,$(compiler_stage1_WAYS),\ compiler/stage1/build/PrimOp.$($(way)_osuf)) : $(PRIMOP_BITS_STAGE1) -$(foreach way,$$(compiler_stage2_WAYS),\ +$(foreach way,$(compiler_stage2_WAYS),\ compiler/stage2/build/PrimOp.$($(way)_osuf)) : $(PRIMOP_BITS_STAGE2) -$(foreach way,$$(compiler_stage3_WAYS),\ +$(foreach way,$(compiler_stage3_WAYS),\ compiler/stage3/build/PrimOp.$($(way)_osuf)) : $(PRIMOP_BITS_STAGE3) diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index ce15071439..8caf987336 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -545,11 +545,11 @@ cvtl e = wrapL (cvt e) ; return $ HsCase e' (mkMatchGroup ms') } cvt (DoE ss) = cvtHsDo DoExpr ss cvt (CompE ss) = cvtHsDo ListComp ss - cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' } + cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' } cvt (ListE xs) | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') } -- Note [Converting strings] - | otherwise = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' } + | otherwise = do { xs' <- mapM cvtl xs; return $ ExplicitList void Nothing xs' } -- Infix expressions cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y @@ -806,7 +806,7 @@ cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' cvtp TH.WildP = return $ WildPat void cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } -cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void } +cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void Nothing } cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t ; return $ SigPatIn p' (mkHsWithBndrs t') } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void } diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 32218e5393..ce391c73e2 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -4,7 +4,8 @@ % \begin{code} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, + DeriveTraversable #-} -- | Abstract syntax of global declarations. -- @@ -15,7 +16,8 @@ module HsDecls ( HsDecl(..), LHsDecl, HsDataDefn(..), -- ** Class or type declarations TyClDecl(..), LTyClDecl, TyClGroup, - isClassDecl, isDataDecl, isSynDecl, isFamilyDecl, tcdName, + isClassDecl, isDataDecl, isSynDecl, tcdName, + isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl, tyFamInstDeclName, tyFamInstDeclLName, countTyClDecls, pprTyClDeclFlavour, tyClDeclLName, tyClDeclTyVars, @@ -53,7 +55,7 @@ module HsDecls ( WarnDecl(..), LWarnDecl, -- ** Annotations AnnDecl(..), LAnnDecl, - AnnProvenance(..), annProvenanceName_maybe, modifyAnnProvenanceNameM, + AnnProvenance(..), annProvenanceName_maybe, -- * Grouping HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups @@ -83,8 +85,9 @@ import SrcLoc import FastString import Bag -import Control.Monad ( liftM ) import Data.Data hiding (TyCon) +import Data.Foldable (Foldable) +import Data.Traversable \end{code} %************************************************************************ @@ -476,7 +479,7 @@ data FamilyDecl name = FamilyDecl data FamilyFlavour = TypeFamily | DataFamily - deriving( Data, Typeable ) + deriving( Data, Typeable, Eq ) \end{code} @@ -500,10 +503,20 @@ isClassDecl :: TyClDecl name -> Bool isClassDecl (ClassDecl {}) = True isClassDecl _ = False --- | type family declaration +-- | type/data family declaration isFamilyDecl :: TyClDecl name -> Bool isFamilyDecl (FamDecl {}) = True isFamilyDecl _other = False + +-- | type family declaration +isTypeFamilyDecl :: TyClDecl name -> Bool +isTypeFamilyDecl (FamDecl d) = fdFlavour d == TypeFamily +isTypeFamilyDecl _other = False + +-- | data family declaration +isDataFamilyDecl :: TyClDecl name -> Bool +isDataFamilyDecl (FamDecl d) = fdFlavour d == DataFamily +isDataFamilyDecl _other = False \end{code} Dealing with names @@ -1348,21 +1361,13 @@ instance (OutputableBndr name) => Outputable (AnnDecl name) where data AnnProvenance name = ValueAnnProvenance name | TypeAnnProvenance name | ModuleAnnProvenance - deriving (Data, Typeable) + deriving (Data, Typeable, Functor, Foldable, Traversable) annProvenanceName_maybe :: AnnProvenance name -> Maybe name annProvenanceName_maybe (ValueAnnProvenance name) = Just name annProvenanceName_maybe (TypeAnnProvenance name) = Just name annProvenanceName_maybe ModuleAnnProvenance = Nothing --- TODO: Replace with Traversable instance when GHC bootstrap version rises high enough -modifyAnnProvenanceNameM :: Monad m => (before -> m after) -> AnnProvenance before -> m (AnnProvenance after) -modifyAnnProvenanceNameM fm prov = - case prov of - ValueAnnProvenance name -> liftM ValueAnnProvenance (fm name) - TypeAnnProvenance name -> liftM TypeAnnProvenance (fm name) - ModuleAnnProvenance -> return ModuleAnnProvenance - pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc pprAnnProvenance ModuleAnnProvenance = ptext (sLit "ANN module") pprAnnProvenance (ValueAnnProvenance name) = ptext (sLit "ANN") <+> ppr name diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 3e3c2f4ed0..d59c193ae8 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -179,8 +179,9 @@ data HsExpr id [ExprLStmt id] -- "do":one or more stmts PostTcType -- Type of the whole expression - | ExplicitList -- syntactic list - PostTcType -- Gives type of components of list + | ExplicitList -- syntactic list + PostTcType -- Gives type of components of list + (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromListN witness [LHsExpr id] | ExplicitPArr -- syntactic parallel array: [:e1, ..., en:] @@ -215,8 +216,9 @@ data HsExpr id (LHsType Name) -- Retain the signature for -- round-tripping purposes - | ArithSeq -- arithmetic sequence + | ArithSeq -- Arithmetic sequence PostTcExpr + (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromList witness (ArithSeqInfo id) | PArrSeq -- arith. sequence for parallel array @@ -500,7 +502,7 @@ ppr_expr (HsLet binds expr) ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts -ppr_expr (ExplicitList _ exprs) +ppr_expr (ExplicitList _ _ exprs) = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) ppr_expr (ExplicitPArr _ exprs) @@ -519,7 +521,7 @@ ppr_expr (ExprWithTySigOut expr sig) = hang (nest 2 (ppr_lexpr expr) <+> dcolon) 4 (ppr sig) -ppr_expr (ArithSeq _ info) = brackets (ppr info) +ppr_expr (ArithSeq _ _ info) = brackets (ppr info) ppr_expr (PArrSeq _ info) = paBrackets (ppr info) ppr_expr EWildPat = char '_' diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index 64bda890db..3a8e433596 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -67,8 +67,12 @@ data Pat id | BangPat (LPat id) -- Bang pattern ------------ Lists, tuples, arrays --------------- - | ListPat [LPat id] -- Syntactic list - PostTcType -- The type of the elements + | ListPat [LPat id] -- Syntactic list + PostTcType -- The type of the elements + (Maybe (PostTcType, SyntaxExpr id)) -- For rebindable syntax + -- For OverloadedLists a Just (ty,fn) gives + -- overall type of the pattern, and the toList + -- function to convert the scrutinee to a list value | TuplePat [LPat id] -- Tuple Boxity -- UnitPat is TuplePat [] @@ -245,7 +249,7 @@ pprPat (BangPat pat) = char '!' <> pprParendLPat pat pprPat (AsPat name pat) = hcat [ppr name, char '@', pprParendLPat pat] pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat] pprPat (ParPat pat) = parens (ppr pat) -pprPat (ListPat pats _) = brackets (interpp'SP pats) +pprPat (ListPat pats _ _) = brackets (interpp'SP pats) pprPat (PArrPat pats _) = paBrackets (interpp'SP pats) pprPat (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP pats) @@ -401,7 +405,7 @@ isIrrefutableHsPat pat go1 (SigPatIn pat _) = go pat go1 (SigPatOut pat _) = go pat go1 (TuplePat pats _ _) = all go pats - go1 (ListPat {}) = False + go1 (ListPat {}) = False go1 (PArrPat {}) = False -- ? go1 (ConPatIn {}) = False -- Conservative diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 74aa4773b6..d0d9e1a0a9 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -614,7 +614,7 @@ ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty) ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr_mono_lty pREC_CON ty ppr_mono_ty _ (HsQuasiQuoteTy qq) = ppr qq ppr_mono_ty _ (HsRecTy flds) = pprConDeclFields flds -ppr_mono_ty _ (HsTyVar name) = ppr name +ppr_mono_ty _ (HsTyVar name) = pprPrefixOcc name ppr_mono_ty prec (HsFunTy ty1 ty2) = ppr_fun_ty prec ty1 ty2 ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys) where std_con = case con of diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 081d61be10..1fa949653e 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -343,7 +343,7 @@ nlHsLam match = noLoc (HsLam (mkMatchGroup [match])) nlHsPar e = noLoc (HsPar e) nlHsIf cond true false = noLoc (mkHsIf cond true false) nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup matches)) -nlList exprs = noLoc (ExplicitList placeHolderType exprs) +nlList exprs = noLoc (ExplicitList placeHolderType Nothing exprs) nlHsAppTy :: LHsType name -> LHsType name -> LHsType name nlHsTyVar :: name -> LHsType name @@ -569,7 +569,7 @@ collect_lpat (L _ pat) bndrs go (ViewPat _ pat _) = collect_lpat pat bndrs go (ParPat pat) = collect_lpat pat bndrs - go (ListPat pats _) = foldr collect_lpat bndrs pats + go (ListPat pats _ _) = foldr collect_lpat bndrs pats go (PArrPat pats _) = foldr collect_lpat bndrs pats go (TuplePat pats _ _) = foldr collect_lpat bndrs pats @@ -754,7 +754,7 @@ lPatImplicits = hs_lpat hs_pat (AsPat _ pat) = hs_lpat pat hs_pat (ViewPat _ pat _) = hs_lpat pat hs_pat (ParPat pat) = hs_lpat pat - hs_pat (ListPat pats _) = hs_lpats pats + hs_pat (ListPat pats _ _) = hs_lpats pats hs_pat (PArrPat pats _) = hs_lpats pats hs_pat (TuplePat pats _ _) = hs_lpats pats diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 1748e94709..c47066d1b6 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -1051,7 +1051,7 @@ tcIfaceExpr (IfaceCase scrut case_bndr alts) = do scrut_ty = exprType scrut' case_bndr' = mkLocalId case_bndr_name scrut_ty tc_app = splitTyConApp scrut_ty - -- NB: Won't always succeed (polymoprhic case) + -- NB: Won't always succeed (polymorphic case) -- but won't be demanded in those cases -- NB: not tcSplitTyConApp; we are looking at Core here -- look through non-rec newtypes to find the tycon that diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index 047cc018da..817d789a93 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -145,12 +145,14 @@ outputAsm dflags filenm cmm_stream = do ncg_uniqs <- mkSplitUniqSupply 'n' let filenmDyn = filenm ++ "-dyn" - withHandles f = doOutput filenm $ \h -> - ifGeneratingDynamicToo dflags - (doOutput filenmDyn $ \dynH -> - f [(h, dflags), - (dynH, doDynamicToo dflags)]) - (f [(h, dflags)]) + withHandles f = do debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm) + doOutput filenm $ \h -> + ifGeneratingDynamicToo dflags + (do debugTraceMsg dflags 4 (text "Outputing dynamic-too asm to" <+> text filenmDyn) + doOutput filenmDyn $ \dynH -> + f [(h, dflags), + (dynH, doDynamicToo dflags)]) + (f [(h, dflags)]) _ <- {-# SCC "OutputAsm" #-} withHandles $ \hs -> {-# SCC "NativeCodeGen" #-} diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 62ff424bb6..fa3b9dcad8 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -482,6 +482,7 @@ data PipelineOutput -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o. | SpecificFile FilePath -- ^ The output must go into the specified file. + deriving Show -- | Run a compilation pipeline, consisting of multiple phases. -- @@ -563,8 +564,9 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) SpecificFile fn -> SpecificFile (replaceExtension fn (objectSuf dflags')) Persistent -> Persistent Temporary -> Temporary + env' = env { output_spec = output' } hsc_env' <- newHscEnv dflags' - _ <- runPipeline' start_phase stop_phase hsc_env' env input_fn + _ <- runPipeline' start_phase stop_phase hsc_env' env' input_fn output' maybe_loc maybe_stub_o return () return r @@ -1023,8 +1025,11 @@ runPhase (Hsc src_flavour) input_fn dflags0 setStubO stub_o -- In the case of hs-boot files, generate a dummy .o-boot -- stamp file for the benefit of Make - when (isHsBoot src_flavour) $ + when (isHsBoot src_flavour) $ do liftIO $ touchObjectFile dflags' o_file + whenGeneratingDynamicToo dflags' $ do + let dyn_o_file = addBootSuffix (replaceExtension o_file (dynObjectSuf dflags')) + liftIO $ touchObjectFile dflags' dyn_o_file return (next_phase, output_fn) ----------------------------------------------------------------------------- @@ -1275,8 +1280,15 @@ runPhase As input_fn dflags , SysTools.FileOption "" outputFilename ]) + liftIO $ debugTraceMsg dflags 4 (text "Running the assembler") runAssembler input_fn output_fn - whenGeneratingDynamicToo dflags $ + -- If we're compiling a Haskell module (isHaskellishFile), and + -- we're doing -dynamic-too, then we also need to assemble the + -- -dyn assembly file. + env <- getPipeEnv + when (pe_isHaskellishFile env) $ whenGeneratingDynamicToo dflags $ do + liftIO $ debugTraceMsg dflags 4 + (text "Running the assembler again for -dynamic-too") runAssembler (input_fn ++ "-dyn") (replaceExtension output_fn (dynObjectSuf dflags)) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 9bfef011e2..3591a30d25 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -169,10 +169,13 @@ import qualified Data.Set as Set import Data.Word import System.FilePath import System.IO +import System.IO.Error import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet +import GHC.Foreign (withCString, peekCString) + -- ----------------------------------------------------------------------------- -- DynFlags @@ -480,6 +483,7 @@ data ExtensionFlag | Opt_BangPatterns | Opt_TypeFamilies | Opt_OverloadedStrings + | Opt_OverloadedLists | Opt_DisambiguateRecordFields | Opt_RecordWildCards | Opt_RecordPuns @@ -707,6 +711,8 @@ data DynFlags = DynFlags { pprCols :: Int, traceLevel :: Int, -- Standard level is 1. Less verbose is 0. + useUnicodeQuotes :: Bool, + -- | what kind of {-# SCC #-} to add automatically profAuto :: ProfAuto, @@ -1175,6 +1181,12 @@ initDynFlags dflags = do refGeneratedDumps <- newIORef Set.empty refLlvmVersion <- newIORef 28 wrapperNum <- newIORef 0 + canUseUnicodeQuotes <- do let enc = localeEncoding + str = "‛’" + (withCString enc str $ \cstr -> + do str' <- peekCString enc cstr + return (str == str')) + `catchIOError` \_ -> return False return dflags{ canGenerateDynamicToo = refCanGenerateDynamicToo, filesToClean = refFilesToClean, @@ -1182,7 +1194,8 @@ initDynFlags dflags = do filesToNotIntermediateClean = refFilesToNotIntermediateClean, generatedDumps = refGeneratedDumps, llvmVersion = refLlvmVersion, - nextWrapperNum = wrapperNum + nextWrapperNum = wrapperNum, + useUnicodeQuotes = canUseUnicodeQuotes } -- | The normal 'DynFlags'. Note that they is not suitable for use in this form @@ -1307,6 +1320,7 @@ defaultDynFlags mySettings = flushErr = defaultFlushErr, pprUserLength = 5, pprCols = 100, + useUnicodeQuotes = False, traceLevel = 1, profAuto = NoProfAuto, llvmVersion = panic "defaultDynFlags: No llvmVersion", @@ -2594,6 +2608,7 @@ xFlags = [ deprecatedForExtension "NamedFieldPuns" ), ( "DisambiguateRecordFields", Opt_DisambiguateRecordFields, nop ), ( "OverloadedStrings", Opt_OverloadedStrings, nop ), + ( "OverloadedLists", Opt_OverloadedLists, nop), ( "GADTs", Opt_GADTs, nop ), ( "GADTSyntax", Opt_GADTSyntax, nop ), ( "ViewPatterns", Opt_ViewPatterns, nop ), diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot index da54e49e66..04ec5a4e7d 100644 --- a/compiler/main/DynFlags.hs-boot +++ b/compiler/main/DynFlags.hs-boot @@ -9,3 +9,4 @@ targetPlatform :: DynFlags -> Platform pprUserLength :: DynFlags -> Int pprCols :: DynFlags -> Int unsafeGlobalDynFlags :: DynFlags +useUnicodeQuotes :: DynFlags -> Bool diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index ee40a1343d..483da4b5e4 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -17,7 +17,6 @@ module GHC ( runGhc, runGhcT, initGhcMonad, gcatch, gbracket, gfinally, printException, - printExceptionAndWarnings, handleSourceError, needsTemplateHaskell, diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs index 6b8c7bacdf..66034e0b50 100644 --- a/compiler/main/GhcMonad.hs +++ b/compiler/main/GhcMonad.hs @@ -18,7 +18,7 @@ module GhcMonad ( Session(..), withSession, modifySession, withTempSession, -- ** Warnings - logWarnings, printException, printExceptionAndWarnings, + logWarnings, printException, WarnErrLogger, defaultWarnErrLogger ) where @@ -110,8 +110,6 @@ instance MonadFix Ghc where instance ExceptionMonad Ghc where gcatch act handle = Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s - gblock (Ghc m) = Ghc $ \s -> gblock (m s) - gunblock (Ghc m) = Ghc $ \s -> gunblock (m s) gmask f = Ghc $ \s -> gmask $ \io_restore -> let @@ -169,8 +167,6 @@ instance MonadIO m => MonadIO (GhcT m) where instance ExceptionMonad m => ExceptionMonad (GhcT m) where gcatch act handle = GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s - gblock (GhcT m) = GhcT $ \s -> gblock (m s) - gunblock (GhcT m) = GhcT $ \s -> gunblock (m s) gmask f = GhcT $ \s -> gmask $ \io_restore -> let @@ -193,10 +189,6 @@ printException err = do dflags <- getSessionDynFlags liftIO $ printBagOfErrors dflags (srcErrorMessages err) -{-# DEPRECATED printExceptionAndWarnings "use printException instead" #-} -printExceptionAndWarnings :: GhcMonad m => SourceError -> m () -printExceptionAndWarnings = printException - -- | A function called to log warnings and errors. type WarnErrLogger = GhcMonad m => Maybe SourceError -> m () diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 40a7a25ccd..79af4f6673 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -284,10 +284,11 @@ initSysTools mbMinusB ++ gcc_args -- Other things being equal, as and ld are simply gcc + gcc_link_args_str <- getSetting "C compiler link flags" let as_prog = gcc_prog as_args = gcc_args ld_prog = gcc_prog - ld_args = gcc_args + ld_args = gcc_args ++ map Option (words gcc_link_args_str) -- We just assume on command line lc_prog <- getSetting "LLVM llc command" diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index d49d43702b..72b887a588 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -459,18 +459,21 @@ tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars | (var, var_v) <- varEnvElts vars , let tidy_var = lookup_var var tidy_var_v = lookup_var var_v - , isExportedId tidy_var - , isExternalId tidy_var_v + , isExternalId tidy_var && isExportedId tidy_var + , isExternalId tidy_var_v && isExportedId tidy_var_v , isDataConWorkId var || not (isImplicitId var) ] tidy_parallelVars = mkVarSet [ tidy_var | var <- varSetElems parallelVars , let tidy_var = lookup_var var - , isExternalId tidy_var] + , isExternalId tidy_var && isExportedId tidy_var + ] lookup_var var = lookupWithDefaultVarEnv var_env var var + -- We need to make sure that all names getting into the iface version of 'VectInfo' are + -- external; otherwise, 'MkIface' will bomb out. isExternalId = isExternalName . idName \end{code} diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index c6cdd8a4d2..36aebea2c7 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -1820,6 +1820,8 @@ genCCall32' :: DynFlags -> NatM InstrBlock genCCall32' dflags target dest_regs args = do let + prom_args = map (maybePromoteCArg dflags W32) args + -- Align stack to 16n for calls, assuming a starting stack -- alignment of 16n - word_size on procedure entry. Which we -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86] @@ -1831,7 +1833,7 @@ genCCall32' dflags target dest_regs args = do setDeltaNat (delta0 - arg_pad_size) use_sse2 <- sse2Enabled - push_codes <- mapM (push_arg use_sse2) (reverse args) + push_codes <- mapM (push_arg use_sse2) (reverse prom_args) delta <- getDeltaNat MASSERT (delta == delta0 - tot_arg_size) @@ -2055,12 +2057,14 @@ genCCall64' :: DynFlags -> NatM InstrBlock genCCall64' dflags target dest_regs args = do -- load up the register arguments + let prom_args = map (maybePromoteCArg dflags W32) args + (stack_args, int_regs_used, fp_regs_used, load_args_code) <- if platformOS platform == OSMinGW32 - then load_args_win args [] [] (allArgRegs platform) nilOL + then load_args_win prom_args [] [] (allArgRegs platform) nilOL else do (stack_args, aregs, fregs, load_args_code) - <- load_args args (allIntArgRegs platform) (allFPArgRegs platform) nilOL + <- load_args prom_args (allIntArgRegs platform) (allFPArgRegs platform) nilOL let fp_regs_used = reverse (drop (length fregs) (reverse (allFPArgRegs platform))) int_regs_used = reverse (drop (length aregs) (reverse (allIntArgRegs platform))) return (stack_args, int_regs_used, fp_regs_used, load_args_code) @@ -2231,9 +2235,6 @@ genCCall64' dflags target dest_regs args = do push_args rest code' | otherwise = do - -- we only ever generate word-sized function arguments. Promotion - -- has already happened: our Int8# type is kept sign-extended - -- in an Int#, for example. ASSERT(width == W64) return () (arg_op, arg_code) <- getOperand arg delta <- getDeltaNat @@ -2253,6 +2254,13 @@ genCCall64' dflags target dest_regs args = do SUB II64 (OpImm (ImmInt (n * wORD_SIZE dflags))) (OpReg rsp), DELTA (delta - n * arg_size)] +maybePromoteCArg :: DynFlags -> Width -> CmmExpr -> CmmExpr +maybePromoteCArg dflags wto arg + | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg] + | otherwise = arg + where + wfrom = cmmExprWidth dflags arg + -- | We're willing to inline and unroll memcpy/memset calls that touch -- at most these many bytes. This threshold is the same as the one -- used by GCC and LLVM. diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 2746faa34e..fdf75cf003 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -339,7 +339,7 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } } <0> { - "(#" / { ifExtension unboxedTuplesEnabled `alexAndPred` notFollowedBySymbol } + "(#" / { ifExtension unboxedTuplesEnabled } { token IToubxparen } "#)" / { ifExtension unboxedTuplesEnabled } { token ITcubxparen } @@ -2389,8 +2389,11 @@ dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToStr Nothing -> lexError "unknown pragma" known_pragma :: Map String Action -> AlexAccPred Int -known_pragma prags _ _ len (AI _ buf) = (isJust $ Map.lookup (clean_pragma (lexemeToString (offsetBytes (- len) buf) len)) prags) - && (nextCharIsNot buf (\c -> isAlphaNum c || c == '_')) +known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf) + = isKnown && nextCharIsNot curbuf pragmaNameChar + where l = lexemeToString startbuf (byteDiff startbuf curbuf) + isKnown = isJust $ Map.lookup (clean_pragma l) prags + pragmaNameChar c = isAlphaNum c || c == '_' clean_pragma :: String -> String clean_pragma prag = canon_ws (map toLower (unprefix prag)) diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 72537a9a1b..18651b97c2 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -1617,12 +1617,12 @@ tup_tail :: { [HsTupArg RdrName] } -- avoiding another shift/reduce-conflict. list :: { LHsExpr RdrName } - : texp { L1 $ ExplicitList placeHolderType [$1] } - | lexps { L1 $ ExplicitList placeHolderType (reverse (unLoc $1)) } - | texp '..' { LL $ ArithSeq noPostTcExpr (From $1) } - | texp ',' exp '..' { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) } - | texp '..' exp { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) } - | texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) } + : texp { L1 $ ExplicitList placeHolderType Nothing [$1] } + | lexps { L1 $ ExplicitList placeHolderType Nothing (reverse (unLoc $1)) } + | texp '..' { LL $ ArithSeq noPostTcExpr Nothing (From $1) } + | texp ',' exp '..' { LL $ ArithSeq noPostTcExpr Nothing (FromThen $1 $3) } + | texp '..' exp { LL $ ArithSeq noPostTcExpr Nothing (FromTo $1 $3) } + | texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr Nothing (FromThenTo $1 $3 $5) } | texp '|' flattenedpquals {% checkMonadComp >>= \ ctxt -> return (sL (comb2 $1 $>) $ diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index f7236b89c8..3695daef58 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -619,8 +619,8 @@ checkAPat msg loc e0 = do _ -> patFail msg loc e0 HsPar e -> checkLPat msg e >>= (return . ParPat) - ExplicitList _ es -> do ps <- mapM (checkLPat msg) es - return (ListPat ps placeHolderType) + ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es + return (ListPat ps placeHolderType Nothing) ExplicitPArr _ es -> do ps <- mapM (checkLPat msg) es return (PArrPat ps placeHolderType) diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index a67580a18c..19acf488e0 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -227,13 +227,19 @@ basicKnownKeyNames -- Stable pointers newStablePtrName, - -- GHC Extensions + -- GHC Extensions groupWithName, -- Strings and lists unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, - + + -- Overloaded lists + isListClassName, + fromListName, + fromListNName, + toListName, + -- List operations concatName, filterName, mapName, zipName, foldrName, buildName, augmentName, appendName, @@ -570,6 +576,11 @@ plus_RDR = varQual_RDR gHC_NUM (fsLit "+") fromString_RDR :: RdrName fromString_RDR = nameRdrName fromStringName +fromList_RDR, fromListN_RDR, toList_RDR :: RdrName +fromList_RDR = nameRdrName fromListName +fromListN_RDR = nameRdrName fromListNName +toList_RDR = nameRdrName toListName + compose_RDR :: RdrName compose_RDR = varQual_RDR gHC_BASE (fsLit ".") @@ -1002,6 +1013,13 @@ concatName = varQual gHC_LIST (fsLit "concat") concatIdKey filterName = varQual gHC_LIST (fsLit "filter") filterIdKey zipName = varQual gHC_LIST (fsLit "zip") zipIdKey +-- Overloaded lists +isListClassName, fromListName, fromListNName, toListName :: Name +isListClassName = clsQual gHC_EXTS (fsLit "IsList") isListClassKey +fromListName = methName gHC_EXTS (fsLit "fromList") fromListClassOpKey +fromListNName = methName gHC_EXTS (fsLit "fromListN") fromListNClassOpKey +toListName = methName gHC_EXTS (fsLit "toList") toListClassOpKey + -- Class Show showClassName :: Name showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey @@ -1743,6 +1761,12 @@ mzipIdKey = mkPreludeMiscIdUnique 196 ghciStepIoMClassOpKey :: Unique ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197 +-- Overloaded lists +isListClassKey, fromListClassOpKey, fromListNClassOpKey, toListClassOpKey :: Unique +isListClassKey = mkPreludeMiscIdUnique 198 +fromListClassOpKey = mkPreludeMiscIdUnique 199 +fromListNClassOpKey = mkPreludeMiscIdUnique 500 +toListClassOpKey = mkPreludeMiscIdUnique 501 ---------------- Template Haskell ------------------- -- USES IdUniques 200-499 diff --git a/compiler/prelude/PrelNames.lhs-boot b/compiler/prelude/PrelNames.lhs-boot index c14695b060..7b5365e621 100644 --- a/compiler/prelude/PrelNames.lhs-boot +++ b/compiler/prelude/PrelNames.lhs-boot @@ -1,9 +1,10 @@ - \begin{code} module PrelNames where import Module +import Unique mAIN :: Module +liftedTypeKindTyConKey :: Unique \end{code} diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index 2e55e497d7..079ab0cc98 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -100,6 +100,15 @@ primOpRules nm IntRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intO retLit zeroi , equalArgs >> retLit zeroi , equalArgs >> retLit zeroi ] +primOpRules nm AndIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.)) + , idempotent + , zeroElem zeroi ] +primOpRules nm OrIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.)) + , idempotent + , identityDynFlags zeroi ] +primOpRules nm XorIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 xor) + , identityDynFlags zeroi + , equalArgs >> retLit zeroi ] primOpRules nm IntNegOp = mkPrimOpRule nm 1 [ unaryLit negOp , inversePrimOp IntNegOp ] primOpRules nm ISllOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftL) diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index e83fcb5255..8ee2d3f53e 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -48,7 +48,7 @@ module TysWiredIn ( wordTyCon, wordDataCon, wordTyConName, wordTy, -- * List - listTyCon, nilDataCon, consDataCon, consDataConName, + listTyCon, nilDataCon, nilDataConName, consDataCon, consDataConName, listTyCon_RDR, consDataCon_RDR, listTyConName, mkListTy, mkPromotedListTy, diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index a5b0fec908..45472816c0 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -217,6 +217,17 @@ primop IntQuotRemOp "quotRemInt#" GenPrimOp {Rounds towards zero.} with can_fail = True +primop AndIOp "andI#" Dyadic Int# -> Int# -> Int# + with commutable = True + +primop OrIOp "orI#" Dyadic Int# -> Int# -> Int# + with commutable = True + +primop XorIOp "xorI#" Dyadic Int# -> Int# -> Int# + with commutable = True + +primop NotIOp "notI#" Monadic Int# -> Int# + primop IntNegOp "negateInt#" Monadic Int# -> Int# primop IntAddCOp "addIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) {Add with carry. First member of result is (wrapped) sum; diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 038e775fe9..90061b10a2 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -11,6 +11,7 @@ module RnEnv ( lookupLocalOccRn_maybe, lookupTypeOccRn, lookupKindOccRn, lookupGlobalOccRn, lookupGlobalOccRn_maybe, + reportUnboundName, HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, @@ -543,9 +544,11 @@ lookupLocalOccRn_maybe rdr_name -- lookupOccRn looks up an occurrence of a RdrName lookupOccRn :: RdrName -> RnM Name -lookupOccRn rdr_name = do - opt_name <- lookupOccRn_maybe rdr_name - maybe (unboundName WL_Any rdr_name) return opt_name +lookupOccRn rdr_name + = do { mb_name <- lookupOccRn_maybe rdr_name + ; case mb_name of + Just name -> return name + Nothing -> reportUnboundName rdr_name } lookupKindOccRn :: RdrName -> RnM Name -- Looking up a name occurring in a kind @@ -553,7 +556,7 @@ lookupKindOccRn rdr_name = do { mb_name <- lookupOccRn_maybe rdr_name ; case mb_name of Just name -> return name - Nothing -> unboundName WL_Any rdr_name } + Nothing -> reportUnboundName rdr_name } -- lookupPromotedOccRn looks up an optionally promoted RdrName. lookupTypeOccRn :: RdrName -> RnM Name @@ -571,13 +574,13 @@ lookup_demoted rdr_name = do { data_kinds <- xoptM Opt_DataKinds ; mb_demoted_name <- lookupOccRn_maybe demoted_rdr ; case mb_demoted_name of - Nothing -> unboundName WL_Any rdr_name + Nothing -> reportUnboundName rdr_name Just demoted_name | data_kinds -> return demoted_name | otherwise -> unboundNameX WL_Any rdr_name suggest_dk } | otherwise - = unboundName WL_Any rdr_name + = reportUnboundName rdr_name where suggest_dk = ptext (sLit "A data constructor of that name is in scope; did you mean -XDataKinds?") @@ -1354,6 +1357,9 @@ data WhereLooking = WL_Any -- Any binding | WL_Global -- Any top-level binding (local or imported) | WL_LocalTop -- Any top-level binding in this module +reportUnboundName :: RdrName -> RnM Name +reportUnboundName rdr = unboundName WL_Any rdr + unboundName :: WhereLooking -> RdrName -> RnM Name unboundName wl rdr = unboundNameX wl rdr empty diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 8e4d554a46..29674ca34c 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -53,6 +53,7 @@ import Outputable import SrcLoc import FastString import Control.Monad +import TysWiredIn ( nilDataConName ) \end{code} @@ -108,14 +109,18 @@ finishHsVar name ; return (e, unitFV name) } } rnExpr (HsVar v) - = do { opt_TypeHoles <- xoptM Opt_TypeHoles - ; if opt_TypeHoles && startsWithUnderscore (rdrNameOcc v) - then do { mb_name <- lookupOccRn_maybe v - ; case mb_name of - Nothing -> return (HsUnboundVar v, emptyFVs) - Just n -> finishHsVar n } - else do { name <- lookupOccRn v - ; finishHsVar name } } + = do { mb_name <- lookupOccRn_maybe v + ; case mb_name of { + Nothing -> do { opt_TypeHoles <- xoptM Opt_TypeHoles + ; if opt_TypeHoles && startsWithUnderscore (rdrNameOcc v) + then return (HsUnboundVar v, emptyFVs) + else do { n <- reportUnboundName v; finishHsVar n } } ; + Just name + | name == nilDataConName -- Treat [] as an ExplicitList, so that + -- OverloadedLists works correctly + -> rnExpr (ExplicitList placeHolderType Nothing []) + | otherwise + -> finishHsVar name } } rnExpr (HsIPVar v) = return (HsIPVar v, emptyFVs) @@ -249,9 +254,15 @@ rnExpr (HsDo do_or_lc stmts _) = do { ((stmts', _), fvs) <- rnStmts do_or_lc rnLExpr stmts (\ _ -> return ((), emptyFVs)) ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) } -rnExpr (ExplicitList _ exps) - = rnExprs exps `thenM` \ (exps', fvs) -> - return (ExplicitList placeHolderType exps', fvs) +rnExpr (ExplicitList _ _ exps) + = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists + ; (exps', fvs) <- rnExprs exps + ; if opt_OverloadedLists + then do { + ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName + ; return (ExplicitList placeHolderType (Just from_list_n_name) exps', fvs `plusFV` fvs') } + else + return (ExplicitList placeHolderType Nothing exps', fvs) } rnExpr (ExplicitPArr _ exps) = rnExprs exps `thenM` \ (exps', fvs) -> @@ -299,9 +310,15 @@ rnExpr (HsType a) = rnLHsType HsTypeCtx a `thenM` \ (t, fvT) -> return (HsType t, fvT) -rnExpr (ArithSeq _ seq) - = rnArithSeq seq `thenM` \ (new_seq, fvs) -> - return (ArithSeq noPostTcExpr new_seq, fvs) +rnExpr (ArithSeq _ _ seq) + = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists + ; (new_seq, fvs) <- rnArithSeq seq + ; if opt_OverloadedLists + then do { + ; (from_list_name, fvs') <- lookupSyntaxName fromListName + ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') } + else + return (ArithSeq noPostTcExpr Nothing new_seq, fvs) } rnExpr (PArrSeq _ seq) = rnArithSeq seq `thenM` \ (new_seq, fvs) -> diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 9738585aa4..a039f36b25 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -61,6 +61,8 @@ import SrcLoc import FastString import Literal ( inCharRange ) import Control.Monad ( when ) +import TysWiredIn ( nilDataCon ) +import DataCon ( dataConName ) \end{code} @@ -375,11 +377,20 @@ rnPatAndThen mk p@(ViewPat expr pat ty) rnPatAndThen mk (ConPatIn con stuff) -- rnConPatAndThen takes care of reconstructing the pattern - = rnConPatAndThen mk con stuff - -rnPatAndThen mk (ListPat pats _) - = do { pats' <- rnLPatsAndThen mk pats - ; return (ListPat pats' placeHolderType) } + -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on. + = case unLoc con == nameRdrName (dataConName nilDataCon) of + True -> do { ol_flag <- liftCps $ xoptM Opt_OverloadedLists + ; if ol_flag then rnPatAndThen mk (ListPat [] placeHolderType Nothing) + else rnConPatAndThen mk con stuff} + False -> rnConPatAndThen mk con stuff + +rnPatAndThen mk (ListPat pats _ _) + = do { opt_OverloadedLists <- liftCps $ xoptM Opt_OverloadedLists + ; pats' <- rnLPatsAndThen mk pats + ; case opt_OverloadedLists of + True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName + ; return (ListPat pats' placeHolderType (Just (placeHolderType, to_list_name)))} + False -> return (ListPat pats' placeHolderType Nothing) } rnPatAndThen mk (PArrPat pats _) = do { pats' <- rnLPatsAndThen mk pats diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 7ff473f8c7..cc410388df 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -44,6 +44,7 @@ import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices ) import Control.Monad import Data.List( partition ) +import Data.Traversable (traverse) import Maybes( orElse ) \end{code} @@ -339,7 +340,7 @@ rnAnnDecl (HsAnnotation provenance expr) = do rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars) rnAnnProvenance provenance = do - provenance' <- modifyAnnProvenanceNameM lookupTopBndrRn provenance + provenance' <- traverse lookupTopBndrRn provenance return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance')) \end{code} diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 6e01f9647a..62a546de96 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -621,6 +621,12 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) vectVars = mkVarSet $ catMaybes [ fmap snd $ lookupVarEnv (vectInfoVar (mg_vect_info guts)) bndr | Vect bndr _ <- mg_vect_decls guts] + ++ + catMaybes [ fmap snd $ lookupVarEnv (vectInfoVar (mg_vect_info guts)) bndr + | bndr <- bindersOfBinds binds] + -- FIXME: This second comprehensions is only needed as long as we + -- have vectorised bindings where we get "Could NOT call + -- vectorised from original version". ; (maybeVects, maybeVectVars) = case sm_phase mode of InitialPhase -> (mg_vect_decls guts, vectVars) diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 7374e62d1a..6a83268759 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -379,7 +379,7 @@ tcDeriving tycl_decls inst_decls deriv_decls deriveTypeable tys = [ L l (DerivDecl (L l (HsAppTy (noLoc (HsTyVar typeableClassName)) (L l (HsTyVar (tcdName t)))))) - | L l t <- tys ] + | L l t <- tys, not (isSynDecl t), not (isTypeFamilyDecl t) ] -- Prints the representable type family instance pprRepTy :: FamInst Unbranched -> SDoc diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 273301314a..7766dd721d 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -15,8 +15,8 @@ module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, tcInferRho, tcInferRhoNC, tcSyntaxOp, tcCheckId, - addExprErrCtxt ) where - + addExprErrCtxt) where + #include "HsVersions.h" #ifdef GHCI /* Only if bootstrapped */ @@ -401,12 +401,18 @@ tcExpr (ExplicitTuple tup_args boxity) res_ty ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) } -tcExpr (ExplicitList _ exprs) res_ty - = do { (coi, elt_ty) <- matchExpectedListTy res_ty - ; exprs' <- mapM (tc_elt elt_ty) exprs - ; return $ mkHsWrapCo coi (ExplicitList elt_ty exprs') } - where - tc_elt elt_ty expr = tcPolyExpr expr elt_ty +tcExpr (ExplicitList _ witness exprs) res_ty + = case witness of + Nothing -> do { (coi, elt_ty) <- matchExpectedListTy res_ty + ; exprs' <- mapM (tc_elt elt_ty) exprs + ; return $ mkHsWrapCo coi (ExplicitList elt_ty Nothing exprs') } + + Just fln -> do { list_ty <- newFlexiTyVarTy liftedTypeKind + ; fln' <- tcSyntaxOp ListOrigin fln (mkFunTys [intTy, list_ty] res_ty) + ; (coi, elt_ty) <- matchExpectedListTy list_ty + ; exprs' <- mapM (tc_elt elt_ty) exprs + ; return $ mkHsWrapCo coi (ExplicitList elt_ty (Just fln') exprs') } + where tc_elt elt_ty expr = tcPolyExpr expr elt_ty tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty @@ -757,40 +763,8 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty %************************************************************************ \begin{code} -tcExpr (ArithSeq _ seq@(From expr)) res_ty - = do { (coi, elt_ty) <- matchExpectedListTy res_ty - ; expr' <- tcPolyExpr expr elt_ty - ; enum_from <- newMethodFromName (ArithSeqOrigin seq) - enumFromName elt_ty - ; return $ mkHsWrapCo coi (ArithSeq enum_from (From expr')) } - -tcExpr (ArithSeq _ seq@(FromThen expr1 expr2)) res_ty - = do { (coi, elt_ty) <- matchExpectedListTy res_ty - ; expr1' <- tcPolyExpr expr1 elt_ty - ; expr2' <- tcPolyExpr expr2 elt_ty - ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) - enumFromThenName elt_ty - ; return $ mkHsWrapCo coi - (ArithSeq enum_from_then (FromThen expr1' expr2')) } - -tcExpr (ArithSeq _ seq@(FromTo expr1 expr2)) res_ty - = do { (coi, elt_ty) <- matchExpectedListTy res_ty - ; expr1' <- tcPolyExpr expr1 elt_ty - ; expr2' <- tcPolyExpr expr2 elt_ty - ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) - enumFromToName elt_ty - ; return $ mkHsWrapCo coi - (ArithSeq enum_from_to (FromTo expr1' expr2')) } - -tcExpr (ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty - = do { (coi, elt_ty) <- matchExpectedListTy res_ty - ; expr1' <- tcPolyExpr expr1 elt_ty - ; expr2' <- tcPolyExpr expr2 elt_ty - ; expr3' <- tcPolyExpr expr3 elt_ty - ; eft <- newMethodFromName (ArithSeqOrigin seq) - enumFromThenToName elt_ty - ; return $ mkHsWrapCo coi - (ArithSeq eft (FromThenTo expr1' expr2' expr3')) } +tcExpr (ArithSeq _ witness seq) res_ty + = tcArithSeq witness seq res_ty tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty @@ -851,6 +825,61 @@ tcExpr other _ = pprPanic "tcMonoExpr" (ppr other) %************************************************************************ %* * + Arithmetic sequences [a..b] etc +%* * +%************************************************************************ + +\begin{code} +tcArithSeq :: Maybe (SyntaxExpr Name) -> ArithSeqInfo Name -> TcRhoType + -> TcM (HsExpr TcId) + +tcArithSeq witness seq@(From expr) res_ty + = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr' <- tcPolyExpr expr elt_ty + ; enum_from <- newMethodFromName (ArithSeqOrigin seq) + enumFromName elt_ty + ; return $ mkHsWrapCo coi (ArithSeq enum_from wit' (From expr')) } + +tcArithSeq witness seq@(FromThen expr1 expr2) res_ty + = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr1' <- tcPolyExpr expr1 elt_ty + ; expr2' <- tcPolyExpr expr2 elt_ty + ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) + enumFromThenName elt_ty + ; return $ mkHsWrapCo coi (ArithSeq enum_from_then wit' (FromThen expr1' expr2')) } + +tcArithSeq witness seq@(FromTo expr1 expr2) res_ty + = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr1' <- tcPolyExpr expr1 elt_ty + ; expr2' <- tcPolyExpr expr2 elt_ty + ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) + enumFromToName elt_ty + ; return $ mkHsWrapCo coi (ArithSeq enum_from_to wit' (FromTo expr1' expr2')) } + +tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty + = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr1' <- tcPolyExpr expr1 elt_ty + ; expr2' <- tcPolyExpr expr2 elt_ty + ; expr3' <- tcPolyExpr expr3 elt_ty + ; eft <- newMethodFromName (ArithSeqOrigin seq) + enumFromThenToName elt_ty + ; return $ mkHsWrapCo coi (ArithSeq eft wit' (FromThenTo expr1' expr2' expr3')) } + +----------------- +arithSeqEltType :: Maybe (SyntaxExpr Name) -> TcRhoType + -> TcM (TcCoercion, TcType, Maybe (SyntaxExpr Id)) +arithSeqEltType Nothing res_ty + = do { (coi, elt_ty) <- matchExpectedListTy res_ty + ; return (coi, elt_ty, Nothing) } +arithSeqEltType (Just fl) res_ty + = do { list_ty <- newFlexiTyVarTy liftedTypeKind + ; fl' <- tcSyntaxOp ListOrigin fl (mkFunTy list_ty res_ty) + ; (coi, elt_ty) <- matchExpectedListTy list_ty + ; return (coi, elt_ty, Just fl') } +\end{code} + +%************************************************************************ +%* * Applications %* * %************************************************************************ diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 0f6a879b52..1e2961258d 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -97,7 +97,8 @@ hsPatType (LazyPat pat) = hsLPatType pat hsPatType (LitPat lit) = hsLitType lit hsPatType (AsPat var _) = idType (unLoc var) hsPatType (ViewPat _ _ ty) = ty -hsPatType (ListPat _ ty) = mkListTy ty +hsPatType (ListPat _ ty Nothing) = mkListTy ty +hsPatType (ListPat _ _ (Just (ty,_))) = ty hsPatType (PArrPat _ ty) = mkPArrTy ty hsPatType (TuplePat _ _ ty) = ty hsPatType (ConPatOut { pat_ty = ty }) = ty @@ -411,7 +412,7 @@ localSigWarnId sig_ns id | idName id `elemNameSet` sig_ns = return () | otherwise = warnMissingSig msg id where - msg = ptext (sLit "Polymophic local binding with no type signature:") + msg = ptext (sLit "Polymorphic local binding with no type signature:") warnMissingSig :: SDoc -> Id -> TcM () warnMissingSig msg id @@ -647,10 +648,14 @@ zonkExpr env (HsDo do_or_lc stmts ty) zonkTcTypeToType env ty `thenM` \ new_ty -> returnM (HsDo do_or_lc new_stmts new_ty) -zonkExpr env (ExplicitList ty exprs) +zonkExpr env (ExplicitList ty wit exprs) = zonkTcTypeToType env ty `thenM` \ new_ty -> + zonkWit env wit `thenM` \ new_wit -> zonkLExprs env exprs `thenM` \ new_exprs -> - returnM (ExplicitList new_ty new_exprs) + returnM (ExplicitList new_ty new_wit new_exprs) + where zonkWit _ Nothing = returnM Nothing + zonkWit env (Just fln) = zonkExpr env fln `thenM` \ new_fln -> + returnM (Just new_fln) zonkExpr env (ExplicitPArr ty exprs) = zonkTcTypeToType env ty `thenM` \ new_ty -> @@ -675,10 +680,14 @@ zonkExpr env (ExprWithTySigOut e ty) zonkExpr _ (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig" -zonkExpr env (ArithSeq expr info) +zonkExpr env (ArithSeq expr wit info) = zonkExpr env expr `thenM` \ new_expr -> + zonkWit env wit `thenM` \ new_wit -> zonkArithSeq env info `thenM` \ new_info -> - returnM (ArithSeq new_expr new_info) + returnM (ArithSeq new_expr new_wit new_info) + where zonkWit _ Nothing = returnM Nothing + zonkWit env (Just fln) = zonkExpr env fln `thenM` \ new_fln -> + returnM (Just new_fln) zonkExpr env (PArrSeq expr info) = zonkExpr env expr `thenM` \ new_expr -> @@ -991,10 +1000,17 @@ zonk_pat env (ViewPat expr pat ty) ; ty' <- zonkTcTypeToType env ty ; return (env', ViewPat expr' pat' ty') } -zonk_pat env (ListPat pats ty) +zonk_pat env (ListPat pats ty Nothing) = do { ty' <- zonkTcTypeToType env ty ; (env', pats') <- zonkPats env pats - ; return (env', ListPat pats' ty') } + ; return (env', ListPat pats' ty' Nothing) } + +zonk_pat env (ListPat pats ty (Just (ty2,wit))) + = do { wit' <- zonkExpr env wit + ; ty2' <- zonkTcTypeToType env ty2 + ; ty' <- zonkTcTypeToType env ty + ; (env', pats') <- zonkPats env pats + ; return (env', ListPat pats' ty' (Just (ty2',wit'))) } zonk_pat env (PArrPat pats ty) = do { ty' <- zonkTcTypeToType env ty diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 9775ea77b0..cde55a65fd 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -181,7 +181,7 @@ tcHsSigTypeNC ctxt (L loc hs_ty) -- The kind is checked by checkValidType, and isn't necessarily -- of kind * in a Template Haskell quote eg [t| Maybe |] - -- Generalise here: see Note [ generalisation] + -- Generalise here: see Note [Kind generalisation] ; ty <- tcCheckHsTypeAndGen hs_ty kind -- Zonk to expose kind information to checkValidType diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 2889c53e82..f4759659d6 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -30,6 +30,7 @@ import Id import Var import Name import TcEnv +--import TcExpr import TcMType import TcValidity( arityErr ) import TcType @@ -282,7 +283,7 @@ mkLocalBinder name ty Note [Polymorphism and pattern bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When is_mono holds we are not generalising -But the signature can still be polymoprhic! +But the signature can still be polymorphic! data T = MkT (forall a. a->a) x :: forall a. a->a MkT x = <rhs> @@ -451,11 +452,20 @@ tc_pat penv (SigPatIn pat sig_ty) pat_ty thing_inside ------------------------ -- Lists, tuples, arrays -tc_pat penv (ListPat pats _) pat_ty thing_inside - = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy pat_ty +tc_pat penv (ListPat pats _ Nothing) pat_ty thing_inside + = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy pat_ty ; (pats', res) <- tcMultiple (\p -> tc_lpat p elt_ty) pats penv thing_inside - ; return (mkHsWrapPat coi (ListPat pats' elt_ty) pat_ty, res) + ; return (mkHsWrapPat coi (ListPat pats' elt_ty Nothing) pat_ty, res) + } + +tc_pat penv (ListPat pats _ (Just (_,e))) pat_ty thing_inside + = do { list_pat_ty <- newFlexiTyVarTy liftedTypeKind + ; e' <- tcSyntaxOp ListOrigin e (mkFunTy pat_ty list_pat_ty) + ; (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy list_pat_ty + ; (pats', res) <- tcMultiple (\p -> tc_lpat p elt_ty) + pats penv thing_inside + ; return (mkHsWrapPat coi (ListPat pats' elt_ty (Just (pat_ty,e'))) list_pat_ty, res) } tc_pat penv (PArrPat pats _) pat_ty thing_inside diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index c103385e4e..5b7eb739b4 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -1475,7 +1475,7 @@ tcGhciStmts stmts -- 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)) ; + (noLoc $ ExplicitList unitTy Nothing (map mk_item ids)) ; mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy]) (nlHsVar id) ; stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] @@ -1575,27 +1575,42 @@ tcRnType :: HscEnv -> IO (Messages, Maybe (Type, Kind)) tcRnType hsc_env ictxt normalise rdr_type = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext hsc_env ictxt $ do { - - (rn_type, _fvs) <- rnLHsType GHCiCtx rdr_type ; - failIfErrsM ; + setInteractiveContext hsc_env ictxt $ + setXOptM Opt_PolyKinds $ -- See Note [Kind-generalise in tcRnType] + do { (rn_type, _fvs) <- rnLHsType GHCiCtx rdr_type + ; failIfErrsM -- Now kind-check the type -- It can have any rank or kind - ty <- tcHsSigType GhciCtxt rn_type ; + ; ty <- tcHsSigType GhciCtxt rn_type ; - ty' <- if normalise - then do { fam_envs <- tcGetFamInstEnvs - ; return (snd (normaliseType fam_envs ty)) } - -- normaliseType returns a coercion - -- which we discard - else return ty ; - - return (ty', typeKind ty) - } + ; ty' <- if normalise + then do { fam_envs <- tcGetFamInstEnvs + ; return (snd (normaliseType fam_envs ty)) } + -- normaliseType returns a coercion + -- which we discard + else return ty ; + ; return (ty', typeKind ty) } \end{code} +Note [Kind-generalise in tcRnType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We switch on PolyKinds when kind-checking a user type, so that we will +kind-generalise the type. This gives the right default behaviour at +the GHCi prompt, where if you say ":k T", and T has a polymorphic +kind, you'd like to see that polymorphism. Of course. If T isn't +kind-polymorphic you won't get anything unexpected, but the apparent +*loss* of polymorphism, for types that you know are polymorphic, is +quite surprising. See Trac #7688 for a discussion. + + +%************************************************************************ +%* * + tcRnDeclsi +%* * +%************************************************************************ + tcRnDeclsi exists to allow class, data, and other declarations in GHCi. \begin{code} diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 0b28f4db80..e70f67422d 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -1543,7 +1543,8 @@ data CtOrigin | FunDepOrigin | HoleOrigin | UnboundOccurrenceOf RdrName - + | ListOrigin -- An overloaded list + pprO :: CtOrigin -> SDoc pprO (GivenOrigin sk) = ppr sk pprO (OccurrenceOf name) = hsep [ptext (sLit "a use of"), quotes (ppr name)] @@ -1580,6 +1581,7 @@ pprO AnnOrigin = ptext (sLit "an annotation") pprO FunDepOrigin = ptext (sLit "a functional dependency") pprO HoleOrigin = ptext (sLit "a use of") <+> quotes (ptext $ sLit "_") pprO (UnboundOccurrenceOf name) = hsep [ptext (sLit "an undeclared identifier"), quotes (ppr name)] +pprO ListOrigin = ptext (sLit "an overloaded list") instance Outputable CtOrigin where ppr = pprO diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index e0af05bdad..b21888a76d 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -266,6 +266,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds meta_tvs = filter isMetaTyVar (varSetElems (tyVarsOfCts quant_cand)) ; ((flats, _insols), _extra_binds) <- runTcS $ do { mapM_ (promoteAndDefaultTyVar untch gbl_tvs) meta_tvs + -- See Note [Promote _and_ default when inferring] ; _implics <- solveInteract quant_cand ; getInertUnsolved } ; return (map ctPred $ filter isWantedCt (bagToList flats)) } @@ -910,6 +911,7 @@ have an instance (C ((x:*) -> Int)). The instance doesn't match -- but it should! If we don't solve the constraint, we'll stupidly quantify over (C (a->Int)) and, worse, in doing so zonkQuantifiedTyVar will quantify over (b:*) instead of (a:OpenKind), which can lead to disaster; see Trac #7332. +Trac #7641 is a simpler example. Note [Float Equalities out of Implications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 1add302eb0..679d39cb7c 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -419,14 +419,18 @@ splitAppTys ty = split ty ty [] mkNumLitTy :: Integer -> Type mkNumLitTy n = LitTy (NumTyLit n) +-- | Is this a numeric literal. We also look through type synonyms. isNumLitTy :: Type -> Maybe Integer +isNumLitTy ty | Just ty1 <- tcView ty = isNumLitTy ty1 isNumLitTy (LitTy (NumTyLit n)) = Just n isNumLitTy _ = Nothing mkStrLitTy :: FastString -> Type mkStrLitTy s = LitTy (StrTyLit s) +-- | Is this a symbol literal. We also look through type synonyms. isStrLitTy :: Type -> Maybe FastString +isStrLitTy ty | Just ty1 <- tcView ty = isStrLitTy ty1 isStrLitTy (LitTy (StrTyLit s)) = Just s isStrLitTy _ = Nothing diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index b748b8943d..f7fdd595aa 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -666,17 +666,9 @@ See Trac #2766. \begin{code} pprTcApp :: Prec -> (Prec -> a -> SDoc) -> TyCon -> [a] -> SDoc -pprTcApp _ _ tc [] -- No brackets for SymOcc - = pp_nt_debug <> ppr tc - where - pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc - then ptext (sLit "<recnt>") - else ptext (sLit "<nt>")) - | otherwise = empty - pprTcApp _ pp tc [ty] - | tc `hasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp TopPrec ty) - | tc `hasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty) + | tc `hasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp TopPrec ty) + | tc `hasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty) pprTcApp p pp tc tys | isTupleTyCon tc && tyConArity tc == length tys @@ -701,27 +693,35 @@ pprTcApp p pp tc tys = pprInfixApp p pp (ppr tc) ty1 ty2 | otherwise - = ppr_type_name_app p pp (ppr tc) (isSymOcc (getOccName tc)) tys + = ppr_type_name_app p pp (getName tc) (ppr tc) tys ---------------- -pprTypeApp :: NamedThing a => a -> [Type] -> SDoc --- The first arg is the tycon, or sometimes class --- Print infix if the tycon/class looks like an operator +pprTypeApp :: TyCon -> [Type] -> SDoc pprTypeApp tc tys - = pprTypeNameApp TopPrec ppr_type (getName tc) tys + = ppr_type_name_app TopPrec ppr_type (getName tc) (ppr tc) tys + -- We have to to use ppr on the TyCon (not its name) + -- so that we get promotion quotes in the right place pprTypeNameApp :: Prec -> (Prec -> a -> SDoc) -> Name -> [a] -> SDoc -- Used for classes and coercions as well as types; that's why it's separate from pprTcApp pprTypeNameApp p pp name tys - = ppr_type_name_app p pp (ppr name) (isSymOcc (getOccName name)) tys + = ppr_type_name_app p pp name (ppr name) tys + +ppr_type_name_app :: Prec -> (Prec -> a -> SDoc) -> Name -> SDoc -> [a] -> SDoc +ppr_type_name_app p pp nm_tc pp_tc tys + | not (isSymOcc (nameOccName nm_tc)) + = pprPrefixApp p pp_tc (map (pp TyConPrec) tys) -ppr_type_name_app :: Prec -> (Prec -> a -> SDoc) -> SDoc -> Bool -> [a] -> SDoc -ppr_type_name_app p pp pp_tc is_sym_occ tys - | is_sym_occ -- Print infix if possible - , [ty1,ty2] <- tys -- We know nothing of precedence though + | [ty1,ty2] <- tys -- Infix, two arguments; + -- we know nothing of precedence though = pprInfixApp p pp pp_tc ty1 ty2 + + | nm_tc `hasKey` liftedTypeKindTyConKey + || nm_tc `hasKey` unliftedTypeKindTyConKey + = ASSERT( null tys ) pp_tc -- Do not wrap *, # in parens + | otherwise - = pprPrefixApp p (pprPrefixVar is_sym_occ pp_tc) (map (pp TyConPrec) tys) + = pprPrefixApp p (parens pp_tc) (map (pp TyConPrec) tys) ---------------- pprInfixApp :: Prec -> (Prec -> a -> SDoc) -> SDoc -> a -> a -> SDoc diff --git a/compiler/utils/Exception.hs b/compiler/utils/Exception.hs index b4908997a8..850393e359 100644 --- a/compiler/utils/Exception.hs +++ b/compiler/utils/Exception.hs @@ -21,11 +21,11 @@ tryIO = try -- | A monad that can catch exceptions. A minimal definition -- requires a definition of 'gcatch'. -- --- Implementations on top of 'IO' should implement 'gblock' and 'gunblock' to --- eventually call the primitives 'Control.Exception.block' and --- 'Control.Exception.unblock' respectively. These are used for +-- Implementations on top of 'IO' should implement 'gmask' to +-- eventually call the primitive 'Control.Exception.mask'. +-- These are used for -- implementations that support asynchronous exceptions. The default --- implementations of 'gbracket' and 'gfinally' use 'gblock' and 'gunblock' +-- implementations of 'gbracket' and 'gfinally' use 'gmask' -- thus rarely require overriding. -- class MonadIO m => ExceptionMonad m where @@ -46,20 +46,6 @@ class MonadIO m => ExceptionMonad m where -- exception handling monad instead of just 'IO'. gfinally :: m a -> m b -> m a - -- | DEPRECATED, here for backwards compatibilty. Instances can - -- define either 'gmask', or both 'block' and 'unblock'. - gblock :: m a -> m a - -- | DEPRECATED, here for backwards compatibilty Instances can - -- define either 'gmask', or both 'block' and 'unblock'. - gunblock :: m a -> m a - -- XXX we're keeping these two methods for the time being because we - -- have to interact with Haskeline's MonadException class which - -- still has block/unblock; see GhciMonad.hs. - - gmask f = gblock (f gunblock) - gblock f = gmask (\_ -> f) - gunblock f = f -- XXX wrong; better override this if you need it - gbracket before after thing = gmask $ \restore -> do a <- before @@ -76,8 +62,6 @@ class MonadIO m => ExceptionMonad m where instance ExceptionMonad IO where gcatch = Control.Exception.catch gmask f = mask (\x -> f x) - gblock = block - gunblock = unblock gtry :: (ExceptionMonad m, Exception e) => m a -> m (Either e a) gtry act = gcatch (act >>= \a -> return (Right a)) diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 4e741b44fb..f26f918068 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -72,6 +72,7 @@ module Outputable ( import {-# SOURCE #-} DynFlags( DynFlags, targetPlatform, pprUserLength, pprCols, + useUnicodeQuotes, unsafeGlobalDynFlags ) import {-# SOURCE #-} Module( Module, ModuleName, moduleName ) import {-# SOURCE #-} Name( Name, nameModule ) @@ -260,7 +261,9 @@ pprDeeper d = SDoc $ \ctx -> case ctx of pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc -- Truncate a list that list that is longer than the current depth -pprDeeperList f ds = SDoc work +pprDeeperList f ds + | null ds = f [] + | otherwise = SDoc work where work ctx@SDC{sdocStyle=PprUser q (PartWay n)} | n==0 = Pretty.text "..." @@ -446,7 +449,11 @@ cparen b d = SDoc $ Pretty.cparen b . runSDoc d -- 'quotes' encloses something in single quotes... -- but it omits them if the thing begins or ends in a single quote -- so that we don't get `foo''. Instead we just have foo'. -quotes d = SDoc $ \sty -> +quotes d = + sdocWithDynFlags $ \dflags -> + if useUnicodeQuotes dflags + then char '‛' <> d <> char '’' + else SDoc $ \sty -> let pp_d = runSDoc d sty str = show pp_d in case (str, snocView str) of diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs index 706fc85166..fb0c148610 100644 --- a/compiler/vectorise/Vectorise/Exp.hs +++ b/compiler/vectorise/Vectorise/Exp.hs @@ -1211,12 +1211,17 @@ maybeParrTy ty maybeParrTy (ForAllTy _ ty) = maybeParrTy ty maybeParrTy _ = return False --- Are the types of all variables in the 'Scalar' class? +-- Are the types of all variables in the 'Scalar' class or toplevel variables? +-- +-- NB: 'liftSimple' does not abstract over toplevel variables. -- allScalarVarType :: [Var] -> VM Bool -allScalarVarType vs = and <$> mapM (isScalar . varType) vs +allScalarVarType vs = and <$> mapM isScalarOrToplevel vs + where + isScalarOrToplevel v | isToplevel v = return True + | otherwise = isScalar (varType v) --- Are the types of all variables in the set in the 'Scalar' class? +-- Are the types of all variables in the set in the 'Scalar' class or toplevel variables? -- allScalarVarTypeSet :: VarSet -> VM Bool allScalarVarTypeSet = allScalarVarType . varSetElems diff --git a/configure.ac b/configure.ac index 199ce5139b..78a157b536 100644 --- a/configure.ac +++ b/configure.ac @@ -94,22 +94,6 @@ dnl ** Tell the make system which OS we are using dnl $OSTYPE is set by the operating system to "msys" or "cygwin" or something AC_SUBST(OSTYPE) -dnl ** Booting from .hc files? -dnl -------------------------------------------------------------- -AC_ARG_ENABLE(hc-boot, -[AC_HELP_STRING([--enable-hc-boot], -[Boot the Glasgow Haskell Compiler from intermediate .hc files. - (This option is mostly of interest to porters.) [default=no]])], -[ if test x"$enableval" = x"yes"; then - BootingFromHc=YES - else - BootingFromHc=NO - fi -], -[BootingFromHc=NO] -) -AC_SUBST(BootingFromHc) - AC_ARG_ENABLE(bootstrap-with-devel-snapshot, [AC_HELP_STRING([--enable-bootstrap-with-devel-snapshot], [Allow bootstrapping using a development snapshot of GHC. This is not guaranteed to work.])], @@ -144,28 +128,29 @@ if test "$WithGhc" != ""; then fi fi -dnl ** Must have GHC to build GHC, unless --enable-hc-boot is on -if test "$BootingFromHc" = "NO"; then - if test "$WithGhc" = ""; then - AC_MSG_ERROR([GHC is required unless bootstrapping from .hc files.]) - fi - FP_COMPARE_VERSIONS([$GhcVersion],[-lt],[7.4], +dnl ** Must have GHC to build GHC +if test "$WithGhc" = "" +then + AC_MSG_ERROR([GHC is required.]) +fi +FP_COMPARE_VERSIONS([$GhcVersion],[-lt],[7.4], [AC_MSG_ERROR([GHC version 7.4 or later is required to compile GHC.])])dnl - if test `expr $GhcMinVersion % 2` = "1"; then - if test "$EnableBootstrapWithDevelSnaphost" = "NO"; then +if test `expr $GhcMinVersion % 2` = "1" +then + if test "$EnableBootstrapWithDevelSnaphost" = "NO" + then AC_MSG_ERROR([ $WithGhc is a development snapshot of GHC, version $GhcVersion. Bootstrapping using this version of GHC is not supported, and may not work. Use --enable-bootstrap-with-devel-snapshot to try it anyway, or --with-ghc to specify a different GHC to use.]) - fi - fi + fi +fi - GHC_PACKAGE_DB_FLAG=package-db - FP_COMPARE_VERSIONS([$GhcVersion],[-lt],[7.5],GHC_PACKAGE_DB_FLAG=package-conf) - AC_SUBST(GHC_PACKAGE_DB_FLAG) -fi; +GHC_PACKAGE_DB_FLAG=package-db +FP_COMPARE_VERSIONS([$GhcVersion],[-lt],[7.5],GHC_PACKAGE_DB_FLAG=package-conf) +AC_SUBST(GHC_PACKAGE_DB_FLAG) # GHC is passed to Cabal, so we need a native path if test "${WithGhc}" != "" @@ -215,15 +200,12 @@ FPTOOLS_SET_PLATFORM_VARS # Verify that the installed (bootstrap) GHC is capable of generating # code for the requested build platform. -if test "$BootingFromHc" = "NO" +if test "$BuildPlatform" != "$bootstrap_target" then - if test "$BuildPlatform" != "$bootstrap_target" - then - echo "This GHC (${WithGhc}) does not generate code for the build platform" - echo " GHC target platform : $bootstrap_target" - echo " Desired build platform : $BuildPlatform" - exit 1 - fi + echo "This GHC (${WithGhc}) does not generate code for the build platform" + echo " GHC target platform : $bootstrap_target" + echo " Desired build platform : $BuildPlatform" + exit 1 fi # Testing if we shall enable shared libs support on Solaris. @@ -516,23 +498,6 @@ FIND_LLVM_PROG([OPT], [opt], [opt]) OptCmd="$OPT" AC_SUBST([OptCmd]) -dnl ** Mac OS X: explicit deployment target -dnl -------------------------------------------------------------- -AC_ARG_WITH([macosx-deployment-target], -[AC_HELP_STRING([--with-macosx-deployment-target=VERSION], - [Build for Mac OS VERSION and higher (default= version of build host)])], -[FP_MACOSX_DEPLOYMENT_TARGET="$withval" - if test "x$TargetOS_CPP-$TargetVendor_CPP" != "xdarwin-apple"; then - # ignore everywhere, but on Mac OS - AC_MSG_WARN([--macosx-deployment-target is only available on Mac OS X]) - FP_MACOSX_DEPLOYMENT_TARGET=none - fi], -[FP_MACOSX_DEPLOYMENT_TARGET=none] -) -FP_CHECK_MACOSX_DEPLOYMENT_TARGET -AC_SUBST(MACOSX_DEPLOYMENT_VERSION) -AC_SUBST(MACOSX_DEPLOYMENT_SDK) - dnl -------------------------------------------------------------- dnl End of configure script option section dnl -------------------------------------------------------------- @@ -685,16 +650,10 @@ dnl ** check for ghc-pkg command FP_PROG_GHC_PKG dnl ** check for installed happy binary + version -dnl (don't do it if we're booting from .hc files though.) -if test "$BootingFromHc" = "NO"; then FPTOOLS_HAPPY -fi; dnl ** check for installed alex binary + version -dnl (don't do it if we're booting from .hc files though.) -if test "$BootingFromHc" = "NO"; then FPTOOLS_ALEX -fi; dnl -------------------------------------------------- dnl ### program checking section ends here ### @@ -976,16 +935,10 @@ Configure completed successfully. Target platform : $TargetPlatform "] -if test "$BootingFromHc" = "YES"; then -echo ["\ - Bootstrapping from HC files. -"] -else echo ["\ Bootstrapping using : $WithGhc which is version : $GhcVersion "] -fi if test "x$CC_LLVM_BACKEND" = "x1"; then if test "x$CC_CLANG_BACKEND" = "x1"; then diff --git a/distrib/configure.ac.in b/distrib/configure.ac.in index 2f96a1a7eb..09b54577bf 100644 --- a/distrib/configure.ac.in +++ b/distrib/configure.ac.in @@ -9,9 +9,6 @@ AC_INIT([The Glorious Glasgow Haskell Compilation System], [@ProjectVersion@], [ FP_BINDIST_GHC_PWD FP_FIND_ROOT -BootingFromHc=NO -AC_SUBST(BootingFromHc) - dnl-------------------------------------------------------------------- dnl * Deal with arguments telling us gmp is somewhere odd dnl-------------------------------------------------------------------- diff --git a/docs/users_guide/extending_ghc.xml b/docs/users_guide/extending_ghc.xml index 1bce3fa7b4..2c7f0210a8 100644 --- a/docs/users_guide/extending_ghc.xml +++ b/docs/users_guide/extending_ghc.xml @@ -226,12 +226,13 @@ install _ todo = do return (CoreDoPluginPass "Say name" pass : todo) pass :: ModGuts -> CoreM ModGuts -pass = bindsOnlyPass (mapM printBind) - where printBind :: CoreBind -> CoreM CoreBind - printBind bndr@(NonRec b _) = do - putMsgS $ "Non-recursive binding named " ++ showSDoc (ppr b) +pass = do dflags <- getDynFlags + bindsOnlyPass (mapM (printBind dflags)) + where printBind :: DynFlags -> CoreBind -> CoreM CoreBind + printBind dflags bndr@(NonRec b _) = do + putMsgS $ "Non-recursive binding named " ++ showSDoc dflags (ppr b) return bndr - printBind bndr = return bndr + printBind _ bndr = return bndr </programlisting> </sect3> diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index f856f66dcf..299b4d527b 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -809,6 +809,13 @@ <entry><option>-XNoOverloadedStrings</option></entry> </row> <row> + <entry><option>-XOverloadedLists</option></entry> + <entry>Enable <link linkend="overloaded-lists">overloaded lists</link>. + </entry> + <entry>dynamic</entry> + <entry><option>-XNoOverloadedLists</option></entry> + </row> + <row> <entry><option>-XGADTs</option></entry> <entry>Enable <link linkend="gadt">generalised algebraic data types</link>. </entry> diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index eee6223db0..03682bf848 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -225,6 +225,14 @@ the same. </para> <para> +Note that when unboxed tuples are enabled, +<literal>(#</literal> is a single lexeme, so for example when using +operators like <literal>#</literal> and <literal>#-</literal> you need +to write <literal>( # )</literal> and <literal>( #- )</literal> rather than +<literal>(#)</literal> and <literal>(#-)</literal>. +</para> + +<para> Unboxed tuples are used for functions that need to return multiple values, but they avoid the heap allocation normally associated with using fully-fledged tuples. When an unboxed tuple is returned, the @@ -4656,6 +4664,189 @@ to work since it gets translated into an equality comparison. </para> </sect2> +<sect2 id="overloaded-lists"> +<title>Overloaded lists</title> + +<para> GHC supports <emphasis>overloading of the list notation</emphasis>. +Let us recap the notation for +constructing lists. In Haskell, the list notation can be be used in the +following seven ways: + +<programlisting> +[] -- Empty list +[x] -- x : [] +[x,y,z] -- x : y : z : [] +[x .. ] -- enumFrom x +[x,y ..] -- enumFromThen x y +[x .. y] -- enumFromTo x y +[x,y .. z] -- enumFromThenTo x y z +</programlisting> + +When the <option>OverloadedLists</option> extension is turned on, the +aforementioned seven notations are desugared as follows: </para> + +<programlisting> +[] -- fromListN 0 [] +[x] -- fromListN 1 (x : []) +[x,y,z] -- fromListN 3 (x : y : z : []) +[x .. ] -- fromList (enumFrom x) +[x,y ..] -- fromList (enumFromThen x y) +[x .. y] -- fromList (enumFromTo x y) +[x,y .. z] -- fromList (enumFromThenTo x y z) +</programlisting> + +<para> This extension allows programmers to use the list notation for +construction of structures like: <literal>Set</literal>, +<literal>Map</literal>, <literal>IntMap</literal>, <literal>Vector</literal>, +<literal>Text</literal> and <literal>Array</literal>. The following code +listing gives a few examples:</para> + +<programlisting> +['0' .. '9'] :: Set Char +[1 .. 10] :: Vector Int +[("default",0), (k1,v1)] :: Map String Int +['a' .. 'z'] :: Text +</programlisting> +<para> +List patterns are also overloaded. When the <option>OverloadedLists</option> +extension is turned on, these definitions are desugared as follows +<programlisting> +f [] = ... -- f (toList -> []) = ... +g [x,y,z] = ... -- g (toList -> [x,y,z]) = ... +</programlisting> +(Here we are using view-pattern syntax for the translation, see <xref linkend="view-patterns"/>.) +</para> + +<sect3> +<title>The <literal>IsList</literal> class</title> + +<para>In the above desugarings, the functions <literal>toList</literal>, +<literal>fromList</literal> and <literal>fromListN</literal> are all +methods of +the <literal>IsList</literal> class, which is itself exported from +the <literal>GHC.Exts</literal> module. +The type class is defined as follows:</para> + +<programlisting> +class IsList l where + type Item l + + fromList :: [Item l] -> l + toList :: l -> [Item l] + + fromListN :: Int -> [Item l] -> l + fromListN _ = fromList +</programlisting> + +<para>The <literal>FromList</literal> class and its methods are intended to be +used in conjunction with the <option>OverloadedLists</option> extension. +<itemizedlist> +<listitem> <para> The type function +<literal>Item</literal> returns the type of items of the +structure <literal>l</literal>. +</para></listitem> +<listitem><para> +The function <literal>fromList</literal> +constructs the structure <literal>l</literal> from the given list of +<literal>Item l</literal>. +</para></listitem> +<listitem><para> +The function <literal>fromListN</literal> takes the +input list's length as a hint. Its behaviour should be equivalent to +<literal>fromList</literal>. The hint can be used for more efficient +construction of the structure <literal>l</literal> compared to +<literal>fromList</literal>. If the given hint is not equal to the input +list's length the behaviour of <literal>fromListN</literal> is not +specified. +</para></listitem> +<listitem><para> +The function <literal>toList</literal> should be +the inverse of <literal>fromList</literal>. +</para></listitem> +</itemizedlist> +</para> +<para>It is perfectly fine to declare new instances +of <literal>IsList</literal>, so that list notation becomes +useful for completely new data types. +Here are several example instances: +<programlisting> +instance FromList [a] where + type Item [a] = a + fromList = id + toList = id + +instance (Ord a) => FromList (Set a) where + type Item (Set a) = a + fromList = Set.fromList + toList = Set.toList + +instance (Ord k) => FromList (Map k v) where + type Item (Map k v) = (k,v) + fromList = Map.fromList + toList = Map.toList + +instance FromList (IntMap v) where + type Item (IntMap v) = (Int,v) + fromList = IntMap.fromList + toList = IntMap.toList + +instance FromList Text where + type Item Text = Char + fromList = Text.pack + toList = Text.unpack + +instance FromList (Vector a) where + type Item (Vector a) = a + fromList = Vector.fromList + fromListN = Vector.fromListN + toList = Vector.toList +</programlisting> +</para> +</sect3> + +<sect3> +<title>Rebindable syntax</title> + +<para> When desugaring list notation with <option>-XOverloadedLists</option> +GHC uses the <literal>fromList</literal> (etc) methods from module <literal>GHC.Exts</literal>. +You do not need to import <literal>GHC.Exts</literal> for this to happen. +</para> +<para> However if you use <option>-XRebindableSyntax</option>, then +GHC instead uses whatever is in +scope with the names of <literal>toList</literal>, <literal>fromList</literal> and +<literal>fromListN</literal>. That is, these functions are rebindable; +c.f. <xref linkend="rebindable-syntax"/>. </para> +</sect3> + +<sect3> +<title>Defaulting</title> + +<para>Currently, the <literal>IsList</literal> class is not accompanied with +defaulting rules. Although feasible, not much thought has gone into how to +specify the meaning of the default declarations like:</para> + +<programlisting> +default ([a]) +</programlisting> +</sect3> + +<sect3> +<title>Speculation about the future</title> + + +<para>The current implementation of the <option>OverloadedLists</option> +extension can be improved by handling the lists that are only populated with +literals in a special way. More specifically, the compiler could allocate such +lists statically using a compact representation and allow +<literal>IsList</literal> instances to take advantage of the compact +representation. Equipped with this capability the +<option>OverloadedLists</option> extension will be in a good position to +subsume the <option>OverloadedStrings</option> extension (currently, as a +special case, string literals benefit from statically allocated compact +representation).</para> +</sect3> +</sect2> + </sect1> <sect1 id="type-families"> diff --git a/driver/ghci/ghc.mk b/driver/ghci/ghc.mk index 7220090696..4b41849a21 100644 --- a/driver/ghci/ghc.mk +++ b/driver/ghci/ghc.mk @@ -54,7 +54,7 @@ install_driver_ghcii: GHCII_SCRIPT=$(DESTDIR)$(bindir)/ghcii.sh install_driver_ghcii: GHCII_SCRIPT_VERSIONED = $(DESTDIR)$(bindir)/ghcii-$(ProjectVersion).sh install_driver_ghcii: $(call INSTALL_DIR,$(DESTDIR)$(bindir)) - $(call removeFiles,$(GHCII_SCRIPT)) + $(call removeFiles,"$(GHCII_SCRIPT)") echo "#!$(SHELL)" >> $(GHCII_SCRIPT) echo 'exec "$$0"/../ghc --interactive $${1+"$$@"}' >> $(GHCII_SCRIPT) $(EXECUTABLE_FILE) $(GHCII_SCRIPT) @@ -1,7 +1,6 @@ - # ----------------------------------------------------------------------------- # -# (c) 2009 The University of Glasgow +# (c) 2009-2013 The University of Glasgow # # This file is part of the GHC build system. # @@ -208,6 +207,7 @@ endif # ----------------------------------------------------------------------------- # Compilation Flags +include rules/distdir-opts.mk include rules/distdir-way-opts.mk # ----------------------------------------------------------------------------- @@ -228,7 +228,8 @@ include rules/cmm-objs.mk ifneq "$(CLEANING)" "YES" include rules/hs-suffix-rules-srcdir.mk -include rules/hs-suffix-rules.mk +include rules/hs-suffix-way-rules-srcdir.mk +include rules/hs-suffix-way-rules.mk include rules/hi-rule.mk include rules/c-suffix-rules.mk include rules/cmm-suffix-rules.mk @@ -324,7 +325,7 @@ endif # Properties of packages # These lists say "if this package is built, here's a property it has" -# They do not say "this package will be built"; see $(PACKAGES_xx) for that +# They do not say "this package will be built"; see $(PACKAGES_STAGExx) for that # Packages that are built but not installed PKGS_THAT_ARE_INTREE_ONLY := haskeline terminfo xhtml @@ -355,7 +356,10 @@ PKGS_THAT_USE_TH := $(PKGS_THAT_ARE_DPH) # # We assume that the stage0 compiler has a suitable bytestring package, # so we don't have to include it below. -PKGS_THAT_BUILD_WITH_STAGE0 = Cabal/Cabal hpc binary bin-package-db hoopl transformers +PKGS_THAT_BUILD_WITH_STAGE0 = Cabal/Cabal hpc bin-package-db hoopl transformers +ifeq "$(Windows)" "NO" +PKGS_THAT_BUILD_WITH_STAGE0 += terminfo +endif # $(EXTRA_PACKAGES) is another classification, of packages built but # not installed @@ -464,7 +468,7 @@ $(eval $(call extra-packages)) # parallelism, but we don't know the dependencies until we've # generated the package-data.mk files. define fixed_pkg_dep -libraries/$1/$2/package-data.mk : $$(GHC_PKG_INPLACE) $$(fixed_pkg_prev) +libraries/$1/$2/package-data.mk : $$(fixed_pkg_prev) fixed_pkg_prev:=libraries/$1/$2/package-data.mk endef @@ -566,23 +570,6 @@ libraries/dph/dph-lifted-copy_dist-install_EXCLUDED_WAYS := dyn libraries/dph/dph-lifted-vseg_dist-install_EXCLUDED_WAYS := dyn endif -# ---------------------------------------------- -# Checking packages with 'cabal check' - -ifeq "$(phase)" "final" -ifeq "$(CHECK_PACKAGES)" "YES" -all: check_packages -endif -endif - -# These packages don't pass the Cabal checks because hs-source-dirs -# points outside the source directory. This isn't a real problem in -# these cases, so we just skip checking them. -# NB. these must come before we include the ghc.mk files below, because -# they disable the relevant rules. -# In compiler's case, include-dirs points outside of the source tree -CHECKED_compiler = YES - # ----------------------------------------------------------------------------- # Include build instructions from all subdirs @@ -755,8 +742,8 @@ $(eval $(call clean-target,$(BOOTSTRAPPING_CONF),,$(BOOTSTRAPPING_CONF))) # lost). fixed_pkg_prev= $(foreach pkg,$(PACKAGES_STAGE0),$(eval $(call fixed_pkg_dep,$(pkg),dist-boot))) - -compiler/stage1/package-data.mk : $(fixed_pkg_prev) +utils/ghc-pkg/dist/package-data.mk: $(fixed_pkg_prev) +compiler/stage1/package-data.mk: $(fixed_pkg_prev) endif ifneq "$(BINDIST)" "YES" @@ -943,7 +930,6 @@ ifeq "$(DYNAMIC_BY_DEFAULT)" "YES" endif $(foreach p, $(INSTALLED_PKG_DIRS), \ $(call make-command, \ - CROSS_COMPILE="$(CrossCompilePrefix)" \ "$(GHC_CABAL_INPLACE)" copy \ "$(STRIP_CMD)" \ $p $(INSTALL_DISTDIR_$p) \ @@ -954,7 +940,6 @@ endif "$(INSTALLED_GHC_PKG_REAL)" --force --global-package-db "$(INSTALLED_PACKAGE_CONF)" update rts/package.conf.install $(foreach p, $(INSTALLED_PKG_DIRS), \ $(call make-command, \ - CROSS_COMPILE="$(CrossCompilePrefix)" \ "$(GHC_CABAL_INPLACE)" register \ "$(INSTALLED_GHC_REAL)" \ "$(INSTALLED_GHC_PKG_REAL)" \ @@ -1206,16 +1191,6 @@ publish-sdist : $(call try10Times,$(PublishCp) $(SRC_DIST_TESTSUITE_TARBALL) $(PublishLocation)/dist) endif -ifeq "$(BootingFromHc)" "YES" -# In a normal build we use GHC to compile C files (see -# rules/c-suffix-rules.mk), which passes a number of its own options -# to the C compiler. So when bootstrapping we have to provide these -# flags explicitly to C compilations. -SRC_CC_OPTS += -DNO_REGS -DUSE_MINIINTERPRETER -SRC_CC_OPTS += -D__GLASGOW_HASKELL__=$(ProjectVersionInt) -SRC_CC_OPTS += $(addprefix -I,$(GHC_INCLUDE_DIRS)) -endif - # ----------------------------------------------------------------------------- # sdisting libraries @@ -1350,6 +1325,8 @@ endif # Numbered phase targets .PHONY: phase_0_builds +phase_0_builds: $(utils/ghc-pkg_dist_depfile_haskell) +phase_0_builds: $(utils/ghc-pkg_dist_depfile_c_asm) phase_0_builds: $(utils/hsc2hs_dist_depfile_haskell) phase_0_builds: $(utils/hsc2hs_dist_depfile_c_asm) phase_0_builds: $(utils/genprimopcode_dist_depfile_haskell) diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index 2a6badbff0..e61e1409de 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -204,8 +204,6 @@ instance GhcMonad (InputT GHCi) where instance ExceptionMonad GHCi where gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r) - gblock (GHCi m) = GHCi $ \r -> gblock (m r) - gunblock (GHCi m) = GHCi $ \r -> gunblock (m r) gmask f = GHCi $ \s -> gmask $ \io_restore -> let @@ -227,9 +225,6 @@ instance ExceptionMonad (InputT GHCi) where gcatch = Haskeline.catch gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_) - gblock = Haskeline.liftIOOp_ gblock - gunblock = Haskeline.liftIOOp_ gunblock - isOptionSet :: GHCiOption -> GHCi Bool isOptionSet opt = do st <- getGHCiState diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index c5d2808c44..5b3e572650 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -81,7 +81,6 @@ import Exception hiding (catch) import Foreign.C import Foreign.Safe -import System.Cmd import System.Directory import System.Environment import System.Exit ( exitWith, ExitCode(..) ) @@ -89,6 +88,7 @@ import System.FilePath import System.IO import System.IO.Error import System.IO.Unsafe ( unsafePerformIO ) +import System.Process import Text.Printf #ifndef mingw32_HOST_OS @@ -2944,7 +2944,8 @@ showException se = -- may never be delivered. Thanks to Marcin for pointing out the bug. ghciHandle :: ExceptionMonad m => (SomeException -> m a) -> m a -> m a -ghciHandle h m = gcatch m $ \e -> gunblock (h e) +ghciHandle h m = gmask $ \restore -> + gcatch (restore m) $ \e -> restore (h e) ghciTry :: GHCi a -> GHCi (Either SomeException a) ghciTry (GHCi m) = GHCi $ \s -> gtry (m s) diff --git a/ghc/ghc.mk b/ghc/ghc.mk index 6df1a50746..5c37115886 100644 --- a/ghc/ghc.mk +++ b/ghc/ghc.mk @@ -31,6 +31,11 @@ ifeq "$(compiler_stage1_VERSION_MUNGED)" "YES" ghc_stage1_CONFIGURE_OPTS += --constraint "ghc == $(compiler_stage1_MUNGED_VERSION)" endif +# This package doesn't pass the Cabal checks because data-dir +# points outside the source directory. This isn't a real problem, so +# we just skip the check. +ghc_NO_CHECK = YES + ghc_stage1_MORE_HC_OPTS = $(GhcStage1HcOpts) ghc_stage2_MORE_HC_OPTS = $(GhcStage2HcOpts) ghc_stage3_MORE_HC_OPTS = $(GhcStage3HcOpts) @@ -156,11 +161,6 @@ $(GHC_STAGE2) : | $(TOUCHY) $(GHC_STAGE3) : | $(TOUCHY) endif -ifeq "$(BootingFromHc)" "YES" -$(GHC_STAGE2) : $(ALL_STAGE1_LIBS) -ghc_stage2_OTHER_OBJS += $(compiler_stage2_v_LIB) $(ALL_STAGE1_LIBS) $(ALL_STAGE1_LIBS) $(ALL_STAGE1_LIBS) $(ALL_RTS_LIBS) $(libffi_STATIC_LIB) -endif - endif INSTALL_LIBS += settings @@ -177,7 +177,7 @@ else install: install_ghc_post .PHONY: install_ghc_post install_ghc_post: install_bins - $(call removeFiles,$(DESTDIR)$(bindir)/ghc.exe) + $(call removeFiles,"$(DESTDIR)$(bindir)/ghc.exe") "$(MV)" -f $(DESTDIR)$(bindir)/ghc-stage$(INSTALL_GHC_STAGE).exe $(DESTDIR)$(bindir)/$(CrossCompilePrefix)ghc.exe endif diff --git a/includes/Cmm.h b/includes/Cmm.h index 1505b1cb6a..ca8e51af78 100644 --- a/includes/Cmm.h +++ b/includes/Cmm.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- * - * (c) The University of Glasgow 2004-2012 + * (c) The University of Glasgow 2004-2013 * * This file is included at the top of all .cmm source files (and * *only* .cmm files). It defines a collection of useful macros for @@ -583,6 +583,12 @@ #define OVERWRITING_CLOSURE(c) /* nothing */ #endif +#ifdef THREADED_RTS +#define prim_write_barrier prim %write_barrier() +#else +#define prim_write_barrier /* nothing */ +#endif + /* ----------------------------------------------------------------------------- Ticky macros -------------------------------------------------------------------------- */ diff --git a/includes/rts/storage/SMPClosureOps.h b/includes/rts/storage/SMPClosureOps.h index cd6a789af4..39349874f7 100644 --- a/includes/rts/storage/SMPClosureOps.h +++ b/includes/rts/storage/SMPClosureOps.h @@ -1,6 +1,6 @@ /* ---------------------------------------------------------------------------- * - * (c) The GHC Team, 2005 + * (c) The GHC Team, 2005-2013 * * Macros for THREADED_RTS support * @@ -12,7 +12,7 @@ #ifdef CMINUSMINUS #define unlockClosure(ptr,info) \ - prim %write_barrier(); \ + prim_write_barrier; \ StgHeader_info(ptr) = info; #else diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h index 68c6212396..b9b4f2304f 100644 --- a/includes/stg/MiscClosures.h +++ b/includes/stg/MiscClosures.h @@ -472,6 +472,7 @@ extern StgWord RTS_VAR(atomic_modify_mutvar_mutex); extern StgWord RTS_VAR(RtsFlags); // bogus type // Stable.c +extern StgWord RTS_VAR(stable_ptr_table); extern StgWord RTS_VAR(stable_name_table); // Profiling.c diff --git a/libraries/Cabal b/libraries/Cabal -Subproject 4b43bd95753e5f3e29d7bfbe6bba8477715ac29 +Subproject 7e2bdc37dbb3c6bafc0287e93fd922360818cda diff --git a/libraries/Win32 b/libraries/Win32 -Subproject 21335a30161c099da79ae9619c9782e5e32e464 +Subproject 1f9f7175e747aad7c424f5b12be5b95f15286f0 diff --git a/libraries/binary b/libraries/binary -Subproject 2d31cea238d0d08885c457475fc354dbf2b8897 +Subproject feb287316af6b4acfbb4c54553ec55d8b10012d diff --git a/libraries/bytestring b/libraries/bytestring -Subproject aaf84424aee2bac53b5121115b95ae47bcce17a +Subproject 9692aaf0bf9b203f9249a1414637328fd31fc04 diff --git a/libraries/haskeline b/libraries/haskeline -Subproject 6ee5fc8ccdee410486a826cadfb2a0a560d6050 +Subproject 3a92ddd63d4edc622ad4af044c5b664aa64c3dd diff --git a/libraries/pretty b/libraries/pretty -Subproject ab7e8d91470bb94c9e184dffbec89d0aae116f9 +Subproject 0b8eada2d4d62dd09ee361d8b6ca9b13e657320 diff --git a/libraries/random b/libraries/random -Subproject 69bfde219bab869729fdbe9c1496371f912bf41 +Subproject 4b68afd3356674f12a67a4e381fa9becd704fab diff --git a/mk/config.mk.in b/mk/config.mk.in index 987ee32808..4831a7c34f 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -36,37 +36,12 @@ V = 1 # ################################################################################ -# BootingFromHc - build GHC and the libraries from .hc files? -# (unregisterised only) -BootingFromHc = @BootingFromHc@ - NO_INCLUDE_DEPS = NO NO_INCLUDE_PKGDATA = NO # Should we build latex docs? LATEX_DOCS = NO -# Mac OS X deployment target (to cross-compile for older OS versions) -# -MACOSX_DEPLOYMENT_VERSION = @MACOSX_DEPLOYMENT_VERSION@ -MACOSX_DEPLOYMENT_SDK = @MACOSX_DEPLOYMENT_SDK@ - -ifneq "$(MACOSX_DEPLOYMENT_VERSION)" "" -MACOSX_DEPLOYMENT_CC_OPTS = -mmacosx-version-min=$(MACOSX_DEPLOYMENT_VERSION) \ - -isysroot $(MACOSX_DEPLOYMENT_SDK) \ - --no-builtin-fprintf -MACOSX_DEPLOYMENT_LD_OPTS = -mmacosx-version-min=$(MACOSX_DEPLOYMENT_VERSION) \ - -Wl,-syslibroot,$(MACOSX_DEPLOYMENT_SDK) -# We don't extend SRC_CC_OPTS and friends here directly, as (a) they may get -# overwritten in build.mk and (b) we must not use the deployment options in -# stage 1 or we get a linker error if the bootstrap compiler is for a more -# recent OS version. -# -# We need --no-builtin-fprintf, as the use of the builtin function optimisation -# for fprintf together with #include "PosixSource" in the RTS leads to the -# use of fwrite$UNIX2003 (with GCC 4.0.1 on Mac OS X 10.5.2). -endif - ################################################################################ # # Variables that control how the compiler itself is built @@ -152,6 +127,9 @@ endif # cabal-install's that are in the wild don't handle it properly. DYNAMIC_BY_DEFAULT = NO +# For now, we unconditionally disable building with -dynamic-too +DYNAMIC_TOO = NO + # Build a compiler that will build *unregisterised* libraries and # binaries by default. Unregisterised code is supposed to compile and # run without any support for architecture-specific assembly mangling, diff --git a/mk/custom-settings.mk b/mk/custom-settings.mk index e64bb36561..f59a208388 100644 --- a/mk/custom-settings.mk +++ b/mk/custom-settings.mk @@ -5,7 +5,7 @@ ifeq "$(Validating)" "YES" include mk/validate-settings.mk -include mk/validate.mk else --include mk/build.mk +-include $(firstword $(wildcard mk/$(TargetPlatformFull)-build.mk) mk/build.mk) endif ifeq "$(BINDIST)" "YES" diff --git a/mk/ways.mk b/mk/ways.mk index c3651163c7..5608dbd9ef 100644 --- a/mk/ways.mk +++ b/mk/ways.mk @@ -77,7 +77,7 @@ WAY_debug_p_NAME=debug profiled WAY_debug_p_HC_OPTS= -static -optc-DDEBUG -prof # Way 'thr_debug': -WAY_thr_debug_NAME=threaded +WAY_thr_debug_NAME=threaded debug WAY_thr_debug_HC_OPTS= -static -optc-DTHREADED_RTS -optc-DDEBUG # Way 'thr_debug_p': @@ -43,7 +43,6 @@ # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # localpath tag remotepath VCS # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -. - ghc.git git ghc-tarballs - ghc-tarballs.git git utils/hsc2hs - hsc2hs.git git utils/haddock - haddock.git git @@ -83,3 +82,4 @@ libraries/random dph - libraries/primitive dph - git libraries/vector dph - git libraries/dph dph packages/dph.git git +. - ghc.git git diff --git a/rts/Prelude.h b/rts/Prelude.h index dcd7b94da4..89e80a0a3d 100644 --- a/rts/Prelude.h +++ b/rts/Prelude.h @@ -93,6 +93,7 @@ PRELUDE_INFO(base_GHCziStable_StablePtr_con_info); #define runSparks_closure DLL_IMPORT_DATA_REF(base_GHCziConcziSync_runSparks_closure) #define ensureIOManagerIsRunning_closure DLL_IMPORT_DATA_REF(base_GHCziConcziIO_ensureIOManagerIsRunning_closure) +#define ioManagerCapabilitiesChanged_closure DLL_IMPORT_DATA_REF(base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure) #define runHandlers_closure DLL_IMPORT_DATA_REF(base_GHCziConcziSignal_runHandlers_closure) #define flushStdHandles_closure DLL_IMPORT_DATA_REF(base_GHCziTopHandler_flushStdHandles_closure) diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c index e83d047695..7b7d488e2b 100644 --- a/rts/RtsStartup.c +++ b/rts/RtsStartup.c @@ -207,6 +207,7 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) getStablePtr((StgPtr)runSparks_closure); getStablePtr((StgPtr)ensureIOManagerIsRunning_closure); + getStablePtr((StgPtr)ioManagerCapabilitiesChanged_closure); #ifndef mingw32_HOST_OS getStablePtr((StgPtr)runHandlers_closure); #endif diff --git a/rts/Schedule.c b/rts/Schedule.c index f39ef96273..abd317cc62 100644 --- a/rts/Schedule.c +++ b/rts/Schedule.c @@ -133,7 +133,7 @@ static void scheduleYield (Capability **pcap, Task *task); #if defined(THREADED_RTS) static nat requestSync (Capability **pcap, Task *task, nat sync_type); static void acquireAllCapabilities(Capability *cap, Task *task); -static void releaseAllCapabilities(Capability *cap, Task *task); +static void releaseAllCapabilities(nat n, Capability *cap, Task *task); static void startWorkerTasks (nat from USED_IF_THREADS, nat to USED_IF_THREADS); #endif static void scheduleStartSignalHandlers (Capability *cap); @@ -1411,11 +1411,11 @@ static void acquireAllCapabilities(Capability *cap, Task *task) task->cap = cap; } -static void releaseAllCapabilities(Capability *cap, Task *task) +static void releaseAllCapabilities(nat n, Capability *cap, Task *task) { nat i; - for (i = 0; i < n_capabilities; i++) { + for (i = 0; i < n; i++) { if (cap->no != i) { task->cap = &capabilities[i]; releaseCapability(&capabilities[i]); @@ -1437,7 +1437,6 @@ scheduleDoGC (Capability **pcap, Task *task USED_IF_THREADS, rtsBool heap_census; nat collect_gen; #ifdef THREADED_RTS - rtsBool idle_cap[n_capabilities]; rtsBool gc_type; nat i, sync; StgTSO *tso; @@ -1499,6 +1498,13 @@ scheduleDoGC (Capability **pcap, Task *task USED_IF_THREADS, } } while (sync); + // don't declare this until after we have sync'd, because + // n_capabilities may change. + rtsBool idle_cap[n_capabilities]; +#ifdef DEBUG + unsigned int old_n_capabilities = n_capabilities; +#endif + interruptAllCapabilities(); // The final shutdown GC is always single-threaded, because it's @@ -1686,6 +1692,10 @@ delete_threads_and_gc: } #if defined(THREADED_RTS) + + // If n_capabilities has changed during GC, we're in trouble. + ASSERT(n_capabilities == old_n_capabilities); + if (gc_type == SYNC_GC_PAR) { releaseGCThreads(cap); @@ -1732,7 +1742,7 @@ delete_threads_and_gc: #if defined(THREADED_RTS) if (gc_type == SYNC_GC_SEQ) { // release our stash of capabilities. - releaseAllCapabilities(cap, task); + releaseAllCapabilities(n_capabilities, cap, task); } #endif @@ -1957,6 +1967,7 @@ setNumCapabilities (nat new_n_capabilities USED_IF_THREADS) StgTSO* t; nat g, n; Capability *old_capabilities = NULL; + nat old_n_capabilities = n_capabilities; if (new_n_capabilities == enabled_capabilities) return; @@ -2050,17 +2061,17 @@ setNumCapabilities (nat new_n_capabilities USED_IF_THREADS) } } - // We're done: release the original Capabilities - releaseAllCapabilities(cap,task); - - // Start worker tasks on the new Capabilities - startWorkerTasks(n_capabilities, new_n_capabilities); - - // finally, update n_capabilities + // update n_capabilities before things start running if (new_n_capabilities > n_capabilities) { n_capabilities = enabled_capabilities = new_n_capabilities; } + // Start worker tasks on the new Capabilities + startWorkerTasks(old_n_capabilities, new_n_capabilities); + + // We're done: release the original Capabilities + releaseAllCapabilities(old_n_capabilities, cap,task); + // We can't free the old array until now, because we access it // while updating pointers in updateCapabilityRefs(). if (old_capabilities) { @@ -2068,10 +2079,7 @@ setNumCapabilities (nat new_n_capabilities USED_IF_THREADS) } // Notify IO manager that the number of capabilities has changed. - rts_evalIO( - &cap, - &base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure, - NULL); + rts_evalIO(&cap, ioManagerCapabilitiesChanged_closure, NULL); rts_unlock(cap); diff --git a/rts/Stable.c b/rts/Stable.c index e1807faa72..0dade10105 100644 --- a/rts/Stable.c +++ b/rts/Stable.c @@ -278,28 +278,36 @@ freeStablePtr(StgStablePtr sp) /* * get at the real stuff...remove indirections. - * It untags pointers before dereferencing and - * retags the real stuff with its tag (if there - * is any) when returning. - * - * ToDo: move to a better home. */ -static -StgClosure* -removeIndirections(StgClosure* p) +static StgClosure* +removeIndirections (StgClosure* p) { - StgWord tag = GET_CLOSURE_TAG(p); - StgClosure* q = UNTAG_CLOSURE(p); - - while (get_itbl(q)->type == IND || - get_itbl(q)->type == IND_STATIC || - get_itbl(q)->type == IND_PERM) { - q = ((StgInd *)q)->indirectee; - tag = GET_CLOSURE_TAG(q); - q = UNTAG_CLOSURE(q); - } + StgClosure* q; + + while (1) + { + q = UNTAG_CLOSURE(p); + + switch (get_itbl(q)->type) { + case IND: + case IND_STATIC: + case IND_PERM: + p = ((StgInd *)q)->indirectee; + continue; + + case BLACKHOLE: + p = ((StgInd *)q)->indirectee; + if (GET_CLOSURE_TAG(p) != 0) { + continue; + } else { + break; + } - return TAG_CLOSURE(tag,q); + default: + break; + } + return p; + } } StgWord diff --git a/rts/Updates.h b/rts/Updates.h index b4ff7d131b..1bd742a746 100644 --- a/rts/Updates.h +++ b/rts/Updates.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- * - * (c) The GHC Team, 1998-2004 + * (c) The GHC Team, 1998-2013 * * Performing updates. * @@ -46,7 +46,7 @@ \ OVERWRITING_CLOSURE(p1); \ StgInd_indirectee(p1) = p2; \ - prim %write_barrier(); \ + prim_write_barrier; \ SET_INFO(p1, stg_BLACKHOLE_info); \ LDV_RECORD_CREATE(p1); \ bd = Bdescr(p1); \ diff --git a/rts/ghc.mk b/rts/ghc.mk index 7cbb96ef0a..a4c7acb8b7 100644 --- a/rts/ghc.mk +++ b/rts/ghc.mk @@ -153,8 +153,6 @@ endif $(call distdir-way-opts,rts,dist,$1) $(call c-suffix-rules,rts,dist,$1,YES) $(call cmm-suffix-rules,rts,dist,$1) -$(call hs-suffix-rules-srcdir,rts,dist,$1,.) -# hs-suffix-rules-srcdir is needed when BootingFromHc to get the .hc rules rts_$1_LIB_NAME = libHSrts$$($1_libsuf) rts_$1_LIB = rts/dist/build/$$(rts_$1_LIB_NAME) @@ -224,6 +222,8 @@ endef # And expand the above for each way: $(foreach way,$(rts_WAYS),$(eval $(call build-rts-way,$(way)))) +$(eval $(call distdir-opts,rts,dist)) + #----------------------------------------------------------------------------- # Flags for compiling every file @@ -281,11 +281,6 @@ ifeq "$(UseLibFFIForAdjustors)" "YES" rts_CC_OPTS += -DUSE_LIBFFI_FOR_ADJUSTORS endif -# Mac OS X: make sure we compile for the right OS version -rts_CC_OPTS += $(MACOSX_DEPLOYMENT_CC_OPTS) -rts_HC_OPTS += $(addprefix -optc, $(MACOSX_DEPLOYMENT_CC_OPTS)) -rts_LD_OPTS += $(addprefix -optl, $(MACOSX_DEPLOYMENT_LD_OPTS)) - # We *want* type-checking of hand-written cmm. rts_HC_OPTS += -dcmm-lint @@ -547,9 +542,7 @@ endif $(eval $(call manual-package-config,rts)) -ifneq "$(BootingFromHc)" "YES" rts/package.conf.inplace : $(includes_H_CONFIG) $(includes_H_PLATFORM) -endif # ----------------------------------------------------------------------------- # installing diff --git a/rts/sm/Evac.c b/rts/sm/Evac.c index 4dfbad7e37..35d849e005 100644 --- a/rts/sm/Evac.c +++ b/rts/sm/Evac.c @@ -35,7 +35,7 @@ StgWord64 whitehole_spin = 0; #define HEAP_ALLOCED_GC(p) HEAP_ALLOCED(p) #endif -#if !defined(PARALLEL_GC) +#if !defined(PARALLEL_GC) || defined(PROFILING) #define copy_tag_nolock(p, info, src, size, stp, tag) \ copy_tag(p, info, src, size, stp, tag) #endif @@ -113,6 +113,17 @@ copy_tag(StgClosure **p, const StgInfoTable *info, const StgInfoTable *new_info; new_info = (const StgInfoTable *)cas((StgPtr)&src->header.info, (W_)info, MK_FORWARDING_PTR(to)); if (new_info != info) { +#ifdef PROFILING + // We copied this object at the same time as another + // thread. We'll evacuate the object again and the copy + // we just made will be discarded at the next GC, but we + // may have copied it after the other thread called + // SET_EVACUAEE_FOR_LDV(), which would confuse the LDV + // profiler when it encounters this closure in + // processHeapClosureForDead. So we reset the LDVW field + // here. + LDVW(to) = 0; +#endif return evacuate(p); // does the failed_to_evac stuff } else { *p = TAG_CLOSURE(tag,(StgClosure*)to); @@ -126,11 +137,13 @@ copy_tag(StgClosure **p, const StgInfoTable *info, #ifdef PROFILING // We store the size of the just evacuated object in the LDV word so that // the profiler can guess the position of the next object later. + // This is safe only if we are sure that no other thread evacuates + // the object again, so we cannot use copy_tag_nolock when PROFILING. SET_EVACUAEE_FOR_LDV(from, size); #endif } -#if defined(PARALLEL_GC) +#if defined(PARALLEL_GC) && !defined(PROFILING) STATIC_INLINE void copy_tag_nolock(StgClosure **p, const StgInfoTable *info, StgClosure *src, nat size, nat gen_no, StgWord tag) diff --git a/rts/sm/GCAux.c b/rts/sm/GCAux.c index 3df36d7449..29c1e9d604 100644 --- a/rts/sm/GCAux.c +++ b/rts/sm/GCAux.c @@ -93,6 +93,14 @@ isAlive(StgClosure *p) p = ((StgInd *)q)->indirectee; continue; + case BLACKHOLE: + p = ((StgInd*)q)->indirectee; + if (GET_CLOSURE_TAG(p) != 0) { + continue; + } else { + return NULL; + } + default: // dead. return NULL; diff --git a/rts/win32/ThrIOManager.c b/rts/win32/ThrIOManager.c index 41a1505de0..c4974016c1 100644 --- a/rts/win32/ThrIOManager.c +++ b/rts/win32/ThrIOManager.c @@ -1,167 +1,159 @@ -/* -----------------------------------------------------------------------------
- *
- * (c) The GHC Team, 1998-2006
- *
- * The IO manager thread in THREADED_RTS.
- * See also libraries/base/GHC/Conc.lhs.
- *
- * ---------------------------------------------------------------------------*/
-
-#include "Rts.h"
-#include "IOManager.h"
-#include "Prelude.h"
-#include <windows.h>
-
-// Here's the Event that we use to wake up the IO manager thread
-static HANDLE io_manager_event = INVALID_HANDLE_VALUE;
-
-// must agree with values in GHC.Conc:
-#define IO_MANAGER_WAKEUP 0xffffffff
-#define IO_MANAGER_DIE 0xfffffffe
-// spurios wakeups are returned as zero.
-// console events are ((event<<1) | 1)
-
-#if defined(THREADED_RTS)
-
-#define EVENT_BUFSIZ 256
-Mutex event_buf_mutex;
-StgWord32 event_buf[EVENT_BUFSIZ];
-nat next_event;
-
-#endif
-
-HANDLE
-getIOManagerEvent (void)
-{
- // This function has to exist even in the non-THREADED_RTS,
- // because code in GHC.Conc refers to it. It won't ever be called
- // unless we're in the threaded RTS, however.
-#ifdef THREADED_RTS
- HANDLE hRes;
-
- ACQUIRE_LOCK(&event_buf_mutex);
-
- if (io_manager_event == INVALID_HANDLE_VALUE) {
- hRes = CreateEvent ( NULL, // no security attrs
- TRUE, // manual reset
- FALSE, // initial state,
- NULL ); // event name: NULL for private events
- if (hRes == NULL) {
- sysErrorBelch("getIOManagerEvent");
- stg_exit(EXIT_FAILURE);
- }
- io_manager_event = hRes;
- } else {
- hRes = io_manager_event;
- }
-
- RELEASE_LOCK(&event_buf_mutex);
- return hRes;
-#else
- return NULL;
-#endif
-}
-
-
-HsWord32
-readIOManagerEvent (void)
-{
- // This function must exist even in non-THREADED_RTS,
- // see getIOManagerEvent() above.
-#if defined(THREADED_RTS)
- HsWord32 res;
-
- ACQUIRE_LOCK(&event_buf_mutex);
-
- if (io_manager_event != INVALID_HANDLE_VALUE) {
- if (next_event == 0) {
- res = 0; // no event to return
- } else {
- res = (HsWord32)(event_buf[--next_event]);
- if (next_event == 0) {
- if (!ResetEvent(io_manager_event)) {
- sysErrorBelch("readIOManagerEvent");
- stg_exit(EXIT_FAILURE);
- }
- }
- }
- } else {
- res = 0;
- }
-
- RELEASE_LOCK(&event_buf_mutex);
-
- // debugBelch("readIOManagerEvent: %d\n", res);
- return res;
-#else
- return 0;
-#endif
-}
-
-void
-sendIOManagerEvent (HsWord32 event)
-{
-#if defined(THREADED_RTS)
- ACQUIRE_LOCK(&event_buf_mutex);
-
- // debugBelch("sendIOManagerEvent: %d\n", event);
- if (io_manager_event != INVALID_HANDLE_VALUE) {
- if (next_event == EVENT_BUFSIZ) {
- errorBelch("event buffer overflowed; event dropped");
- } else {
- if (!SetEvent(io_manager_event)) {
- sysErrorBelch("sendIOManagerEvent");
- stg_exit(EXIT_FAILURE);
- }
- event_buf[next_event++] = (StgWord32)event;
- }
- }
-
- RELEASE_LOCK(&event_buf_mutex);
-#endif
-}
-
-void
-ioManagerWakeup (void)
-{
- sendIOManagerEvent(IO_MANAGER_WAKEUP);
-}
-
-#if defined(THREADED_RTS)
-void
-ioManagerDie (void)
-{
- sendIOManagerEvent(IO_MANAGER_DIE);
- // IO_MANAGER_DIE must be idempotent, as it is called
- // repeatedly by shutdownCapability(). Try conc059(threaded1) to
- // illustrate the problem.
- ACQUIRE_LOCK(&event_buf_mutex);
- io_manager_event = INVALID_HANDLE_VALUE;
- RELEASE_LOCK(&event_buf_mutex);
- // ToDo: wait for the IO manager to pick up the event, and
- // then release the Event and Mutex objects we've allocated.
-}
-
-void
-ioManagerStart (void)
-{
- initMutex(&event_buf_mutex);
- next_event = 0;
-
- // Make sure the IO manager thread is running
- Capability *cap;
- if (io_manager_event == INVALID_HANDLE_VALUE) {
- cap = rts_lock();
-#if defined(COMPILING_WINDOWS_DLL)
-# if defined(x86_64_HOST_ARCH)
- rts_evalIO(&cap,__imp_base_GHCziConcziIO_ensureIOManagerIsRunning_closure,NULL);
-# else
- rts_evalIO(&cap,_imp__base_GHCziConcziIO_ensureIOManagerIsRunning_closure,NULL);
-# endif
-#else
- rts_evalIO(&cap,&base_GHCziConcziIO_ensureIOManagerIsRunning_closure,NULL);
-#endif
- rts_unlock(cap);
- }
-}
-#endif
+/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team, 1998-2006 + * + * The IO manager thread in THREADED_RTS. + * See also libraries/base/GHC/Conc.lhs. + * + * ---------------------------------------------------------------------------*/ + +#include "Rts.h" +#include "IOManager.h" +#include "Prelude.h" +#include <windows.h> + +// Here's the Event that we use to wake up the IO manager thread +static HANDLE io_manager_event = INVALID_HANDLE_VALUE; + +// must agree with values in GHC.Conc: +#define IO_MANAGER_WAKEUP 0xffffffff +#define IO_MANAGER_DIE 0xfffffffe +// spurios wakeups are returned as zero. +// console events are ((event<<1) | 1) + +#if defined(THREADED_RTS) + +#define EVENT_BUFSIZ 256 +Mutex event_buf_mutex; +StgWord32 event_buf[EVENT_BUFSIZ]; +nat next_event; + +#endif + +HANDLE +getIOManagerEvent (void) +{ + // This function has to exist even in the non-THREADED_RTS, + // because code in GHC.Conc refers to it. It won't ever be called + // unless we're in the threaded RTS, however. +#ifdef THREADED_RTS + HANDLE hRes; + + ACQUIRE_LOCK(&event_buf_mutex); + + if (io_manager_event == INVALID_HANDLE_VALUE) { + hRes = CreateEvent ( NULL, // no security attrs + TRUE, // manual reset + FALSE, // initial state, + NULL ); // event name: NULL for private events + if (hRes == NULL) { + sysErrorBelch("getIOManagerEvent"); + stg_exit(EXIT_FAILURE); + } + io_manager_event = hRes; + } else { + hRes = io_manager_event; + } + + RELEASE_LOCK(&event_buf_mutex); + return hRes; +#else + return NULL; +#endif +} + + +HsWord32 +readIOManagerEvent (void) +{ + // This function must exist even in non-THREADED_RTS, + // see getIOManagerEvent() above. +#if defined(THREADED_RTS) + HsWord32 res; + + ACQUIRE_LOCK(&event_buf_mutex); + + if (io_manager_event != INVALID_HANDLE_VALUE) { + if (next_event == 0) { + res = 0; // no event to return + } else { + res = (HsWord32)(event_buf[--next_event]); + if (next_event == 0) { + if (!ResetEvent(io_manager_event)) { + sysErrorBelch("readIOManagerEvent"); + stg_exit(EXIT_FAILURE); + } + } + } + } else { + res = 0; + } + + RELEASE_LOCK(&event_buf_mutex); + + // debugBelch("readIOManagerEvent: %d\n", res); + return res; +#else + return 0; +#endif +} + +void +sendIOManagerEvent (HsWord32 event) +{ +#if defined(THREADED_RTS) + ACQUIRE_LOCK(&event_buf_mutex); + + // debugBelch("sendIOManagerEvent: %d\n", event); + if (io_manager_event != INVALID_HANDLE_VALUE) { + if (next_event == EVENT_BUFSIZ) { + errorBelch("event buffer overflowed; event dropped"); + } else { + if (!SetEvent(io_manager_event)) { + sysErrorBelch("sendIOManagerEvent"); + stg_exit(EXIT_FAILURE); + } + event_buf[next_event++] = (StgWord32)event; + } + } + + RELEASE_LOCK(&event_buf_mutex); +#endif +} + +void +ioManagerWakeup (void) +{ + sendIOManagerEvent(IO_MANAGER_WAKEUP); +} + +#if defined(THREADED_RTS) +void +ioManagerDie (void) +{ + sendIOManagerEvent(IO_MANAGER_DIE); + // IO_MANAGER_DIE must be idempotent, as it is called + // repeatedly by shutdownCapability(). Try conc059(threaded1) to + // illustrate the problem. + ACQUIRE_LOCK(&event_buf_mutex); + io_manager_event = INVALID_HANDLE_VALUE; + RELEASE_LOCK(&event_buf_mutex); + // ToDo: wait for the IO manager to pick up the event, and + // then release the Event and Mutex objects we've allocated. +} + +void +ioManagerStart (void) +{ + initMutex(&event_buf_mutex); + next_event = 0; + + // Make sure the IO manager thread is running + Capability *cap; + if (io_manager_event == INVALID_HANDLE_VALUE) { + cap = rts_lock(); + rts_evalIO(&cap,ensureIOManagerIsRunning_closure,NULL); + rts_unlock(cap); + } +} +#endif diff --git a/rts/win32/libHSbase.def b/rts/win32/libHSbase.def index 5dd1ce7180..119237b652 100644 --- a/rts/win32/libHSbase.def +++ b/rts/win32/libHSbase.def @@ -27,6 +27,7 @@ EXPORTS base_GHCziPtr_FunPtr_con_info base_GHCziConcziIO_ensureIOManagerIsRunning_closure + base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure base_GHCziConcziSync_runSparks_closure base_GHCziTopHandler_flushStdHandles_closure diff --git a/rules/build-dependencies.mk b/rules/build-dependencies.mk index 4a4f5638e2..7b66dcd266 100644 --- a/rules/build-dependencies.mk +++ b/rules/build-dependencies.mk @@ -48,7 +48,18 @@ endif # Some packages are from the bootstrapping compiler, so are not # within the build tree. On Windows this causes a problem as they look # like bad rules, due to the two colons, so we filter them out. - grep -v ' : [a-zA-Z]:/' $$@.tmp > $$@ + grep -v ' : [a-zA-Z]:/' $$@.tmp > $$@.tmp2 + sed '/hs$$$$/ p ; \ + /hs$$$$/ s/o /hi /g ; \ + /hs$$$$/ s/:/ : %hi: %o / ; \ + /hs$$$$/ s/^/$$$$(eval $$$$(call hi-rule,/ ; \ + /hs$$$$/ s/$$$$/))/ ; \ + /hs-boot$$$$/ p ; \ + /hs-boot$$$$/ s/o-boot /hi-boot /g ; \ + /hs-boot$$$$/ s/:/ : %hi-boot: %o-boot / ; \ + /hs-boot$$$$/ s/^/$$$$(eval $$$$(call hi-rule,/ ; \ + /hs-boot$$$$/ s/$$$$/))/' \ + $$@.tmp2 > $$@ # Some of the C files (directly or indirectly) include the generated # includes files. diff --git a/rules/build-package-data.mk b/rules/build-package-data.mk index 17def03638..41f7a02be1 100644 --- a/rules/build-package-data.mk +++ b/rules/build-package-data.mk @@ -71,9 +71,7 @@ $1_$2_CONFIGURE_OPTS += --configure-option=--with-gmp-libraries="$$(GMP_LIB_DIRS endif ifeq "$$(CrossCompiling)" "YES" -$1_$2_CONFIGURE_OPTS += --configure-option=--host=$(TARGETPLATFORM) -# We use different platform name conventions than autoconf expects, -# but let's hope it doesn't cause problems. +$1_$2_CONFIGURE_OPTS += --configure-option=--host=$(TargetPlatformFull) endif ifeq "$3" "0" @@ -102,7 +100,15 @@ $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) - 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 +# Checking packages built with the bootstrapping compiler would +# generally be a waste of time. Either we will rebuild them with +# stage1/stage2, or we don't really care about them. +ifneq "$3" "0" +ifneq "$$($1_NO_CHECK)" "YES" + "$$(GHC_CABAL_INPLACE)" check $1 +endif +endif + "$$(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" $$(call cmd,$1_$2_GHC_PKG) update --force $$($1_$2_GHC_PKG_OPTS) $1/$2/inplace-pkg-config diff --git a/rules/build-package-way.mk b/rules/build-package-way.mk index aade4e93af..4621482d82 100644 --- a/rules/build-package-way.mk +++ b/rules/build-package-way.mk @@ -16,7 +16,7 @@ $(call trace, build-package-way($1,$2,$3)) $(call profStart, build-package-way($1,$2,$3)) $(call distdir-way-opts,$1,$2,$3,$4) -$(call hs-suffix-rules,$1,$2,$3) +$(call hs-suffix-way-rules,$1,$2,$3) $(call hs-objs,$1,$2,$3) @@ -43,10 +43,6 @@ endif # [inconsistent distdirs]. $1_$2_$3_DEPS_LIBS=$$(foreach dep,$$($1_$2_DEPS),$$($$(dep)_$(subst stage2,dist-install,$2)_$3_LIB)) -ifeq "$$(BootingFromHc)" "YES" -$1_$2_$3_C_OBJS += $$(shell $$(FIND) $1/$2/build -name "*_stub.c" -print | sed 's/c$$$$/o/') -endif - $1_$2_$3_NON_HS_OBJS = $$($1_$2_$3_CMM_OBJS) $$($1_$2_$3_C_OBJS) $$($1_$2_$3_S_OBJS) $$($1_$2_EXTRA_OBJS) $1_$2_$3_ALL_OBJS = $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_NON_HS_OBJS) diff --git a/rules/build-package.mk b/rules/build-package.mk index e64754cb3f..47ef22c89d 100644 --- a/rules/build-package.mk +++ b/rules/build-package.mk @@ -75,6 +75,15 @@ else $1_$2_WAYS = $$(filter-out $$($1_$2_EXCLUDED_WAYS),$$(GhcLibWays)) endif +$1_$2_DYNAMIC_TOO = NO +ifneq "$$(DYNAMIC_TOO)" "NO" +ifneq "$$(filter v,$$($1_$2_WAYS))" "" +ifneq "$$(filter dyn,$$($1_$2_WAYS))" "" +$1_$2_DYNAMIC_TOO = YES +endif +endif +endif + # We must use a different dependency file if $(GhcLibWays) changes, so # encode the ways into the name of the file. $1_$2_WAYS_DASHED = $$(subst $$(space),,$$(patsubst %,-%,$$(strip $$($1_$2_WAYS)))) @@ -105,6 +114,7 @@ endif $(call hs-sources,$1,$2) $(call c-sources,$1,$2) $(call includes-sources,$1,$2) +$(call distdir-opts,$1,$2,$3) $(call dependencies,$1,$2,$3) @@ -123,12 +133,15 @@ $$(foreach way,$$($1_$2_WAYS),$$(eval \ # If dyn libs are not being built then $$($1_$2_dyn_LIB) will just # expand to the empty string, and be ignored. $1_$2_PROGRAM_DEP_LIB = $$($1_$2_v_LIB) $$($1_$2_dyn_LIB) +$$($1_PACKAGE)-$$($1_$2_VERSION)_$2_PROGRAM_DEP_LIB = $$($1_$2_PROGRAM_DEP_LIB) # C and S files are possibly built the "dyn" way. ifeq "$$(BuildSharedLibs)" "YES" $(call c-objs,$1,$2,dyn) $(call c-suffix-rules,$1,$2,dyn,YES) endif +$$(foreach dir,$$($1_$2_HS_SRC_DIRS),\ + $$(eval $$(call hs-suffix-rules-srcdir,$1,$2,$$(dir)))) $(call all-target,$1,all_$1_$2) # This give us things like @@ -137,14 +150,6 @@ ifneq "$$($1_$2_GROUP)" "" all_$$($1_$2_GROUP): all_$1_$2 endif -ifneq "$$(CHECKED_$1)" "YES" -CHECKED_$1 = YES -check_packages: check_$1 -.PHONY: check_$1 -check_$1: $$(GHC_CABAL_INPLACE) - CROSS_COMPILE="$(CrossCompilePrefix)" $$(GHC_CABAL_INPLACE) check $1 -endif - ifneq "$3" "0" $(call haddock,$1,$2) endif diff --git a/rules/build-prog.mk b/rules/build-prog.mk index 0419c3b4ab..3cea0e4839 100644 --- a/rules/build-prog.mk +++ b/rules/build-prog.mk @@ -135,11 +135,14 @@ endif $1_$2_WAYS = $$($1_$2_PROGRAM_WAY) +$1_$2_DYNAMIC_TOO = NO + $(call hs-sources,$1,$2) $(call c-sources,$1,$2) # --- IMPLICIT RULES +$(call distdir-opts,$1,$2,,$3) $(call distdir-way-opts,$1,$2,$$($1_$2_PROGRAM_WAY),$3) ifeq "$3" "0" @@ -154,15 +157,14 @@ $(call c-suffix-rules,$1,$2,$$($1_$2_PROGRAM_WAY),NO) endif endif -$(call hs-suffix-rules,$1,$2,$$($1_$2_PROGRAM_WAY)) +$$(foreach dir,$$($1_$2_HS_SRC_DIRS),\ + $$(eval $$(call hs-suffix-rules-srcdir,$1,$2,$$(dir)))) +$(call hs-suffix-way-rules,$1,$2,$$($1_$2_PROGRAM_WAY)) $(call c-objs,$1,$2,$$($1_$2_PROGRAM_WAY)) $(call hs-objs,$1,$2,$$($1_$2_PROGRAM_WAY)) $1_$2_LINK_WITH_GCC = NO -ifeq "$$(BootingFromHc)" "YES" -$1_$2_LINK_WITH_GCC = YES -endif ifeq "$$($1_$2_$$($1_$2_PROGRAM_WAY)_HS_OBJS)" "" # We don't want to link the GHC RTS into C-only programs. There's no @@ -186,13 +188,13 @@ ifneq "$$(BINDIST)" "YES" # The quadrupled $'s here are because the _<way>_LIB variables aren't # necessarily set when this part of the makefile is read $1/$2/build/tmp/$$($1_$2_PROG) : \ - $$(foreach dep,$$($1_$2_DEP_NAMES),\ - $$(if $$(filter ghc,$$(dep)),\ + $$(foreach dep,$$($1_$2_DEPS),\ + $$(if $$(filter ghc%,$$(dep)),\ $(if $(filter 0,$3),$$(compiler_stage1_PROGRAM_DEP_LIB),\ $(if $(filter 1,$3),$$(compiler_stage2_PROGRAM_DEP_LIB),\ $(if $(filter 2,$3),$$(compiler_stage2_PROGRAM_DEP_LIB),\ $$(error Bad build stage)))),\ - $$$$(libraries/$$(dep)_dist-$(if $(filter 0,$3),boot,install)_PROGRAM_DEP_LIB))) + $$$$($$(dep)_dist-$(if $(filter 0,$3),boot,install)_PROGRAM_DEP_LIB))) ifeq "$$($1_$2_LINK_WITH_GCC)" "NO" $1/$2/build/tmp/$$($1_$2_PROG) : $$($1_$2_$$($1_$2_PROGRAM_WAY)_HS_OBJS) $$($1_$2_$$($1_$2_PROGRAM_WAY)_C_OBJS) $$($1_$2_$$($1_$2_PROGRAM_WAY)_S_OBJS) $$($1_$2_OTHER_OBJS) | $$$$(dir $$$$@)/. diff --git a/rules/c-suffix-rules.mk b/rules/c-suffix-rules.mk index 6d4bfe1755..628546c077 100644 --- a/rules/c-suffix-rules.mk +++ b/rules/c-suffix-rules.mk @@ -19,8 +19,7 @@ define c-suffix-rules ifneq "$$(BINDIST)" "YES" -# UseGhcForCc is only relevant when not booting from HC files. -ifeq "$4 $$(BootingFromHc)" "YES NO" +ifeq "$4" "YES" $1/$2/build/%.$$($3_osuf) : $1/%.c $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. $$(call cmd,$1_$2_HC) $$($1_$2_$3_GHC_CC_OPTS) -c $$< -o $$@ diff --git a/rules/cmm-suffix-rules.mk b/rules/cmm-suffix-rules.mk index 0c8b0716e6..6546f86004 100644 --- a/rules/cmm-suffix-rules.mk +++ b/rules/cmm-suffix-rules.mk @@ -20,8 +20,6 @@ define cmm-suffix-rules ifneq "$$(CLEANING)" "YES" -ifneq "$$(BootingFromHc)" "YES" - $1/$2/build/%.$$($3_way_)o : $1/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$(includes_DERIVEDCONSTANTS) $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. $$(call cmd,$1_$2_HC) $$($1_$2_$3_MOST_HC_OPTS) -c $$< -o $$@ @@ -50,7 +48,5 @@ $1/$2/build/%.$$($3_way_)hc : $1/$2/build/%.cmm $$(rts_H_FILES) $$(includes_H_FI endif -endif - endef diff --git a/rules/distdir-opts.mk b/rules/distdir-opts.mk new file mode 100644 index 0000000000..748e27e52d --- /dev/null +++ b/rules/distdir-opts.mk @@ -0,0 +1,111 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# http://hackage.haskell.org/trac/ghc/wiki/Building/Architecture +# http://hackage.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + + +# Set compilation flags that additionally depend on a particular way + +define distdir-opts # args: $1 = dir, $2 = distdir, $3 = stage + +ifeq "$3" "0" +# This is a bit of a hack. +# If we are compiling something with the bootstrapping compiler on +# cygwin, and it uses an include file from the rts (say), then we +# need to stop mkdependC from generating a dependincy on +# c:/ghc/rts/include/Rts.h +# as that confuses make. So we use -isystem instead of -I, which stops +# these dependencies from being generated. Technically this is wrong if +# we depend on a library that is built inside the build tree, and we +# use headers from that library, but currently I don't think that's the +# case. +$1_$2_DEP_INCLUDE_DIRS_FLAG = -isystem +else +$1_$2_DEP_INCLUDE_DIRS_FLAG = -I +endif + +ifneq ($$(strip $$($1_$2_DEP_INCLUDE_DIRS_SINGLE_QUOTED)),) +$1_$2_CC_INC_FLAGS := $$(subst $$(space)',$$(space)$$($1_$2_DEP_INCLUDE_DIRS_FLAG)',$$(space)$$($1_$2_DEP_INCLUDE_DIRS_SINGLE_QUOTED)) +endif + +# The CONF_CC_OPTS_STAGE$3 options are what we use to get gcc to +# behave correctly, but they are specific to the gcc that we are using. +# If GHC is compiling C code then it will take care of that for us, +# and in the case of the stage 0 compiler it may be using a different +# gcc, so we don't want to use our gcc-specific options. +$1_$2_DIST_GCC_CC_OPTS = \ + $$(CONF_CC_OPTS_STAGE$3) \ + $$($1_$2_DIST_CC_OPTS) + +$1_$2_DIST_CC_OPTS = \ + $$(SRC_CC_OPTS) \ + $$($1_CC_OPTS) \ + $$(foreach dir,$$(filter-out /%,$$($1_$2_INCLUDE_DIRS)),-I$1/$$(dir)) \ + $$(foreach dir,$$(filter /%,$$($1_$2_INCLUDE_DIRS)),-I$$(dir)) \ + $$($1_$2_CC_OPTS) \ + $$($1_$2_CPP_OPTS) \ + $$($1_$2_CC_INC_FLAGS) \ + $$($1_$2_DEP_CC_OPTS) \ + $$(SRC_CC_WARNING_OPTS) + +ifneq ($$(strip $$($1_$2_DEP_LIB_DIRS_SINGLE_QUOTED)),) +$1_$2_DIST_LD_LIB_DIRS := $$(subst $$(space)',$$(space)-L',$$(space)$$($1_$2_DEP_LIB_DIRS_SINGLE_QUOTED)) +endif + +$1_$2_DIST_LD_OPTS = \ + $$(CONF_GCC_LINKER_OPTS_STAGE$3) \ + $$(SRC_LD_OPTS) \ + $$($1_LD_OPTS) \ + $$($1_$2_LD_OPTS) \ + $$($1_$2_DIST_LD_LIB_DIRS) \ + $$(foreach opt,$$($1_$2_DEP_EXTRA_LIBS),-l$$(opt)) \ + $$($1_$2_DEP_LD_OPTS) + +# c.f. Cabal's Distribution.Simple.PreProcess.ppHsc2hs +# We use '' around cflags and lflags to handle paths with backslashes in +# on Windows +ifneq ($$(strip $$($1_$2_DIST_GCC_CC_OPTS)),) +$1_$2_HSC2HS_CC_OPTS:=$$(shell for i in $$($1_$2_DIST_GCC_CC_OPTS); do echo \'--cflag=$$$$i\'; done) +endif +ifneq ($$(strip $$($1_$2_DIST_LD_OPTS)),) +$1_$2_HSC2HS_LD_OPTS:=$$(shell for i in $$($1_$2_DIST_LD_OPTS); do echo \'--lflag=$$$$i\'; done) +endif + +$1_$2_ALL_HSC2HS_OPTS = \ + --cc=$$(WhatGccIsCalled) \ + --ld=$$(WhatGccIsCalled) \ + $$(CONF_HSC2HS_OPTS) \ + $$(SRC_HSC2HS_OPTS) \ + --cflag=-D__GLASGOW_HASKELL__=$$(if $$(filter 0,$3),$$(GhcCanonVersion),$$(ProjectVersionInt)) \ + --cflag=-D$$(HostArch_CPP)_HOST_ARCH=1 \ + --cflag=-D$$(HostOS_CPP)_HOST_OS=1 \ + $$($1_$2_HSC2HS_CC_OPTS) \ + $$($1_$2_HSC2HS_LD_OPTS) \ + --cflag=-I$1/$2/build/autogen \ + $$(if $$($1_PACKAGE),--cflag=-include --cflag=$1/$2/build/autogen/cabal_macros.h) \ + $$($$(basename $$<)_HSC2HS_OPTS) \ + $$(EXTRA_HSC2HS_OPTS) + +$1_$2_ALL_ALEX_OPTS = \ + $$(CONF_ALEX_OPTS) \ + $$(SRC_ALEX_OPTS) + $$($1_ALEX_OPTS) \ + $$($1_$2_ALEX_OPTS) \ + $$(EXTRA_ALEX_OPTS) + +$1_$2_ALL_HAPPY_OPTS = \ + $$(CONF_HAPPY_OPTS) \ + $$(SRC_HAPPY_OPTS) \ + $$($1_HAPPY_OPTS) \ + $$($1_$2_HAPPY_OPTS) \ + $$(EXTRA_HAPPY_OPTS) + +endef + diff --git a/rules/distdir-way-opts.mk b/rules/distdir-way-opts.mk index 4d27bbfdc8..b04241d2bf 100644 --- a/rules/distdir-way-opts.mk +++ b/rules/distdir-way-opts.mk @@ -100,6 +100,7 @@ $1_$2_$3_MOST_HC_OPTS = \ $$(if $$($1_PACKAGE),-optP-include -optP$1/$2/build/autogen/cabal_macros.h) \ $$(foreach pkg,$$($1_$2_DEPS),-package $$(pkg)) \ $$(if $$(findstring YES,$$($1_$2_SplitObjs)),$$(if $$(findstring dyn,$3),,-split-objs),) \ + $$(if $$(findstring YES,$$($1_$2_DYNAMIC_TOO)),$$(if $$(findstring v,$3),-dynamic-too)) \ $$($1_$2_HC_OPTS) \ $$(CONF_HC_OPTS_STAGE$4) \ $$($1_$2_MORE_HC_OPTS) \ @@ -119,59 +120,6 @@ $1_$2_$3_ALL_HC_OPTS = \ -odir $1/$2/build -hidir $1/$2/build -stubdir $1/$2/build \ -hisuf $$($3_hisuf) -osuf $$($3_osuf) -hcsuf $$($3_hcsuf) -ifeq "$4" "0" -# This is a bit of a hack. -# If we are compiling something with the bootstrapping compiler on -# cygwin, and it uses an include file from the rts (say), then we -# need to stop mkdependC from generating a dependincy on -# c:/ghc/rts/include/Rts.h -# as that confuses make. So we use -isystem instead of -I, which stops -# these dependencies from being generated. Technically this is wrong if -# we depend on a library that is built inside the build tree, and we -# use headers from that library, but currently I don't think that's the -# case. -$1_$2_DEP_INCLUDE_DIRS_FLAG = -isystem -else -$1_$2_DEP_INCLUDE_DIRS_FLAG = -I -endif - -ifneq ($$(strip $$($1_$2_DEP_INCLUDE_DIRS_SINGLE_QUOTED)),) -$1_$2_CC_INC_FLAGS := $$(subst $$(space)',$$(space)$$($1_$2_DEP_INCLUDE_DIRS_FLAG)',$$(space)$$($1_$2_DEP_INCLUDE_DIRS_SINGLE_QUOTED)) -endif - -# The CONF_CC_OPTS_STAGE$4 options are what we use to get gcc to -# behave correctly, but they are specific to the gcc that we are using. -# If GHC is compiling C code then it will take care of that for us, -# and in the case of the stage 0 compiler it may be using a different -# gcc, so we don't want to use our gcc-specific options. -$1_$2_DIST_GCC_CC_OPTS = \ - $$(CONF_CC_OPTS_STAGE$4) \ - $$($1_$2_DIST_CC_OPTS) - -$1_$2_DIST_CC_OPTS = \ - $$(SRC_CC_OPTS) \ - $$($1_CC_OPTS) \ - $$(foreach dir,$$(filter-out /%,$$($1_$2_INCLUDE_DIRS)),-I$1/$$(dir)) \ - $$(foreach dir,$$(filter /%,$$($1_$2_INCLUDE_DIRS)),-I$$(dir)) \ - $$($1_$2_CC_OPTS) \ - $$($1_$2_CPP_OPTS) \ - $$($1_$2_CC_INC_FLAGS) \ - $$($1_$2_DEP_CC_OPTS) \ - $$(SRC_CC_WARNING_OPTS) - -ifneq ($$(strip $$($1_$2_DEP_LIB_DIRS_SINGLE_QUOTED)),) -$1_$2_DIST_LD_LIB_DIRS := $$(subst $$(space)',$$(space)-L',$$(space)$$($1_$2_DEP_LIB_DIRS_SINGLE_QUOTED)) -endif - -$1_$2_DIST_LD_OPTS = \ - $$(CONF_GCC_LINKER_OPTS_STAGE$4) \ - $$(SRC_LD_OPTS) \ - $$($1_LD_OPTS) \ - $$($1_$2_LD_OPTS) \ - $$($1_$2_DIST_LD_LIB_DIRS) \ - $$(foreach opt,$$($1_$2_DEP_EXTRA_LIBS),-l$$(opt)) \ - $$($1_$2_DEP_LD_OPTS) - ifeq "$3" "dyn" ifneq "$4" "0" ifeq "$$(TargetOS_CPP)" "linux" @@ -184,32 +132,6 @@ endif endif endif -# c.f. Cabal's Distribution.Simple.PreProcess.ppHsc2hs -# We use '' around cflags and lflags to handle paths with backslashes in -# on Windows -ifneq ($$(strip $$($1_$2_DIST_GCC_CC_OPTS)),) -$1_$2_$3_HSC2HS_CC_OPTS:=$$(shell for i in $$($1_$2_DIST_GCC_CC_OPTS); do echo \'--cflag=$$$$i\'; done) -endif -ifneq ($$(strip $$($1_$2_DIST_LD_OPTS)),) -$1_$2_$3_HSC2HS_LD_OPTS:=$$(shell for i in $$($1_$2_DIST_LD_OPTS); do echo \'--lflag=$$$$i\'; done) -endif - -$1_$2_$3_ALL_HSC2HS_OPTS = \ - --cc=$$(WhatGccIsCalled) \ - --ld=$$(WhatGccIsCalled) \ - $$(CONF_HSC2HS_OPTS) \ - $$(SRC_HSC2HS_OPTS) \ - $$(WAY_$3_HSC2HS_OPTS) \ - --cflag=-D__GLASGOW_HASKELL__=$$(if $$(filter 0,$4),$$(GhcCanonVersion),$$(ProjectVersionInt)) \ - --cflag=-D$$(HostArch_CPP)_HOST_ARCH=1 \ - --cflag=-D$$(HostOS_CPP)_HOST_OS=1 \ - $$($1_$2_$3_HSC2HS_CC_OPTS) \ - $$($1_$2_$3_HSC2HS_LD_OPTS) \ - --cflag=-I$1/$2/build/autogen \ - $$(if $$($1_PACKAGE),--cflag=-include --cflag=$1/$2/build/autogen/cabal_macros.h) \ - $$($$(basename $$<)_HSC2HS_OPTS) \ - $$(EXTRA_HSC2HS_OPTS) - $1_$2_$3_ALL_CC_OPTS = \ $$(WAY_$3_CC_OPTS) \ $$($1_$2_DIST_GCC_CC_OPTS) \ @@ -235,23 +157,5 @@ $1_$2_$3_ALL_AS_OPTS = \ $$($1_$2_$3_AS_OPTS) \ $$(EXTRA_AS_OPTS) -$1_$2_$3_ALL_ALEX_OPTS = \ - $$(CONF_ALEX_OPTS) \ - $$(SRC_ALEX_OPTS) - $$(WAY_$3_ALEX_OPTS) \ - $$($1_ALEX_OPTS) \ - $$($1_$2_ALEX_OPTS) \ - $$($1_$2_$3_ALEX_OPTS) \ - $$(EXTRA_ALEX_OPTS) - -$1_$2_$3_ALL_HAPPY_OPTS = \ - $$(CONF_HAPPY_OPTS) \ - $$(SRC_HAPPY_OPTS) \ - $$(WAY_$3_HAPPY_OPTS) \ - $$($1_HAPPY_OPTS) \ - $$($1_$2_HAPPY_OPTS) \ - $$($1_$2_$3_HAPPY_OPTS) \ - $$(EXTRA_HAPPY_OPTS) - endef diff --git a/rules/haddock.mk b/rules/haddock.mk index 4dabe3c71f..3a3fed4503 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" - CROSS_COMPILE="$(CrossCompilePrefix)" "$$(GHC_CABAL_INPLACE)" hscolour $2 $1 + "$$(GHC_CABAL_INPLACE)" hscolour $2 $1 endif "$$(TOP)/$$(INPLACE_BIN)/haddock" \ --odir="$1/$2/doc/html/$$($1_PACKAGE)" \ diff --git a/rules/hi-rule.mk b/rules/hi-rule.mk index e478c17aea..b87e600990 100644 --- a/rules/hi-rule.mk +++ b/rules/hi-rule.mk @@ -67,29 +67,37 @@ # However, given that rule, make thinks that it can make .hi files # for any object file, even if the object file was created from e.g. # a C source file. We therefore also add a dependency on the .hs/.lhs -# source file, which means we finally end up with rules like: +# source file, which means we end up with rules like: # # a/%.hi : a/%.o b/%.hs ; - -define hi-rule # $1 = source directory, $2 = object directory, $3 = way - -$(call hi-rule-helper,$2/%.$$($3_hisuf) : $2/%.$$($3_osuf) $1/%.hs) -$(call hi-rule-helper,$2/%.$$($3_hisuf) : $2/%.$$($3_osuf) $1/%.lhs) - -$(call hi-rule-helper,$2/%.$$($3_way_)hi-boot : $2/%.$$($3_way_)o-boot $1/%.hs) -$(call hi-rule-helper,$2/%.$$($3_way_)hi-boot : $2/%.$$($3_way_)o-boot $1/%.lhs) - -endef +# +# But! If a file is not explicitly mentioned in a makefile, then if +# make needs to build it using such a %-rule then it treats it as an +# 'intermediate file', and deletes it when it is finished. Most .hi +# files are mentioned in .depend* files, as some other module depends on +# them, but there are some library modules that aren't imported by +# anything in the tree. +# +# We could stop make from deleting the .hi files by declaring +# ".SECONDARY:", but if we do that then make takes a pathologically long +# time with our build system. So we now generate (by calling hi-rule +# from .depend* files) rules that look like +# +# a/B.hi a/B.dyn_hi : %hi : %o x/B.hs +# +# Now all the .hi files are explicitly mentioned in the makefiles, so +# make doesn't think they are merely intermediate files, and doesn't +# delete them. ifeq "$(ExtraMakefileSanityChecks)" "NO" -define hi-rule-helper # $1 = rule header +define hi-rule # $1 = rule header $1 ; endef else -define hi-rule-helper # $1 = rule header +define hi-rule # $1 = rule header $1 @if [ ! -f $$@ ] ; then \ echo "Panic! $$< exists, but $$@ does not."; \ diff --git a/rules/hs-suffix-rules-srcdir.mk b/rules/hs-suffix-rules-srcdir.mk index 776d1ce0f6..8ed72af3be 100644 --- a/rules/hs-suffix-rules-srcdir.mk +++ b/rules/hs-suffix-rules-srcdir.mk @@ -12,89 +12,38 @@ define hs-suffix-rules-srcdir -# args: $1 = dir, $2 = distdir, $3 = way, $4 = srcdir +# args: $1 = dir, $2 = distdir, $3 = srcdir # Preprocessing Haskell source ifneq "$$(BINDIST)" "YES" -ifneq "$$(BootingFromHc)" "YES" +$1/$2/build/%.hs : $1/$3/%.ly | $$$$(dir $$$$@)/. + $$(call cmd,HAPPY) $$($1_$2_ALL_HAPPY_OPTS) $$< -o $$@ -$1/$2/build/%.hs : $1/$4/%.ly | $$$$(dir $$$$@)/. - $$(call cmd,HAPPY) $$($1_$2_$3_ALL_HAPPY_OPTS) $$< -o $$@ - -$1/$2/build/%.hs : $1/$4/%.y | $$$$(dir $$$$@)/. - $$(call cmd,HAPPY) $$($1_$2_$3_ALL_HAPPY_OPTS) $$< -o $$@ +$1/$2/build/%.hs : $1/$3/%.y | $$$$(dir $$$$@)/. + $$(call cmd,HAPPY) $$($1_$2_ALL_HAPPY_OPTS) $$< -o $$@ $1/$2/build/%.hs : $1/$2/build/%.ly | $$$$(dir $$$$@)/. - $$(call cmd,HAPPY) $$($1_$2_$3_ALL_HAPPY_OPTS) $$< -o $$@ + $$(call cmd,HAPPY) $$($1_$2_ALL_HAPPY_OPTS) $$< -o $$@ $1/$2/build/%.hs : $1/$2/build/%.y | $$$$(dir $$$$@)/. - $$(call cmd,HAPPY) $$($1_$2_$3_ALL_HAPPY_OPTS) $$< -o $$@ - -$1/$2/build/%.hs : $1/$4/%.x | $$$$(dir $$$$@)/. - $$(call cmd,ALEX) $$($1_$2_$3_ALL_ALEX_OPTS) $$< -o $$@ - -$1/$2/build/%_hsc.c $1/$2/build/%_hsc.h $1/$2/build/%.hs : $1/$4/%.hsc $$(HSC2HS_INPLACE) | $$$$(dir $$$$@)/. - $$(call cmd,HSC2HS_INPLACE) $$($1_$2_$3_ALL_HSC2HS_OPTS) $$< -o $$@ - -# Compiling Haskell source - -$1/$2/build/%.$$($3_osuf) : $1/$4/%.hs $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP) - $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ - -$1/$2/build/%.$$($3_osuf) : $1/$4/%.lhs $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP) - $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ - -$1/$2/build/%.$$($3_hcsuf) : $1/$4/%.hs $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP) - $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -C $$< -o $$@ - -$1/$2/build/%.$$($3_hcsuf) : $1/$4/%.lhs $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP) - $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -C $$< -o $$@ - -$(call hi-rule,$1/$4,$1/$2/build,$3) - -endif - -# XXX: for some reason these get used in preference to the direct -# .hs->.o rule, I don't know why --SDM - -$1/$2/build/%.$$($3_osuf) : $1/$4/%.hc includes/ghcautoconf.h includes/ghcplatform.h | $$$$(dir $$$$@)/. - $$(call cmd,$1_$2_CC) $$($1_$2_$3_ALL_CC_OPTS) $$(addprefix -I,$$(GHC_INCLUDE_DIRS)) -x c -c $$< -o $$@ + $$(call cmd,HAPPY) $$($1_$2_ALL_HAPPY_OPTS) $$< -o $$@ -$1/$2/build/%.$$($3_osuf) : $1/$2/build/%.hc includes/ghcautoconf.h includes/ghcplatform.h - $$(call cmd,$1_$2_CC) $$($1_$2_$3_ALL_CC_OPTS) $$(addprefix -I,$$(GHC_INCLUDE_DIRS)) -x c -c $$< -o $$@ +$1/$2/build/%.hs : $1/$3/%.x | $$$$(dir $$$$@)/. + $$(call cmd,ALEX) $$($1_$2_ALL_ALEX_OPTS) $$< -o $$@ -# $1/$2/build/%.$$($3_osuf) : $1/$2/build/%.$$($3_way_)hc -# $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ -# -# $1/$2/build/%.$$($3_osuf) : $1/$2/build/%.hc -# $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ -# -# $1/$2/build/%.$$($3_way_)s : $1/$2/build/%.$$($3_way_)hc -# $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -S $$< -o $$@ +$1/$2/build/%_hsc.c $1/$2/build/%_hsc.h $1/$2/build/%.hs : $1/$3/%.hsc $$(HSC2HS_INPLACE) | $$$$(dir $$$$@)/. + $$(call cmd,HSC2HS_INPLACE) $$($1_$2_ALL_HSC2HS_OPTS) $$< -o $$@ # Now the rules for hs-boot files. -$1/$2/build/%.hs-boot : $1/$4/%.hs-boot +$1/$2/build/%.hs-boot : $1/$3/%.hs-boot "$$(CP)" $$< $$@ -$1/$2/build/%.lhs-boot : $1/$4/%.lhs-boot +$1/$2/build/%.lhs-boot : $1/$3/%.lhs-boot "$$(CP)" $$< $$@ -$1/$2/build/%.$$($3_way_)o-boot : $1/$4/%.hs-boot $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP) - $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ - -$1/$2/build/%.$$($3_way_)o-boot : $1/$4/%.lhs-boot $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP) - $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ - -ifneq "$$(BootingFromHc)" "YES" -# stubs are automatically generated and compiled by GHC - -$1/$2/build/%_stub.$$($3_osuf): $1/$2/build/%.$$($3_osuf) - @: -endif - endif endef diff --git a/rules/hs-suffix-way-rules-srcdir.mk b/rules/hs-suffix-way-rules-srcdir.mk new file mode 100644 index 0000000000..b8b8bfd694 --- /dev/null +++ b/rules/hs-suffix-way-rules-srcdir.mk @@ -0,0 +1,67 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# http://hackage.haskell.org/trac/ghc/wiki/Building/Architecture +# http://hackage.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + + +define hs-suffix-way-rules-srcdir +# args: $1 = dir, $2 = distdir, $3 = way, $4 = srcdir + +ifneq "$$(BINDIST)" "YES" + +# Compiling Haskell source + +$1/$2/build/%.$$($3_osuf) : $1/$4/%.hs $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP) + $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ $$(if $$(findstring YES,$$($1_$2_DYNAMIC_TOO)),-dyno $$(addsuffix .$$(dyn_osuf),$$(basename $$@))) + +$1/$2/build/%.$$($3_osuf) : $1/$4/%.lhs $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP) + $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ $$(if $$(findstring YES,$$($1_$2_DYNAMIC_TOO)),-dyno $$(addsuffix .$$(dyn_osuf),$$(basename $$@))) + +$1/$2/build/%.$$($3_hcsuf) : $1/$4/%.hs $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP) + $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -C $$< -o $$@ + +$1/$2/build/%.$$($3_hcsuf) : $1/$4/%.lhs $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP) + $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -C $$< -o $$@ + +# XXX: for some reason these get used in preference to the direct +# .hs->.o rule, I don't know why --SDM + +$1/$2/build/%.$$($3_osuf) : $1/$4/%.hc includes/ghcautoconf.h includes/ghcplatform.h | $$$$(dir $$$$@)/. + $$(call cmd,$1_$2_CC) $$($1_$2_$3_ALL_CC_OPTS) $$(addprefix -I,$$(GHC_INCLUDE_DIRS)) -x c -c $$< -o $$@ $$(if $$(findstring YES,$$($1_$2_DYNAMIC_TOO)),-dyno $$(addsuffix .$$(dyn_osuf),$$(basename $$@))) + +$1/$2/build/%.$$($3_osuf) : $1/$2/build/%.hc includes/ghcautoconf.h includes/ghcplatform.h + $$(call cmd,$1_$2_CC) $$($1_$2_$3_ALL_CC_OPTS) $$(addprefix -I,$$(GHC_INCLUDE_DIRS)) -x c -c $$< -o $$@ $$(if $$(findstring YES,$$($1_$2_DYNAMIC_TOO)),-dyno $$(addsuffix .$$(dyn_osuf),$$(basename $$@))) + +# $1/$2/build/%.$$($3_osuf) : $1/$2/build/%.$$($3_way_)hc +# $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ +# +# $1/$2/build/%.$$($3_osuf) : $1/$2/build/%.hc +# $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ +# +# $1/$2/build/%.$$($3_way_)s : $1/$2/build/%.$$($3_way_)hc +# $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -S $$< -o $$@ + +# Now the rules for hs-boot files. + +$1/$2/build/%.$$($3_way_)o-boot : $1/$4/%.hs-boot $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP) + $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ $$(if $$(findstring YES,$$($1_$2_DYNAMIC_TOO)),-dyno $$(addsuffix .$$(dyn_osuf)-boot,$$(basename $$@))) + +$1/$2/build/%.$$($3_way_)o-boot : $1/$4/%.lhs-boot $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP) + $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ $$(if $$(findstring YES,$$($1_$2_DYNAMIC_TOO)),-dyno $$(addsuffix .$$(dyn_osuf)-boot,$$(basename $$@))) + +# stubs are automatically generated and compiled by GHC + +$1/$2/build/%_stub.$$($3_osuf): $1/$2/build/%.$$($3_osuf) + @: + +endif + +endef + diff --git a/rules/hs-suffix-rules.mk b/rules/hs-suffix-way-rules.mk index fead7d1d41..e53821554a 100644 --- a/rules/hs-suffix-rules.mk +++ b/rules/hs-suffix-way-rules.mk @@ -11,31 +11,44 @@ # ----------------------------------------------------------------------------- -define hs-suffix-rules # args: $1 = dir, $2 = distdir, $3 = way +define hs-suffix-way-rules # args: $1 = dir, $2 = distdir, $3 = way + +ifeq "$3 $$($1_$2_DYNAMIC_TOO)" "dyn YES" +# We only want this rule to be used for Haskell sources, not for +# e.g. C sources, so we depend on the v_hisuf rather than v_osuf. +$1/$2/build/%.$$(dyn_osuf): $1/$2/build/%.$$(v_hisuf) + @if [ ! -f $$@ ] ; then \ + echo "Panic! $$< exists, but $$@ does not."; \ + exit 1; \ + fi + +$1/$2/build/%.$$(dyn_osuf)-boot: $1/$2/build/%.$$(v_hisuf)-boot + @if [ ! -f $$@ ] ; then \ + echo "Panic! $$< exists, but $$@ does not."; \ + exit 1; \ + fi +else ifneq "$$(BINDIST)" "YES" -ifneq "$$(BootingFromHc)" "YES" $1/$2/build/%.$$($3_hcsuf) : $1/$2/build/%.hs $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -C $$< -o $$@ $1/$2/build/%.$$($3_osuf) : $1/$2/build/%.hs $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) - $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ + $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ $$(if $$(findstring YES,$$($1_$2_DYNAMIC_TOO)),-dyno $$(addsuffix .$$(dyn_osuf),$$(basename $$@))) $1/$2/build/%.$$($3_hcsuf) : $1/$2/build/autogen/%.hs $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -C $$< -o $$@ $1/$2/build/%.$$($3_osuf) : $1/$2/build/autogen/%.hs $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) - $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ + $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ $$(if $$(findstring YES,$$($1_$2_DYNAMIC_TOO)),-dyno $$(addsuffix .$$(dyn_osuf),$$(basename $$@))) -$(call hi-rule,$1/$2/build,$1/$2/build,$3) -$(call hi-rule,$1/$2/build/autogen,$1/$2/build,$3) - -endif endif $$(foreach dir,$$($1_$2_HS_SRC_DIRS),\ - $$(eval $$(call hs-suffix-rules-srcdir,$1,$2,$3,$$(dir)))) + $$(eval $$(call hs-suffix-way-rules-srcdir,$1,$2,$3,$$(dir)))) + +endif -endef # hs-suffix-rules +endef # hs-suffix-way-rules diff --git a/rules/manual-package-config.mk b/rules/manual-package-config.mk index 848fe1b4ce..568d70887b 100644 --- a/rules/manual-package-config.mk +++ b/rules/manual-package-config.mk @@ -15,7 +15,7 @@ define manual-package-config # args: $1 = dir $(call trace, manual-package-config($1)) $(call profStart, manual-package-config($1)) -$1/package.conf.inplace : $1/package.conf.in $(GHC_PKG_INPLACE) +$1/package.conf.inplace : $1/package.conf.in $$(GHC_PKG_INPLACE) $$(CPP) $$(RAWCPP_FLAGS) -P \ -DTOP='"$$(TOP)"' \ $$($1_PACKAGE_CPP_OPTS) \ diff --git a/settings.in b/settings.in index e7354cd2cf..c749f2342f 100644 --- a/settings.in +++ b/settings.in @@ -1,6 +1,7 @@ [("GCC extra via C opts", "@GccExtraViaCOpts@"), ("C compiler command", "@SettingsCCompilerCommand@"), ("C compiler flags", "@SettingsCCompilerFlags@"), + ("C compiler link flags", "@SettingsCCompilerLinkFlags@"), ("ld command", "@SettingsLdCommand@"), ("ld flags", "@SettingsLdFlags@"), ("ld supports compact unwind", "@LdHasNoCompactUnwind@"), @@ -162,6 +162,29 @@ sub gitNewWorkdir { } } +sub configure_repository { + my $localpath = shift; + my $scm = shift; + + if ($scm eq "git") { + &scm($localpath, $scm, "config", "--local", "core.ignorecase", "true"); + + chdir($localpath); + open my $git_autocrlf, '-|', 'git', 'config', '--get', 'core.autocrlf' + or die "Executing git config failed: $!"; + my $autocrlf = <$git_autocrlf>; + $autocrlf = "" unless defined($autocrlf); + chomp $autocrlf; + close($git_autocrlf); + chdir($initial_working_directory); + if ($autocrlf eq "true") { + &scm($localpath, $scm, + "config", "--local", "core.autocrlf", "false"); + &scm($localpath, $scm, "reset", "--hard"); + } + } +} + sub scm { my $dir = shift; my $scm = shift; @@ -309,9 +332,7 @@ sub scmall { if (-d $localpath) { warning("$localpath already present; omitting") if $localpath ne "."; - if ($scm eq "git") { - scm ($localpath, $scm, "config", "core.ignorecase", "true"); - } + &configure_repository($localpath, $scm); next; } @@ -329,7 +350,7 @@ sub scmall { my @argsWithBare = @args; push @argsWithBare, $bare_flag if $bare_flag; scm (".", $scm, "clone", $path, $localpath, @argsWithBare); - scm ($localpath, $scm, "config", "core.ignorecase", "true"); + &configure_repository($localpath, $scm); } next; } @@ -371,8 +392,50 @@ sub scmall { $ignore_failure = 1; scm ($localpath, $scm, "commit", @args); } + elsif ($command eq "check_submodules") { + # If we have a submodule then check whether it is up-to-date + if ($remotepath eq "-") { + my %remote_heads; + + message "== Checking sub-module $localpath"; + + chdir($localpath); + + open my $lsremote, '-|', 'git', 'ls-remote', '--heads', '-q' + or die "Executing ls-remote failed: $!"; + while (<$lsremote>) { + if (/^([0-9a-f]{40})\s*refs\/heads\//) { + $remote_heads{$1} = 1; + } + else { + die "Bad output from ls-remote: $_"; + } + } + close($lsremote); + + open my $revparse, '-|', 'git', 'rev-parse', '--verify', 'HEAD' + or die "Executing rev-parse failed: $!"; + my $myhead; + $myhead = <$revparse>; + # or die "Failed to read from rev-parse: $!"; + chomp $myhead; + close($revparse); + + if (not defined($remote_heads{$myhead})) { + die "Sub module $localpath needs to be pushed; see http://hackage.haskell.org/trac/ghc/wiki/Repositories/Upstream"; + } + + chdir($initial_working_directory); + } + } elsif ($command eq "push") { - scm ($localpath, $scm, "push", @args); + # We don't automatically push to the submodules. If you want + # to push to them then you need to use a special command, as + # described on + # http://hackage.haskell.org/trac/ghc/wiki/Repositories/Upstream + if ($remotepath ne "-") { + scm ($localpath, $scm, "push", @args); + } } elsif ($command eq "pull") { my $realcmd; @@ -777,6 +840,10 @@ sub main { $command = "status"; } + if ($command eq "push") { + scmall ("check_submodules", @_); + } + scmall ($command, @_); my @submodule_args = grep(/^-q/,@_); diff --git a/utils/Makefile b/utils/Makefile deleted file mode 100644 index e522c32ba8..0000000000 --- a/utils/Makefile +++ /dev/null @@ -1,119 +0,0 @@ -TOP=.. -include $(TOP)/mk/boilerplate.mk - -ifeq "$(DOING_BIN_DIST)" "YES" -# We're doing a binary-dist, descend into a subset of the dirs. -SUBDIRS = mkdirhier hp2ps parallel unlit -else -ifeq "$(BootingFromHc)" "YES" -SUBDIRS = mkdependC mkdirhier runstdtest genapply genprimopcode unlit -else -SUBDIRS = mkdependC mkdirhier runstdtest hp2ps \ - parallel unlit genprimopcode genapply -endif -#ifneq "$(TARGETPLATFORM)" "i386-unknown-mingw32" -## lndir doesn't build on Windows -#SUBDIRS += lndir -#endif -endif - -ifeq "$(TARGETPLATFORM)" "i386-unknown-mingw32" -SUBDIRS += touchy -endif - -# XXX pwd and lndir building disabled for now - -# Utils that we don't build by default: -# nofib-analyse - -# Utils that are old and/or bitrotted: -# stat2resid -# debugNCG -# genargs -# heap-view -# pvm -# verbatim -# ltx -# hstags - -# "heap-view" is not in the list because (a) it requires -# a Haskell compiler (which you may not have yet), and (b) you are -# unlikely to want it desperately. It is easy to build once you have -# a Haskell compiler and if you want it. - -include $(TOP)/mk/target.mk - -# genprimopcode is needed to boot in ghc/compiler... -ifneq "$(BootingFromHc)" "YES" -boot :: - $(MAKE) -C genprimopcode -endif - -############################################ - -# The utils may be built with the bootstrapping compiler, for use during -# the build, or with the stage2 compiler, for installing. Some of them -# are built with both; we can't install the utils built with the -# bootstrapping compiler as they may use different versions of C -# libraries. The reason we use stage2 rather than stage1 is that some -# utils, e.g. haddock, need the GHC API package. - -WITH_BOOTSTRAPPING_COMPILER = installPackage ghc-pkg hsc2hs hpc - -WITH_STAGE2 = installPackage ghc-pkg runghc hpc pwd haddock -ifneq "$(NO_INSTALL_HSC2HS)" "YES" -WITH_STAGE2 += hsc2hs -endif - -# sort removes duplicates - we don't actually care about the order -WITH_EITHER = $(sort $(WITH_BOOTSTRAPPING_COMPILER) $(WITH_STAGE2)) - -# We need to build pwd with stage 2, as it goes in bindists, but we -# don't actually want to install it. Likewise the installPackage -# program. -DO_NOT_INSTALL = pwd installPackage - -binary-dist: $(foreach P,$(WITH_STAGE2),binary-dist.$P) -ifeq "$(WHERE_AM_I)" "" - echo "I don't know where I am" >&2 - exit 1 -endif - echo $(WHERE_AM_I)/Makefile >> $(BIN_DIST_LIST) - set -e; for d in $(SUBDIRS); do $(MAKE) -C $$d binary-dist WHERE_AM_I=$(WHERE_AM_I)/$$d; done - -clean:: $(foreach P,$(WITH_EITHER),clean.$P) - -distclean:: $(foreach P,$(WITH_EITHER),distclean.$P) - -with-bootstrapping-compiler: \ - $(foreach P,$(WITH_BOOTSTRAPPING_COMPILER),with-bootstrapping-compiler.$P) - -with-stage-2: $(foreach P,$(WITH_STAGE2),with-stage-2.$P) - $(MAKE) -C haddock install-inplace - -install:: $(foreach P,$(filter-out $(DO_NOT_INSTALL),$(WITH_STAGE2)),install.$P) - -$(foreach P,$(WITH_EITHER),clean.$P): \ -clean.%: - $(MAKE) -C $* clean - -$(foreach P,$(WITH_EITHER),distclean.$P): \ -distclean.%: - $(MAKE) -C $* distclean - -$(foreach P,$(WITH_BOOTSTRAPPING_COMPILER),with-bootstrapping-compiler.$P): \ -with-bootstrapping-compiler.%: - $(MAKE) -C $* with-bootstrapping-compiler - -$(foreach P,$(WITH_STAGE2),with-stage-2.$P): \ -with-stage-2.%: - $(MAKE) -C $* with-stage-2 - -$(foreach P,$(WITH_STAGE2),install.$P): \ -install.%: - $(MAKE) -C $* install - -$(foreach P,$(WITH_STAGE2),binary-dist.$P): \ -binary-dist.%: - $(MAKE) -C $* binary-dist WHERE_AM_I=$(WHERE_AM_I)/$* - diff --git a/utils/ghc-cabal/ghc.mk b/utils/ghc-cabal/ghc.mk index 2b105f424c..e95fa62f07 100644 --- a/utils/ghc-cabal/ghc.mk +++ b/utils/ghc-cabal/ghc.mk @@ -30,7 +30,7 @@ $(GHC_CABAL_DIR)/dist/build/tmp/ghc-cabal$(exeext): $(GHC_CABAL_DIR)/Main.hs $(T -no-user-$(GHC_PACKAGE_DB_FLAG) \ -Wall -fno-warn-unused-imports -fno-warn-warnings-deprecations \ -DCABAL_VERSION=$(CABAL_VERSION) \ - -DBOOTSTRAPPING \ + -DBOOTSTRAPPING \ -odir bootstrapping \ -hidir bootstrapping \ -ilibraries/Cabal/Cabal \ diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 6e9dba6dab..2e7bab6cc4 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -21,7 +21,7 @@ import Distribution.Text import Distribution.Version import System.FilePath as FilePath import qualified System.FilePath.Posix as FilePath.Posix -import System.Cmd ( rawSystem ) +import System.Process import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing, getModificationTime ) import Text.Printf @@ -61,7 +61,6 @@ import System.Posix hiding (fdToHandle) #endif #if defined(GLOB) -import System.Process(runInteractiveCommand) import qualified System.Info(os) #endif diff --git a/utils/ghc-pkg/ghc-pkg.cabal b/utils/ghc-pkg/ghc-pkg.cabal index e7f1d539ac..2f42e31f15 100644 --- a/utils/ghc-pkg/ghc-pkg.cabal +++ b/utils/ghc-pkg/ghc-pkg.cabal @@ -11,7 +11,7 @@ Description: XXX Category: Development build-type: Simple -cabal-version: >=1.2 +cabal-version: >=1.4 Executable ghc-pkg Main-Is: Main.hs diff --git a/utils/ghc-pkg/ghc.mk b/utils/ghc-pkg/ghc.mk index d904c48d11..a179ae7940 100644 --- a/utils/ghc-pkg/ghc.mk +++ b/utils/ghc-pkg/ghc.mk @@ -13,62 +13,6 @@ # ----------------------------------------------------------------------------- # Bootstrapping ghc-pkg -utils/ghc-pkg_dist_PROG = ghc-pkg$(exeext) - -ifeq "$(BootingFromHc)" "YES" - -inplace/bin/ghc-pkg : utils/ghc-pkg/dist-install/build/tmp/$(utils/ghc-pkg_dist_PROG)$(exeext) -ifeq "$(Windows)" "YES" - cp $< $@ -else - $(call removeFiles,$@) - echo "#!/bin/sh" >>$@ - echo "PKGCONF=$(TOP)/$(INPLACE_PACKAGE_CONF)" >>$@ - echo '$(TOP)/$< --global-package-db $$PKGCONF $${1+"$$@"}' >> $@ - chmod +x $@ -endif - -else - -$(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 $< $@ -else - $(call removeFiles,$@) - echo "#!/bin/sh" >>$@ - echo "PKGCONF=$(TOP)/$(INPLACE_PACKAGE_CONF)" >>$@ - echo '$(TOP)/$< --global-package-db $$PKGCONF $${1+"$$@"}' >> $@ - chmod +x $@ -endif - -endif - -# depend on ghc-cabal, otherwise we build Cabal twice when building in parallel. -# (ghc-cabal is an order-only dependency, we don't need to rebuild ghc-pkg -# if ghc-cabal is newer). -# The binary package is not warning-clean, so we need a few -fno-warns here. -# -# ToDo: we might want to do this using ghc-cabal instead. -# -utils/ghc-pkg/dist/build/tmp/$(utils/ghc-pkg_dist_PROG)$(exeext): utils/ghc-pkg/Main.hs utils/ghc-pkg/dist/build/Version.hs | bootstrapping/. $$(dir $$@)/. $(GHC_CABAL_INPLACE) - "$(GHC)" $(SRC_HC_OPTS) --make utils/ghc-pkg/Main.hs -o $@ \ - -no-user-$(GHC_PACKAGE_DB_FLAG) \ - -Wall -fno-warn-unused-imports -fno-warn-warnings-deprecations \ - $(SRC_HC_WARNING_OPTS) \ - -DCABAL_VERSION=$(CABAL_VERSION) \ - -DBOOTSTRAPPING \ - -odir bootstrapping \ - -hidir bootstrapping \ - -iutils/ghc-pkg \ - -iutils/ghc-pkg/dist/build \ - -ilibraries/Cabal/Cabal \ - -ilibraries/filepath \ - -ilibraries/hpc \ - -ilibraries/binary/src \ - -ilibraries/bin-package-db - - utils/ghc-pkg/dist/build/Version.hs \ utils/ghc-pkg/dist-install/build/Version.hs: mk/project.mk | $$(dir $$@)/. $(call removeFiles,$@) @@ -78,7 +22,7 @@ utils/ghc-pkg/dist-install/build/Version.hs: mk/project.mk | $$(dir $$@)/. echo "targetOS = \"$(TargetOS_CPP)\"" >> $@ echo "targetARCH = \"$(TargetArch_CPP)\"" >> $@ -$(eval $(call clean-target,utils/ghc-pkg,dist,utils/ghc-pkg/dist)) +utils/ghc-pkg_PACKAGE = ghc-pkg # ----------------------------------------------------------------------------- # Cross-compile case: install our dist version @@ -96,13 +40,24 @@ $(eval $(call shell-wrapper,utils/ghc-pkg,dist)) endif +utils/ghc-pkg_dist_USES_CABAL = YES +utils/ghc-pkg_dist_PROG = ghc-pkg$(exeext) +utils/ghc-pkg_dist_SHELL_WRAPPER = YES +utils/ghc-pkg_dist_INSTALL_INPLACE = YES + +$(eval $(call build-prog,utils/ghc-pkg,dist,0)) + +$(GHC_PKG_INPLACE) : | $(INPLACE_PACKAGE_CONF)/. + +utils/ghc-pkg/dist/package-data.mk: \ + utils/ghc-pkg/dist/build/Version.hs + # ----------------------------------------------------------------------------- # Normal case: Build ghc-pkg with stage 1 and install it ifneq "$(Stage1Only)" "YES" utils/ghc-pkg_dist-install_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 diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index 07fd5723fc..514f2998c0 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -292,7 +292,7 @@ boundThings modname lbinding = AsPat id p -> patThings p (thing id : tl) ParPat p -> patThings p tl BangPat p -> patThings p tl - ListPat ps _ -> foldr patThings tl ps + ListPat ps _ _ -> foldr patThings tl ps TuplePat ps _ _ -> foldr patThings tl ps PArrPat ps _ -> foldr patThings tl ps ConPatIn _ conargs -> conArgs conargs tl diff --git a/utils/lndir/Makefile b/utils/lndir/Makefile deleted file mode 100644 index 43e61c1a3a..0000000000 --- a/utils/lndir/Makefile +++ /dev/null @@ -1,17 +0,0 @@ -TOP=../.. -include $(TOP)/mk/boilerplate.mk - -# Exclude for booting -ifeq "$(stage)" "2" -SRC_CC_OPTS += $(MACOSX_DEPLOYMENT_CC_OPTS) -SRC_LD_OPTS += $(MACOSX_DEPLOYMENT_LD_OPTS) -endif - -C_SRCS=lndir.c -C_PROG=lndir - -CLEAN_FILES += $(C_PROG)$(exeext) $(C_OBJS) -DESTDIR=$(INSTBINDIR) - -include $(TOP)/mk/target.mk - diff --git a/utils/runghc/runghc.hs b/utils/runghc/runghc.hs index 7c306475b6..1673e7bdeb 100644 --- a/utils/runghc/runghc.hs +++ b/utils/runghc/runghc.hs @@ -20,12 +20,12 @@ module Main (main) where import Control.Exception import Data.Monoid -import System.Cmd import System.Directory import System.Environment import System.Exit import System.FilePath import System.IO +import System.Process #if defined(mingw32_HOST_OS) import Foreign |