From: Adam Megacz Date: Wed, 20 Apr 2011 17:29:56 +0000 (-0700) Subject: merge upstream HEAD X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=cf5905ea24904cf73a041fd7535e8723a668cb9a;hp=6cec61d14a324285dbb8ce73d4c7215f1f8d6766 merge upstream HEAD --- diff --git a/.gitignore b/.gitignore index bbcff22..32d243b 100644 --- a/.gitignore +++ b/.gitignore @@ -7,6 +7,7 @@ *.BAK *.orig *.prof +*.rej *.hi *.hi-boot @@ -30,6 +31,12 @@ config.status configure # ----------------------------------------------------------------------------- +# Ignore any overlapped darcs repos and back up files + +*-darcs-backup* +_darcs/ + +# ----------------------------------------------------------------------------- # sub-repositories /ghc-tarballs/ @@ -79,9 +86,7 @@ configure /bindist-list /bindistprep/ /bindisttest/HelloWorld -/bindisttest/a/ -/bindisttest/install\ dir/ -/bindisttest/output +/bindisttest/ /ch01.html /ch02.html /compiler/cmm/CmmLex.hs @@ -119,8 +124,12 @@ configure /docs/users_guide/users_guide.xml /docs/users_guide/users_guide/ /docs/users_guide/what_glasgow_exts_does.gen.xml +/driver/ghc/dist/ +/driver/haddock/dist/ /driver/ghci/ghc-pkg-inplace /driver/ghci/ghci-inplace +/driver/ghci/dist/ +/driver/ghci/ghci.res /driver/mangler/dist/ghc-asm /driver/mangler/dist/ghc-asm.prl /driver/package.conf @@ -150,6 +159,8 @@ configure /libffi/package.conf.inplace /libffi/package.conf.inplace.raw /libffi/stamp* +/libffi/package.conf.install +/libffi/package.conf.install.raw /libraries/bin-package-db/GNUmakefile /libraries/bin-package-db/ghc.mk /libraries/bootstrapping.conf @@ -185,6 +196,8 @@ configure /rts/package.conf.inplace.raw /rts/sm/Evac_thr.c /rts/sm/Scav_thr.c +/rts/package.conf.install +/rts/package.conf.install.raw /stage3.package.conf /testsuite_summary.txt /testlog @@ -218,3 +231,4 @@ configure /utils/runghc/runhaskell /utils/runstdtest/runstdtest /utils/unlit/unlit + diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index c40f3b7..a7dabc6 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -101,7 +101,7 @@ module CLabel ( hasCAF, infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl, needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel, - isMathFun, + isMathFun, isCas, isCFunctionLabel, isGcPtrLabel, labelDynamic, pprCLabel @@ -594,9 +594,17 @@ maybeAsmTemp (AsmTempLabel uq) = Just uq maybeAsmTemp _ = Nothing +-- | Check whether a label corresponds to our cas function. +-- We #include the prototype for this, so we need to avoid +-- generating out own C prototypes. +isCas :: CLabel -> Bool +isCas (CmmLabel pkgId fn _) = pkgId == rtsPackageId && fn == fsLit "cas" +isCas _ = False + + -- | Check whether a label corresponds to a C function that has -- a prototype in a system header somehere, or is built-in --- to the C compiler. For these labels we abovoid generating our +-- to the C compiler. For these labels we avoid generating our -- own C prototypes. isMathFun :: CLabel -> Bool isMathFun (ForeignLabel fs _ _ _) = fs `elementOfUniqSet` math_funs diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 10f4e8b..d363cef 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -248,7 +248,7 @@ pprStmt stmt = case stmt of | CmmNeverReturns <- ret -> let myCall = pprCall (pprCLabel lbl) cconv results args safety in (real_fun_proto lbl, myCall) - | not (isMathFun lbl) -> + | not (isMathFun lbl || isCas lbl) -> let myCall = braces ( pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index b28f3eb..0daa6be 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -365,6 +365,20 @@ addTickHsExpr (HsWrap w e) = (return w) (addTickHsExpr e) -- explicitly no tick on inside +addTickHsExpr (HsArrApp e1 e2 ty1 arr_ty lr) = + liftM5 HsArrApp + (addTickLHsExpr e1) + (addTickLHsExpr e2) + (return ty1) + (return arr_ty) + (return lr) + +addTickHsExpr (HsArrForm e fix cmdtop) = + liftM3 HsArrForm + (addTickLHsExpr e) + (return fix) + (mapM (liftL (addTickHsCmdTop)) cmdtop) + addTickHsExpr e@(HsType _) = return e -- Others dhould never happen in expression content. @@ -558,7 +572,7 @@ addTickHsCmd (HsLet binds c) = addTickHsCmd (HsDo cxt stmts last_exp srcloc) = do (stmts', last_exp') <- addTickLCmdStmts' stmts (addTickLHsCmd last_exp) return (HsDo cxt stmts' last_exp' srcloc) - where + addTickHsCmd (HsArrApp e1 e2 ty1 arr_ty lr) = liftM5 HsArrApp (addTickLHsExpr e1) diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index e080bee..675afa2 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -679,16 +679,12 @@ okInstDclSig (TypeSig _ _) = False okInstDclSig (FixSig _) = False okInstDclSig _ = True -sigForThisGroup :: NameSet -> LSig Name -> Bool -sigForThisGroup ns sig - = case sigName sig of - Nothing -> False - Just n -> n `elemNameSet` ns - sigName :: LSig name -> Maybe name +-- Used only in Haddock sigName (L _ sig) = sigNameNoLoc sig sigNameNoLoc :: Sig name -> Maybe name +-- Used only in Haddock sigNameNoLoc (TypeSig n _) = Just (unLoc n) sigNameNoLoc (SpecSig n _ _) = Just (unLoc n) sigNameNoLoc (InlineSig n _) = Just (unLoc n) diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs index 661dc9a..b0c63a4 100644 --- a/compiler/llvmGen/LlvmCodeGen/Regs.hs +++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs @@ -38,6 +38,8 @@ lmGlobalReg suf reg VanillaReg 4 _ -> wordGlobal $ "R4" ++ suf VanillaReg 5 _ -> wordGlobal $ "R5" ++ suf VanillaReg 6 _ -> wordGlobal $ "R6" ++ suf + VanillaReg 7 _ -> wordGlobal $ "R7" ++ suf + VanillaReg 8 _ -> wordGlobal $ "R8" ++ suf SpLim -> wordGlobal $ "SpLim" ++ suf FloatReg 1 -> floatGlobal $"F1" ++ suf FloatReg 2 -> floatGlobal $"F2" ++ suf diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 488012d..9dd9cc7 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1031,7 +1031,7 @@ runPhase cc_phase input_fn dflags gcc_extra_viac_flags <- io $ getExtraViaCOpts dflags let pic_c_flags = picCCOpts dflags - let verb = getVerbFlag dflags + let verbFlags = getVerbFlags dflags -- cc-options are not passed when compiling .hc files. Our -- hc code doesn't not #include any header files anyway, so these @@ -1118,7 +1118,8 @@ runPhase cc_phase input_fn dflags ++ (if hcc then gcc_extra_viac_flags ++ more_hcc_opts else []) - ++ [ verb, "-S", "-Wimplicit", cc_opt ] + ++ verbFlags + ++ [ "-S", "-Wimplicit", cc_opt ] ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ] #ifdef darwin_TARGET_OS ++ framework_paths @@ -1577,7 +1578,7 @@ getHCFilePackages filename = linkBinary :: DynFlags -> [FilePath] -> [PackageId] -> IO () linkBinary dflags o_files dep_packages = do - let verb = getVerbFlag dflags + let verbFlags = getVerbFlags dflags output_fn = exeFileName dflags -- get the full list of packages to link with, by combining the @@ -1655,10 +1656,10 @@ linkBinary dflags o_files dep_packages = do let md_c_flags = machdepCCOpts dflags SysTools.runLink dflags ( - [ SysTools.Option verb - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ] + map SysTools.Option verbFlags + ++ [ SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] ++ map SysTools.Option ( md_c_flags @@ -1771,7 +1772,7 @@ maybeCreateManifest dflags exe_filename = do linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO () linkDynLib dflags o_files dep_packages = do - let verb = getVerbFlag dflags + let verbFlags = getVerbFlags dflags let o_file = outputFile dflags pkgs <- getPreloadPackagesAnd dflags dep_packages @@ -1816,15 +1817,15 @@ linkDynLib dflags o_files dep_packages = do ----------------------------------------------------------------------------- let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; } - SysTools.runLink dflags - ([ SysTools.Option verb - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - , SysTools.Option "-shared" - ] ++ - [ SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a") - | dopt Opt_SharedImplib dflags - ] + SysTools.runLink dflags ( + map SysTools.Option verbFlags + ++ [ SysTools.Option "-o" + , SysTools.FileOption "" output_fn + , SysTools.Option "-shared" + ] ++ + [ SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a") + | dopt Opt_SharedImplib dflags + ] ++ map (SysTools.FileOption "") o_files ++ map SysTools.Option ( md_c_flags @@ -1876,12 +1877,12 @@ linkDynLib dflags o_files dep_packages = do Nothing -> do pwd <- getCurrentDirectory return $ pwd `combine` output_fn - SysTools.runLink dflags - ([ SysTools.Option verb - , SysTools.Option "-dynamiclib" - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ] + SysTools.runLink dflags ( + map SysTools.Option verbFlags + ++ [ SysTools.Option "-dynamiclib" + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] ++ map SysTools.Option ( md_c_flags ++ o_files @@ -1912,11 +1913,11 @@ linkDynLib dflags o_files dep_packages = do -- non-PIC intra-package-relocations ["-Wl,-Bsymbolic"] - SysTools.runLink dflags - ([ SysTools.Option verb - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ] + SysTools.runLink dflags ( + map SysTools.Option verbFlags + ++ [ SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] ++ map SysTools.Option ( md_c_flags ++ o_files @@ -1945,7 +1946,7 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do let include_paths = foldr (\ x xs -> "-I" : x : xs) [] (cmdline_include_paths ++ pkg_include_dirs) - let verb = getVerbFlag dflags + let verbFlags = getVerbFlags dflags let cc_opts | not include_cc_opts = [] @@ -1965,7 +1966,7 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do -- remember, in code we *compile*, the HOST is the same our TARGET, -- and BUILD is the same as our HOST. - cpp_prog ([SysTools.Option verb] + cpp_prog ( map SysTools.Option verbFlags ++ map SysTools.Option include_paths ++ map SysTools.Option hsSourceCppOpts ++ map SysTools.Option target_defs diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 832f2d2..70358ee 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -40,7 +40,7 @@ module DynFlags ( initDynFlags, -- DynFlags -> IO DynFlags getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] - getVerbFlag, + getVerbFlags, updOptLevel, setTmpDir, setPackageName, @@ -878,10 +878,10 @@ getOpts dflags opts = reverse (opts dflags) -- | Gets the verbosity flag for the current verbosity level. This is fed to -- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included -getVerbFlag :: DynFlags -> String -getVerbFlag dflags - | verbosity dflags >= 3 = "-v" - | otherwise = "" +getVerbFlags :: DynFlags -> [String] +getVerbFlags dflags + | verbosity dflags >= 4 = ["-v"] + | otherwise = [] setObjectDir, setHiDir, setStubDir, setOutputDir, setDylibInstallName, setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode, diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index 54f0a92..5767a52 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/compiler/main/StaticFlagParser.hs @@ -210,7 +210,6 @@ unregFlags :: [Located String] unregFlags = map (mkGeneralLocated "in unregFlags") [ "-optc-DNO_REGS" , "-optc-DUSE_MINIINTERPRETER" - , "-fno-asm-mangling" , "-funregisterised" ] ----------------------------------------------------------------------------- diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 6c57cb2..21822a8 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -699,7 +699,7 @@ renameSig _ (SpecInstSig ty) -- {-# SPECIALISE #-} pragmas can refer to imported Ids -- so, in the top-level case (when mb_names is Nothing) -- we use lookupOccRn. If there's both an imported and a local 'f' --- then the SPECIALISE pragma is ambiguous, unlike alll other signatures +-- then the SPECIALISE pragma is ambiguous, unlike all other signatures renameSig mb_names sig@(SpecSig v ty inl) = do { new_v <- case mb_names of Just {} -> lookupSigOccRn mb_names sig v diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index a5aa5e1..a6503a8 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -12,7 +12,7 @@ module RnEnv ( lookupLocalDataTcNames, lookupSigOccRn, lookupFixityRn, lookupTyFixityRn, lookupInstDeclBndr, lookupSubBndr, lookupConstructorFields, - lookupSyntaxName, lookupSyntaxTable, + lookupSyntaxName, lookupSyntaxTable, lookupIfThenElse, lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe, getLookupOccRn, addUsedRdrNames, @@ -755,6 +755,17 @@ We treat the orignal (standard) names as free-vars too, because the type checker checks the type of the user thing against the type of the standard thing. \begin{code} +lookupIfThenElse :: RnM (Maybe (SyntaxExpr Name), FreeVars) +-- Different to lookupSyntaxName because in the non-rebindable +-- case we desugar directly rather than calling an existing function +-- Hence the (Maybe (SyntaxExpr Name)) return type +lookupIfThenElse + = do { rebind <- xoptM Opt_RebindableSyntax + ; if not rebind + then return (Nothing, emptyFVs) + else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse")) + ; return (Just (HsVar ite), unitFV ite) } } + lookupSyntaxName :: Name -- The standard name -> RnM (SyntaxExpr Name, FreeVars) -- Possibly a non-standard name lookupSyntaxName std_name diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index f71b17c..1b7eef0 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -291,15 +291,10 @@ rnExpr (ExprWithTySig expr pty) rnExpr (HsIf _ p b1 b2) = do { (p', fvP) <- rnLExpr p - ; (b1', fvB1) <- rnLExpr b1 - ; (b2', fvB2) <- rnLExpr b2 - ; rebind <- xoptM Opt_RebindableSyntax - ; if not rebind - then return (HsIf Nothing p' b1' b2', plusFVs [fvP, fvB1, fvB2]) - else do { hetMetLevel <- getHetMetLevel - ; n <- lookupOccRn $ mkRdrUnqual $ setOccNameDepth (length hetMetLevel) (mkVarOccFS (fsLit "ifThenElse")) - ; c <- return $ HsVar n - ; return (HsIf (Just c) p' b1' b2', plusFVs [fvP, fvB1, fvB2]) }} + ; (b1', fvB1) <- rnLExpr b1 + ; (b2', fvB2) <- rnLExpr b2 + ; (mb_ite, fvITE) <- lookupIfThenElse + ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } rnExpr (HsType a) = rnHsTypeFVs doc a `thenM` \ (t, fvT) -> diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 8a6a3b7..33e9081 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -25,7 +25,6 @@ import TcHsType import TcPat import TcMType import TcType -import RnBinds( misplacedSigErr ) import Coercion import TysPrim import Id @@ -44,7 +43,6 @@ import BasicTypes import Outputable import FastString -import Data.List( partition ) import Control.Monad #include "HsVersions.h" @@ -559,24 +557,16 @@ tcSpec _ prag = pprPanic "tcSpec" (ppr prag) tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag] tcImpPrags prags = do { this_mod <- getModule - ; let is_imp prag - = case sigName prag of - Nothing -> False - Just name -> not (nameIsLocalOrFrom this_mod name) - (spec_prags, others) = partition isSpecLSig $ - filter is_imp prags - ; mapM_ misplacedSigErr others - -- Messy that this misplaced-sig error comes here - -- but the others come from the renamer - ; mapAndRecoverM (wrapLocM tcImpSpec) spec_prags } - -tcImpSpec :: Sig Name -> TcM TcSpecPrag -tcImpSpec prag@(SpecSig (L _ name) _ _) + ; mapAndRecoverM (wrapLocM tcImpSpec) + [L loc (name,prag) | (L loc prag@(SpecSig (L _ name) _ _)) <- prags + , not (nameIsLocalOrFrom this_mod name) ] } + +tcImpSpec :: (Name, Sig Name) -> TcM TcSpecPrag +tcImpSpec (name, prag) = do { id <- tcLookupId name ; checkTc (isAnyInlinePragma (idInlinePragma id)) (impSpecErr name) ; tcSpec id prag } -tcImpSpec p = pprPanic "tcImpSpec" (ppr p) impSpecErr :: Name -> SDoc impSpecErr name diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 2988f08..1798be3 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -1282,7 +1282,7 @@ inferInstanceContexts oflag infer_specs gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs }) = setSrcSpan loc $ - addErrCtxt (derivInstCtxt clas inst_tys) $ + addErrCtxt (derivInstCtxt the_pred) $ do { -- Check for a bizarre corner case, when the derived instance decl should -- have form instance C a b => D (T a) where ... -- Note that 'b' isn't a parameter of T. This gives rise to all sorts @@ -1297,7 +1297,7 @@ inferInstanceContexts oflag infer_specs , not (tyVarsOfPred pred `subVarSet` tv_set)] ; mapM_ (addErrTc . badDerivedPred) weird_preds - ; theta <- simplifyDeriv orig tyvars deriv_rhs + ; theta <- simplifyDeriv orig the_pred tyvars deriv_rhs -- checkValidInstance tyvars theta clas inst_tys -- Not necessary; see Note [Exotic derived instance contexts] -- in TcSimplify @@ -1307,6 +1307,8 @@ inferInstanceContexts oflag infer_specs -- Hence no need to call: -- checkValidInstance tyvars theta clas inst_tys ; return (sortLe (<=) theta) } -- Canonicalise before returning the solution + where + the_pred = mkClassPred clas inst_tys ------------------------------------------------------------------ mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> Instance @@ -1511,9 +1513,9 @@ standaloneCtxt :: LHsType Name -> SDoc standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for")) 2 (quotes (ppr ty)) -derivInstCtxt :: Class -> [Type] -> Message -derivInstCtxt clas inst_tys - = ptext (sLit "When deriving the instance for") <+> parens (pprClassPred clas inst_tys) +derivInstCtxt :: PredType -> Message +derivInstCtxt pred + = ptext (sLit "When deriving the instance for") <+> parens (ppr pred) badDerivedPred :: PredType -> Message badDerivedPred pred diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 2c04cf4..efacac2 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -893,15 +893,15 @@ gen_Read_binds get_fixity loc tycon read_nullary_cons = case nullary_cons of [] -> [] - [con] -> [nlHsDo DoExpr [bindLex (match_con con)] (result_expr con [])] + [con] -> [nlHsDo DoExpr (match_con con) (result_expr con [])] _ -> [nlHsApp (nlHsVar choose_RDR) (nlList (map mk_pair nullary_cons))] -- NB For operators the parens around (:=:) are matched by the -- enclosing "parens" call, so here we must match the naked -- data_con_str con - match_con con | isSym con_str = symbol_pat con_str - | otherwise = ident_pat con_str + match_con con | isSym con_str = [symbol_pat con_str] + | otherwise = ident_h_pat con_str where con_str = data_con_str con -- For nullary constructors we must match Ident s for normal constrs @@ -925,12 +925,12 @@ gen_Read_binds get_fixity loc tycon prefix_parser = mk_parser prefix_prec prefix_stmts body read_prefix_con - | isSym con_str = [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"] - | otherwise = [bindLex (ident_pat con_str)] + | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"] + | otherwise = ident_h_pat con_str read_infix_con - | isSym con_str = [bindLex (symbol_pat con_str)] - | otherwise = [read_punc "`", bindLex (ident_pat con_str), read_punc "`"] + | isSym con_str = [symbol_pat con_str] + | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"] prefix_stmts -- T a b c = read_prefix_con ++ read_args @@ -972,8 +972,15 @@ gen_Read_binds get_fixity loc tycon result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c' - ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo" - symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>" + + -- For constructors and field labels ending in '#', we hackily + -- let the lexer generate two tokens, and look for both in sequence + -- Thus [Ident "I"; Symbol "#"]. See Trac #5041 + ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ] + | otherwise = [ ident_pat s ] + + ident_pat s = bindLex $ nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo" <- lexP + symbol_pat s = bindLex $ nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>" <- lexP data_con_str con = occNameString (getOccName con) @@ -991,11 +998,9 @@ gen_Read_binds get_fixity loc tycon -- or (#) = 4 -- Note the parens! read_lbl lbl | isSym lbl_str - = [read_punc "(", - bindLex (symbol_pat lbl_str), - read_punc ")"] + = [read_punc "(", symbol_pat lbl_str, read_punc ")"] | otherwise - = [bindLex (ident_pat lbl_str)] + = ident_h_pat lbl_str where lbl_str = occNameString (getOccName lbl) \end{code} diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 87cd5eb..cbf9330 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -103,7 +103,9 @@ import HsBinds -- for TcEvBinds stuff import Id import TcRnTypes - +#ifdef DEBUG +import Control.Monad( when ) +#endif import Data.IORef \end{code} @@ -421,17 +423,16 @@ type TcsUntouchables = (Untouchables,TcTyVarSet) \begin{code} data SimplContext - = SimplInfer -- Inferring type of a let-bound thing - | SimplRuleLhs -- Inferring type of a RULE lhs - | SimplInteractive -- Inferring type at GHCi prompt - | SimplCheck -- Checking a type signature or RULE rhs - deriving Eq + = SimplInfer SDoc -- Inferring type of a let-bound thing + | SimplRuleLhs RuleName -- Inferring type of a RULE lhs + | SimplInteractive -- Inferring type at GHCi prompt + | SimplCheck SDoc -- Checking a type signature or RULE rhs instance Outputable SimplContext where - ppr SimplInfer = ptext (sLit "SimplInfer") - ppr SimplRuleLhs = ptext (sLit "SimplRuleLhs") + ppr (SimplInfer d) = ptext (sLit "SimplInfer") <+> d + ppr (SimplCheck d) = ptext (sLit "SimplCheck") <+> d + ppr (SimplRuleLhs n) = ptext (sLit "SimplRuleLhs") <+> doubleQuotes (ftext n) ppr SimplInteractive = ptext (sLit "SimplInteractive") - ppr SimplCheck = ptext (sLit "SimplCheck") isInteractive :: SimplContext -> Bool isInteractive SimplInteractive = True @@ -441,14 +442,14 @@ simplEqsOnly :: SimplContext -> Bool -- Simplify equalities only, not dictionaries -- This is used for the LHS of rules; ee -- Note [Simplifying RULE lhs constraints] in TcSimplify -simplEqsOnly SimplRuleLhs = True -simplEqsOnly _ = False +simplEqsOnly (SimplRuleLhs {}) = True +simplEqsOnly _ = False performDefaulting :: SimplContext -> Bool -performDefaulting SimplInfer = False -performDefaulting SimplRuleLhs = False -performDefaulting SimplInteractive = True -performDefaulting SimplCheck = True +performDefaulting (SimplInfer {}) = False +performDefaulting (SimplRuleLhs {}) = False +performDefaulting SimplInteractive = True +performDefaulting (SimplCheck {}) = True --------------- newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } @@ -526,7 +527,8 @@ runTcS context untouch tcs #ifdef DEBUG ; count <- TcM.readTcRef step_count - ; TcM.dumpTcRn (ptext (sLit "Constraint solver steps =") <+> int count) + ; when (count > 0) $ + TcM.dumpTcRn (ptext (sLit "Constraint solver steps =") <+> int count <+> ppr context) #endif -- And return ; ev_binds <- TcM.readTcRef evb_ref @@ -563,8 +565,9 @@ recoverTcS (TcS recovery_code) (TcS thing_inside) ctxtUnderImplic :: SimplContext -> SimplContext -- See Note [Simplifying RULE lhs constraints] in TcSimplify -ctxtUnderImplic SimplRuleLhs = SimplCheck -ctxtUnderImplic ctxt = ctxt +ctxtUnderImplic (SimplRuleLhs n) = SimplCheck (ptext (sLit "lhs of rule") + <+> doubleQuotes (ftext n)) +ctxtUnderImplic ctxt = ctxt tryTcS :: TcS a -> TcS a -- Like runTcS, but from within the TcS monad diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index eecfb27..cf41372 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -49,7 +49,7 @@ simplifyTop :: WantedConstraints -> TcM (Bag EvBind) -- but when there is nothing to quantify we don't wrap -- in a degenerate implication, so we do that here instead simplifyTop wanteds - = simplifyCheck SimplCheck wanteds + = simplifyCheck (SimplCheck (ptext (sLit "top level"))) wanteds ------------------ simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind) @@ -61,7 +61,8 @@ simplifyDefault :: ThetaType -- Wanted; has no type variables in it -> TcM () -- Succeeds iff the constraint is soluble simplifyDefault theta = do { wanted <- newFlatWanteds DefaultOrigin theta - ; _ignored_ev_binds <- simplifyCheck SimplCheck (mkFlatWC wanted) + ; _ignored_ev_binds <- simplifyCheck (SimplCheck (ptext (sLit "defaults"))) + (mkFlatWC wanted) ; return () } \end{code} @@ -75,13 +76,14 @@ simplifyDefault theta \begin{code} simplifyDeriv :: CtOrigin - -> [TyVar] - -> ThetaType -- Wanted - -> TcM ThetaType -- Needed + -> PredType + -> [TyVar] + -> ThetaType -- Wanted + -> TcM ThetaType -- Needed -- Given instance (wanted) => C inst_ty -- Simplify 'wanted' as much as possibles -- Fail if not possible -simplifyDeriv orig tvs theta +simplifyDeriv orig pred tvs theta = do { tvs_skols <- tcInstSkolTyVars tvs -- Skolemize -- The constraint solving machinery -- expects *TcTyVars* not TyVars. @@ -90,12 +92,13 @@ simplifyDeriv orig tvs theta ; let skol_subst = zipTopTvSubst tvs $ map mkTyVarTy tvs_skols subst_skol = zipTopTvSubst tvs_skols $ map mkTyVarTy tvs + doc = parens $ ptext (sLit "deriving") <+> parens (ppr pred) ; wanted <- newFlatWanteds orig (substTheta skol_subst theta) ; traceTc "simplifyDeriv" (ppr tvs $$ ppr theta $$ ppr wanted) ; (residual_wanted, _binds) - <- runTcS SimplInfer NoUntouchables $ + <- runTcS (SimplInfer doc) NoUntouchables $ solveWanteds emptyInert (mkFlatWC wanted) ; let (good, bad) = partitionBagWith get_good (wc_flat residual_wanted) @@ -247,7 +250,7 @@ simplifyInfer top_lvl apply_mr name_taus wanteds -- Step 2 -- Now simplify the possibly-bound constraints ; (simpl_results, tc_binds0) - <- runTcS SimplInfer NoUntouchables $ + <- runTcS (SimplInfer (ppr (map fst name_taus))) NoUntouchables $ simplifyWithApprox (zonked_wanteds { wc_flat = perhaps_bound }) ; when (insolubleWC simpl_results) -- Fail fast if there is an insoluble constraint @@ -547,7 +550,7 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted -- variables; hence *no untouchables* ; (lhs_results, lhs_binds) - <- runTcS SimplRuleLhs untch $ + <- runTcS (SimplRuleLhs name) untch $ solveWanteds emptyInert zonked_lhs ; traceTc "simplifyRule" $ @@ -589,7 +592,8 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted -- Hence the rather painful ad-hoc treatement here ; rhs_binds_var@(EvBindsVar evb_ref _) <- newTcEvBinds - ; rhs_binds1 <- simplifyCheck SimplCheck $ + ; let doc = ptext (sLit "rhs of rule") <+> doubleQuotes (ftext name) + ; rhs_binds1 <- simplifyCheck (SimplCheck doc) $ WC { wc_flat = emptyBag , wc_insol = emptyBag , wc_impl = unitBag $ diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index aa1f941..1be55d7 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -485,9 +485,7 @@ pprKind = pprType pprParendKind = pprParendType ppr_type :: Prec -> Type -> SDoc -ppr_type _ (TyVarTy tv) -- Note [Infix type variables] - | isSymOcc (getOccName tv) = parens (ppr tv) - | otherwise = ppr tv +ppr_type _ (TyVarTy tv) = ppr_tvar tv ppr_type p (PredTy pred) = maybeParen p TyConPrec $ ifPprDebug (ptext (sLit "")) <> (ppr pred) ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys @@ -572,14 +570,19 @@ ppr_tc tc else ptext (sLit "")) | otherwise = empty +ppr_tvar :: TyVar -> SDoc +ppr_tvar tv -- Note [Infix type variables] + | isSymOcc (getOccName tv) = parens (ppr tv) + | otherwise = ppr tv + ------------------- pprForAll :: [TyVar] -> SDoc pprForAll [] = empty pprForAll tvs = ptext (sLit "forall") <+> sep (map pprTvBndr tvs) <> dot pprTvBndr :: TyVar -> SDoc -pprTvBndr tv | isLiftedTypeKind kind = ppr tv - | otherwise = parens (ppr tv <+> dcolon <+> pprKind kind) +pprTvBndr tv | isLiftedTypeKind kind = ppr_tvar tv + | otherwise = parens (ppr_tvar tv <+> dcolon <+> pprKind kind) where kind = tyVarKind tv \end{code} diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index e0940ae..26ab9eb 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -1180,6 +1180,13 @@ + + warn about polymorphic local bindings without signatures + dynamic + + + + warn when names are shadowed dynamic diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml index 8b08d9d..115c290 100644 --- a/docs/users_guide/using.xml +++ b/docs/users_guide/using.xml @@ -1373,6 +1373,20 @@ module M where + : + + + type signatures, missing + + If you use the + flag GHC will warn + you about any polymorphic local bindings. As part of + the warning GHC also reports the inferred type. The + option is off by default. + + + + : diff --git a/ghc/ghc.mk b/ghc/ghc.mk index 8776566..93199d9 100644 --- a/ghc/ghc.mk +++ b/ghc/ghc.mk @@ -111,21 +111,23 @@ all_ghc_stage3 : $(GHC_STAGE3) $(INPLACE_LIB)/extra-gcc-opts : extra-gcc-opts "$(CP)" $< $@ -# The GHC programs need to depend on all the helper programs they might call +# The GHC programs need to depend on all the helper programs they might call, +# and the settings files they use + +$(GHC_STAGE1) : | $(UNLIT) $(INPLACE_LIB)/extra-gcc-opts +$(GHC_STAGE2) : | $(UNLIT) $(INPLACE_LIB)/extra-gcc-opts +$(GHC_STAGE3) : | $(UNLIT) $(INPLACE_LIB)/extra-gcc-opts + ifeq "$(GhcUnregisterised)" "NO" -$(GHC_STAGE1) : $(SPLIT) -$(GHC_STAGE2) : $(SPLIT) -$(GHC_STAGE3) : $(SPLIT) +$(GHC_STAGE1) : | $(SPLIT) +$(GHC_STAGE2) : | $(SPLIT) +$(GHC_STAGE3) : | $(SPLIT) endif -$(GHC_STAGE1) : $(INPLACE_LIB)/extra-gcc-opts -$(GHC_STAGE2) : $(INPLACE_LIB)/extra-gcc-opts -$(GHC_STAGE3) : $(INPLACE_LIB)/extra-gcc-opts - ifeq "$(Windows)" "YES" -$(GHC_STAGE1) : $(TOUCHY) -$(GHC_STAGE2) : $(TOUCHY) -$(GHC_STAGE3) : $(TOUCHY) +$(GHC_STAGE1) : | $(TOUCHY) +$(GHC_STAGE2) : | $(TOUCHY) +$(GHC_STAGE3) : | $(TOUCHY) endif ifeq "$(BootingFromHc)" "YES" diff --git a/utils/ghc-cabal/Main.hs b/utils/ghc-cabal/Main.hs index 72a5010..d64c224 100644 --- a/utils/ghc-cabal/Main.hs +++ b/utils/ghc-cabal/Main.hs @@ -28,7 +28,8 @@ import System.Exit import System.FilePath main :: IO () -main = do args <- getArgs +main = do hSetBuffering stdout LineBuffering + args <- getArgs case args of "hscolour" : distDir : dir : args' -> runHsColour distDir dir args'