diff options
27 files changed, 723 insertions, 397 deletions
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 9e3acb41f9..293cc4a9a2 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -16,31 +16,31 @@ HsTypes: Abstract syntax: user-defined types {-# LANGUAGE DeriveDataTypeable #-} module HsTypes ( - HsType(..), LHsType, HsKind, LHsKind, - HsBndrSig(..), HsTyVarBndr(..), LHsTyVarBndr, - HsTupleSort(..), HsExplicitFlag(..), - HsContext, LHsContext, - HsQuasiQuote(..), + HsType(..), LHsType, HsKind, LHsKind, + HsBndrSig(..), HsTyVarBndr(..), LHsTyVarBndr, + HsTupleSort(..), HsExplicitFlag(..), + HsContext, LHsContext, + HsQuasiQuote(..), HsTyWrapper(..), HsTyLit(..), - LBangType, BangType, HsBang(..), + LBangType, BangType, HsBang(..), getBangType, getBangStrictness, - ConDeclField(..), pprConDeclFields, - - mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs, - hsTyVarName, hsTyVarNames, - hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, - splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe, + ConDeclField(..), pprConDeclFields, + + mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs, + hsTyVarName, hsTyVarNames, + hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, + splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe, splitHsForAllTy, splitLHsForAllTy, splitHsClassTy_maybe, splitLHsClassTy_maybe, splitHsFunType, - splitHsAppTys, mkHsAppTys, mkHsOpTy, + splitHsAppTys, mkHsAppTys, mkHsOpTy, placeHolderBndrs, - -- Printing - pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, + -- Printing + pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, ) where import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) @@ -62,16 +62,16 @@ import Data.Data %************************************************************************ -%* * - Quasi quotes; used in types and elsewhere -%* * +%* * + Quasi quotes; used in types and elsewhere +%* * %************************************************************************ \begin{code} data HsQuasiQuote id = HsQuasiQuote - id -- The quasi-quoter - SrcSpan -- The span of the enclosed string - FastString -- The enclosed string + id -- The quasi-quoter + SrcSpan -- The span of the enclosed string + FastString -- The enclosed string deriving (Data, Typeable) instance OutputableBndr id => Outputable (HsQuasiQuote id) where @@ -85,14 +85,14 @@ ppr_qq (HsQuasiQuote quoter _ quote) = %************************************************************************ -%* * +%* * \subsection{Bang annotations} -%* * +%* * %************************************************************************ \begin{code} type LBangType name = Located (BangType name) -type BangType name = HsType name -- Bangs are in the HsType data type +type BangType name = HsType name -- Bangs are in the HsType data type getBangType :: LHsType a -> LHsType a getBangType (L _ (HsBangTy _ ty)) = ty @@ -105,9 +105,9 @@ getBangStrictness _ = HsNoBang %************************************************************************ -%* * +%* * \subsection{Data types} -%* * +%* * %************************************************************************ This is the syntax for types as seen in type signatures. @@ -148,8 +148,8 @@ placeHolderBndrs :: [Name] placeHolderBndrs = panic "placeHolderBndrs" data HsTyVarBndr name - = UserTyVar -- No explicit kinding - name -- See Note [Printing KindedTyVars] + = UserTyVar -- No explicit kinding + name -- See Note [Printing KindedTyVars] | KindedTyVar name @@ -160,57 +160,57 @@ data HsTyVarBndr name deriving (Data, Typeable) data HsType name - = HsForAllTy HsExplicitFlag -- Renamer leaves this flag unchanged, to record the way - -- the user wrote it originally, so that the printer can - -- print it as the user wrote it - [LHsTyVarBndr name] -- See Note [HsForAllTy tyvar binders] - (LHsContext name) - (LHsType name) - - | HsTyVar name -- Type variable, type constructor, or data constructor + = HsForAllTy HsExplicitFlag -- Renamer leaves this flag unchanged, to record the way + -- the user wrote it originally, so that the printer can + -- print it as the user wrote it + [LHsTyVarBndr name] -- See Note [HsForAllTy tyvar binders] + (LHsContext name) + (LHsType name) + + | HsTyVar name -- Type variable, type constructor, or data constructor -- see Note [Promotions (HsTyVar)] - | HsAppTy (LHsType name) - (LHsType name) + | HsAppTy (LHsType name) + (LHsType name) - | HsFunTy (LHsType name) -- function type - (LHsType name) + | HsFunTy (LHsType name) -- function type + (LHsType name) - | HsListTy (LHsType name) -- Element type + | HsListTy (LHsType name) -- Element type - | HsPArrTy (LHsType name) -- Elem. type of parallel array: [:t:] + | HsPArrTy (LHsType name) -- Elem. type of parallel array: [:t:] - | HsTupleTy HsTupleSort - [LHsType name] -- Element types (length gives arity) + | HsTupleTy HsTupleSort + [LHsType name] -- Element types (length gives arity) - | HsOpTy (LHsType name) (LHsTyOp name) (LHsType name) + | HsOpTy (LHsType name) (LHsTyOp name) (LHsType name) - | HsParTy (LHsType name) -- See Note [Parens in HsSyn] in HsExpr - -- Parenthesis preserved for the precedence re-arrangement in RnTypes - -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! + | HsParTy (LHsType name) -- See Note [Parens in HsSyn] in HsExpr + -- Parenthesis preserved for the precedence re-arrangement in RnTypes + -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! - | HsIParamTy (IPName name) -- (?x :: ty) + | HsIParamTy (IPName name) -- (?x :: ty) (LHsType name) -- Implicit parameters as they occur in contexts | HsEqTy (LHsType name) -- ty1 ~ ty2 (LHsType name) -- Always allowed even without TypeOperators, and has special kinding rule - | HsKindSig (LHsType name) -- (ty :: kind) - (LHsKind name) -- A type with a kind signature + | HsKindSig (LHsType name) -- (ty :: kind) + (LHsKind name) -- A type with a kind signature - | HsQuasiQuoteTy (HsQuasiQuote name) + | HsQuasiQuoteTy (HsQuasiQuote name) - | HsSpliceTy (HsSplice name) - FreeVars -- Variables free in the splice (filled in by renamer) - PostTcKind + | HsSpliceTy (HsSplice name) + FreeVars -- Variables free in the splice (filled in by renamer) + PostTcKind | HsDocTy (LHsType name) LHsDocString -- A documented type - | HsBangTy HsBang (LHsType name) -- Bang-style type annotations - | HsRecTy [ConDeclField name] -- Only in data type declarations + | HsBangTy HsBang (LHsType name) -- Bang-style type annotations + | HsRecTy [ConDeclField name] -- Only in data type declarations - | HsCoreTy Type -- An escape hatch for tunnelling a *closed* - -- Core Type through HsSyn. + | HsCoreTy Type -- An escape hatch for tunnelling a *closed* + -- Core Type through HsSyn. | HsExplicitListTy -- A promoted explicit list PostTcKind -- See Note [Promoted lists and tuples] @@ -339,16 +339,16 @@ data HsTupleSort = HsUnboxedTuple data HsExplicitFlag = Explicit | Implicit deriving (Data, Typeable) -data ConDeclField name -- Record fields have Haddoc docs on them +data ConDeclField name -- Record fields have Haddoc docs on them = ConDeclField { cd_fld_name :: Located name, - cd_fld_type :: LBangType name, - cd_fld_doc :: Maybe LHsDocString } + cd_fld_type :: LBangType name, + cd_fld_doc :: Maybe LHsDocString } deriving (Data, Typeable) ----------------------- -- Combine adjacent for-alls. -- The following awkward situation can happen otherwise: --- f :: forall a. ((Num a) => Int) +-- f :: forall a. ((Num a) => Int) -- might generate HsForAll (Just [a]) [] (HsForAll Nothing [Num a] t) -- Then a isn't discovered as ambiguous, and we abstract the AbsBinds wrt [] -- but the export list abstracts f wrt [a]. Disaster. @@ -367,14 +367,14 @@ mkHsForAllTy exp tvs ctxt ty = HsForAllTy exp tvs ctxt ty -- mk_forall_ty makes a pure for-all type (no context) mk_forall_ty :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsType name -> HsType name -mk_forall_ty exp tvs (L _ (HsParTy ty)) = mk_forall_ty exp tvs ty +mk_forall_ty exp tvs (L _ (HsParTy ty)) = mk_forall_ty exp tvs ty mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 tvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ tvs2) ctxt ty -mk_forall_ty exp tvs ty = HsForAllTy exp tvs (noLoc []) ty - -- Even if tvs is empty, we still make a HsForAll! - -- In the Implicit case, this signals the place to do implicit quantification - -- In the Explicit case, it prevents implicit quantification - -- (see the sigtype production in Parser.y.pp) - -- so that (forall. ty) isn't implicitly quantified +mk_forall_ty exp tvs ty = HsForAllTy exp tvs (noLoc []) ty + -- Even if tvs is empty, we still make a HsForAll! + -- In the Implicit case, this signals the place to do implicit quantification + -- In the Explicit case, it prevents implicit quantification + -- (see the sigtype production in Parser.y.pp) + -- so that (forall. ty) isn't implicitly quantified plus :: HsExplicitFlag -> HsExplicitFlag -> HsExplicitFlag Implicit `plus` Implicit = Implicit @@ -410,14 +410,14 @@ hsLTyVarLocNames = map hsLTyVarLocName \begin{code} splitHsAppTys :: LHsType n -> [LHsType n] -> (LHsType n, [LHsType n]) splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as) -splitHsAppTys f as = (f,as) +splitHsAppTys f as = (f,as) mkHsAppTys :: OutputableBndr n => LHsType n -> [LHsType n] -> HsType n mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty) mkHsAppTys fun_ty (arg_ty:arg_tys) = foldl mk_app (HsAppTy fun_ty arg_ty) arg_tys where - mk_app fun arg = HsAppTy (noLoc fun) arg + mk_app fun arg = HsAppTy (noLoc fun) arg -- Add noLocs for inner nodes of the application; -- they are never used @@ -429,7 +429,7 @@ splitHsInstDeclTy_maybe ty splitLHsInstDeclTy_maybe :: LHsType name -> Maybe ([LHsTyVarBndr name], HsContext name, Located name, [LHsType name]) - -- Split up an instance decl type, returning the pieces + -- Split up an instance decl type, returning the pieces splitLHsInstDeclTy_maybe inst_ty = do let (tvs, cxt, ty) = splitLHsForAllTy inst_ty (cls, tys) <- splitLHsClassTy_maybe ty @@ -471,20 +471,20 @@ splitLHsClassTy_maybe ty -- Splits HsType into the (init, last) parts -- Breaks up any parens in the result type: --- splitHsFunType (a -> (b -> c)) = ([a,b], c) +-- splitHsFunType (a -> (b -> c)) = ([a,b], c) splitHsFunType :: LHsType name -> ([LHsType name], LHsType name) splitHsFunType (L _ (HsFunTy x y)) = (x:args, res) where (args, res) = splitHsFunType y splitHsFunType (L _ (HsParTy ty)) = splitHsFunType ty -splitHsFunType other = ([], other) +splitHsFunType other = ([], other) \end{code} %************************************************************************ -%* * +%* * \subsection{Pretty printing} -%* * +%* * %************************************************************************ \begin{code} @@ -507,12 +507,12 @@ pprHsForAll exp tvs cxt | otherwise = pprHsContext (unLoc cxt) where show_forall = opt_PprStyle_Debug - || (not (null tvs) && is_explicit) + || (not (null tvs) && is_explicit) is_explicit = case exp of {Explicit -> True; Implicit -> False} forall_part = ptext (sLit "forall") <+> interppSP tvs <> dot pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc -pprHsContext [] = empty +pprHsContext [] = empty pprHsContext [L _ pred] = ppr pred <+> darrow pprHsContext cxt = ppr_hs_context cxt <+> darrow @@ -524,8 +524,8 @@ pprConDeclFields :: OutputableBndr name => [ConDeclField name] -> SDoc pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) where ppr_fld (ConDeclField { cd_fld_name = n, cd_fld_type = ty, - cd_fld_doc = doc }) - = ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc + cd_fld_doc = doc }) + = ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc \end{code} Note [Printing KindedTyVars] @@ -549,12 +549,12 @@ pREC_OP = 2 -- Used for arg of any infix operator pREC_CON = 3 -- Used for arg of type applicn: -- always parenthesise unless atomic -maybeParen :: Int -- Precedence of context - -> Int -- Precedence of top-level operator - -> SDoc -> SDoc -- Wrap in parens if (ctxt >= op) +maybeParen :: Int -- Precedence of context + -> Int -- Precedence of top-level operator + -> SDoc -> SDoc -- Wrap in parens if (ctxt >= op) maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p - | otherwise = p - + | otherwise = p + -- printing works more-or-less as for Types pprHsType, pprParendHsType :: (OutputableBndr name) => HsType name -> SDoc @@ -567,7 +567,7 @@ pprParendHsType ty = ppr_mono_ty pREC_CON ty -- (b) Drop top-level for-all type variables in user style -- since they are implicit in Haskell prepare :: PprStyle -> HsType name -> HsType name -prepare sty (HsParTy ty) = prepare sty (unLoc ty) +prepare sty (HsParTy ty) = prepare sty (unLoc ty) prepare _ ty = ty ppr_mono_lty :: (OutputableBndr name) => Int -> LHsType name -> SDoc @@ -588,8 +588,8 @@ ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys) HsUnboxedTuple -> UnboxedTuple _ -> BoxedTuple ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> ppr kind) -ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty) -ppr_mono_ty _ (HsPArrTy ty) = paBrackets (ppr_mono_lty pREC_TOP ty) +ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty) +ppr_mono_ty _ (HsPArrTy ty) = paBrackets (ppr_mono_lty pREC_TOP ty) ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec pREC_FUN (ppr n <+> dcolon <+> ppr_mono_lty pREC_TOP ty) ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s ppr_mono_ty _ (HsCoreTy ty) = ppr ty @@ -627,7 +627,7 @@ ppr_mono_ty _ (HsParTy ty) = parens (ppr_mono_lty pREC_TOP ty) -- Put the parens in where the user did -- But we still use the precedence stuff to add parens because - -- toHsType doesn't put in any HsParTys, so we may still need them + -- toHsType doesn't put in any HsParTys, so we may still need them ppr_mono_ty ctxt_prec (HsDocTy ty doc) = maybeParen ctxt_prec pREC_OP $ @@ -639,7 +639,7 @@ ppr_mono_ty ctxt_prec (HsDocTy ty doc) ppr_fun_ty :: (OutputableBndr name) => Int -> LHsType name -> LHsType name -> SDoc ppr_fun_ty ctxt_prec ty1 ty2 = let p1 = ppr_mono_lty pREC_FUN ty1 - p2 = ppr_mono_lty pREC_TOP ty2 + p2 = ppr_mono_lty pREC_TOP ty2 in maybeParen ctxt_prec pREC_FUN $ sep [p1, ptext (sLit "->") <+> p2] diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 2cc8446ba1..13a5f01e7f 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -597,6 +597,7 @@ data DynFlags = DynFlags { flushErr :: FlushErr, haddockOptions :: Maybe String, + ghciScripts :: [String], -- | what kind of {-# SCC #-} to add automatically profAuto :: ProfAuto, @@ -941,6 +942,7 @@ defaultDynFlags mySettings = haddockOptions = Nothing, flags = IntSet.fromList (map fromEnum defaultFlags), warningFlags = IntSet.fromList (map fromEnum standardWarnings), + ghciScripts = [], language = Nothing, safeHaskell = Sf_SafeInfered, thOnLoc = noSrcSpan, @@ -1183,7 +1185,7 @@ setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir, setDylibInstallName, setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode, setPgmP, addOptl, addOptP, - addCmdlineFramework, addHaddockOpts + addCmdlineFramework, addHaddockOpts, addGhciScript :: String -> DynFlags -> DynFlags setOutputFile, setOutputHi, setDumpPrefixForce :: Maybe String -> DynFlags -> DynFlags @@ -1255,6 +1257,8 @@ addCmdlineFramework f d = d{ cmdlineFrameworks = f : cmdlineFrameworks d} addHaddockOpts f d = d{ haddockOptions = Just f} +addGhciScript f d = d{ ghciScripts = f : ghciScripts d} + -- ----------------------------------------------------------------------------- -- Command-line options @@ -1545,6 +1549,7 @@ dynamic_flags = [ , Flag "haddock" (NoArg (setDynFlag Opt_Haddock)) , Flag "haddock-opts" (hasArg addHaddockOpts) , Flag "hpcdir" (SepArg setOptHpcDir) + , Flag "ghci-script" (hasArg addGhciScript) ------- recompilation checker -------------------------------------- , Flag "recomp" (NoArg (do unSetDynFlag Opt_ForceRecomp diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 6322024c9e..6ea12e51be 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -160,12 +160,12 @@ blockSize = 1024 lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token] lazyGetToks dflags filename handle = do buf <- hGetStringBufferBlock handle blockSize - unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False + unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False blockSize where loc = mkRealSrcLoc (mkFastString filename) 1 1 - lazyLexBuf :: Handle -> PState -> Bool -> IO [Located Token] - lazyLexBuf handle state eof = do + lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token] + lazyLexBuf handle state eof size = do case unP (lexer return) state of POk state' t -> do -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ()) @@ -173,22 +173,26 @@ lazyGetToks dflags filename handle = do -- if this token reached the end of the buffer, and we haven't -- necessarily read up to the end of the file, then the token might -- be truncated, so read some more of the file and lex it again. - then getMore handle state + then getMore handle state size else case t of L _ ITeof -> return [t] - _other -> do rest <- lazyLexBuf handle state' eof + _other -> do rest <- lazyLexBuf handle state' eof size return (t : rest) - _ | not eof -> getMore handle state + _ | not eof -> getMore handle state size | otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof] -- parser assumes an ITeof sentinel at the end - getMore :: Handle -> PState -> IO [Located Token] - getMore handle state = do + getMore :: Handle -> PState -> Int -> IO [Located Token] + getMore handle state size = do -- pprTrace "getMore" (text (show (buffer state))) (return ()) - nextbuf <- hGetStringBufferBlock handle blockSize - if (len nextbuf == 0) then lazyLexBuf handle state True else do + let new_size = size * 2 + -- double the buffer size each time we read a new block. This + -- counteracts the quadratic slowdown we otherwise get for very + -- large module names (#5981) + nextbuf <- hGetStringBufferBlock handle new_size + if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do newbuf <- appendStringBuffers (buffer state) nextbuf - unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False + unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token] diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 8cc94a3ce8..a666220a6e 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -411,8 +411,8 @@ rethrow dflags io = Exception.catch io $ \se -> do withInterruptsSentTo :: ThreadId -> IO r -> IO r withInterruptsSentTo thread get_result = do - bracket (modifyMVar_ interruptTargetThread (return . (thread:))) - (\_ -> modifyMVar_ interruptTargetThread (\tl -> return $! tail tl)) + bracket (pushInterruptTargetThread thread) + (\_ -> popInterruptTargetThread) (\_ -> get_result) -- This function sets up the interpreter for catching breakpoints, and @@ -758,11 +758,16 @@ abandonAll = do -- with the partial computation, which still ends in takeMVar, -- so any attempt to evaluate one of these thunks will block -- unless we fill in the MVar. +-- (c) wait for the thread to terminate by taking its status MVar. This +-- step is necessary to prevent race conditions with +-- -fbreak-on-exception (see #5975). -- See test break010. abandon_ :: Resume -> IO () abandon_ r = do killThread (resumeThreadId r) putMVar (resumeBreakMVar r) () + _ <- takeMVar (resumeStatMVar r) + return () -- ----------------------------------------------------------------------------- -- Bounded list, optimised for repeated cons diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index c2f8674aa9..cfbd4bab58 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -80,7 +80,6 @@ module StaticFlags ( -- misc opts opt_IgnoreDotGhci, - opt_GhciScripts, opt_ErrorSpans, opt_GranMacros, opt_HiVersion, @@ -103,7 +102,7 @@ module StaticFlags ( import Config import FastString import Util -import Maybes ( firstJusts, catMaybes ) +import Maybes ( firstJusts ) import Panic import Control.Monad ( liftM3 ) @@ -133,7 +132,6 @@ lookUp :: FastString -> Bool lookup_def_int :: String -> Int -> Int lookup_def_float :: String -> Float -> Float lookup_str :: String -> Maybe String -lookup_all_str :: String -> [String] -- holds the static opts while they're being collected, before -- being unsafely read by unpacked_static_opts below. @@ -164,10 +162,6 @@ lookup_str sw Just str -> Just str Nothing -> Nothing -lookup_all_str sw = map f $ catMaybes (map (stripPrefix sw) staticFlags) where - f ('=' : str) = str - f str = str - lookup_def_int sw def = case (lookup_str sw) of Nothing -> def -- Use default Just xx -> try_read sw xx @@ -207,9 +201,6 @@ unpacked_opts = opt_IgnoreDotGhci :: Bool opt_IgnoreDotGhci = lookUp (fsLit "-ignore-dot-ghci") -opt_GhciScripts :: [String] -opt_GhciScripts = lookup_all_str "-ghci-script" - -- debugging options -- | Suppress all that is suppressable in core dumps. -- Except for uniques, as some simplifier phases introduce new varibles that diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 5fd0e9de76..dd842849e7 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -1053,6 +1053,9 @@ typedoc :: { LHsType RdrName } | btype '->' ctypedoc { LL $ HsFunTy $1 $3 } | btype docprev '->' ctypedoc { LL $ HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2)) $4 } | btype '~' btype { LL $ HsEqTy $1 $3 } + -- see Note [Promotion] + | btype SIMPLEQUOTE qconop type { LL $ mkHsOpTy $1 $3 $4 } + | btype SIMPLEQUOTE varop type { LL $ mkHsOpTy $1 $3 $4 } btype :: { LHsType RdrName } : btype atype { LL $ HsAppTy $1 $2 } diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 35806a1dc6..9b47edb169 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -276,8 +276,7 @@ basicKnownKeyNames -- Type-level naturals typeNatKindConName, typeStringKindConName, - typeNatClassName, - typeStringClassName, + singIClassName, typeNatLeqClassName, typeNatAddTyFamName, typeNatMulTyFamName, @@ -1052,14 +1051,12 @@ isStringClassName = clsQual dATA_STRING (fsLit "IsString") isStringClassKey -- Type-level naturals typeNatKindConName, typeStringKindConName, - typeNatClassName, typeStringClassName, typeNatLeqClassName, + singIClassName, typeNatLeqClassName, typeNatAddTyFamName, typeNatMulTyFamName, typeNatExpTyFamName :: Name typeNatKindConName = tcQual gHC_TYPELITS (fsLit "Nat") typeNatKindConNameKey typeStringKindConName = tcQual gHC_TYPELITS (fsLit "Symbol") typeStringKindConNameKey -typeNatClassName = clsQual gHC_TYPELITS (fsLit "NatI") typeNatClassNameKey -typeStringClassName = clsQual gHC_TYPELITS (fsLit "SymbolI") - typeStringClassNameKey +singIClassName = clsQual gHC_TYPELITS (fsLit "SingI") singIClassNameKey typeNatLeqClassName = clsQual gHC_TYPELITS (fsLit "<=") typeNatLeqClassNameKey typeNatAddTyFamName = tcQual gHC_TYPELITS (fsLit "+") typeNatAddTyFamNameKey typeNatMulTyFamName = tcQual gHC_TYPELITS (fsLit "*") typeNatMulTyFamNameKey @@ -1179,10 +1176,9 @@ datatypeClassKey = mkPreludeClassUnique 39 constructorClassKey = mkPreludeClassUnique 40 selectorClassKey = mkPreludeClassUnique 41 -typeNatClassNameKey, typeStringClassNameKey, typeNatLeqClassNameKey :: Unique -typeNatClassNameKey = mkPreludeClassUnique 42 -typeStringClassNameKey = mkPreludeClassUnique 43 -typeNatLeqClassNameKey = mkPreludeClassUnique 44 +singIClassNameKey, typeNatLeqClassNameKey :: Unique +singIClassNameKey = mkPreludeClassUnique 42 +typeNatLeqClassNameKey = mkPreludeClassUnique 43 \end{code} %************************************************************************ diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index b24f76ce40..eb642b5f63 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -8,13 +8,13 @@ module TcCanonical( canonicalize, flatten, flattenMany, + FlattenMode (..), StopOrContinue (..) ) where #include "HsVersions.h" import BasicTypes ( IPName ) -import TcErrors import TcRnTypes import TcType import Type @@ -26,7 +26,6 @@ import TypeRep import Name ( Name ) import Var import VarEnv --- import Util( equalLength ) import Outputable import Control.Monad ( when, unless ) import MonadUtils @@ -37,6 +36,9 @@ import VarSet import TcSMonad import FastString +import Util ( equalLength ) + + import TysWiredIn ( eqTyCon ) import Data.Maybe ( isJust, fromMaybe ) @@ -258,7 +260,7 @@ canIP d fl nm ty = -- Note [Canonical implicit parameter constraints] explains why it's -- possible in principle to not flatten, but since flattening applies -- the inert substitution we choose to flatten anyway. - do { (xi,co) <- flatten d fl (mkIPPred nm ty) + do { (xi,co) <- flatten d FMFullFlatten fl (mkIPPred nm ty) ; mb <- rewriteCtFlavor fl xi co ; case mb of Just new_fl -> let IPPred _ xi_in = classifyPredType xi @@ -304,7 +306,7 @@ canClassNC d fl cls tys canClass d fl cls tys = do { -- sctx <- getTcSContext - ; (xis, cos) <- flattenMany d fl tys + ; (xis, cos) <- flattenMany d FMFullFlatten fl tys ; let co = mkTcTyConAppCo (classTyCon cls) cos xi = mkClassPred cls xis @@ -458,7 +460,7 @@ canIrred :: SubGoalDepth -- Depth -- Precondition: ty not a tuple and no other evidence form canIrred d fl ty = do { traceTcS "can_pred" (text "IrredPred = " <+> ppr ty) - ; (xi,co) <- flatten d fl ty -- co :: xi ~ ty + ; (xi,co) <- flatten d FMFullFlatten fl ty -- co :: xi ~ ty ; let no_flattening = xi `eqType` ty -- In this particular case it is not safe to -- say 'isTcReflCo' because the new constraint may @@ -485,7 +487,8 @@ Note [Flattening] ~~~~~~~~~~~~~~~~~~~~ flatten ty ==> (xi, cc) where - xi has no type functions + xi has no type functions, unless they appear under ForAlls + cc = Auxiliary given (equality) constraints constraining the fresh type variables in xi. Evidence for these is always the identity coercion, because internally the @@ -522,17 +525,21 @@ unexpanded synonym. \begin{code} +data FlattenMode = FMSubstOnly + | FMFullFlatten + -- Flatten a bunch of types all at once. flattenMany :: SubGoalDepth -- Depth + -> FlattenMode -> CtFlavor -> [Type] -> TcS ([Xi], [TcCoercion]) -- Coercions :: Xi ~ Type -- Returns True iff (no flattening happened) -- NB: The EvVar inside the flavor is unused, we merely want Given/Solved/Derived/Wanted info -flattenMany d ctxt tys +flattenMany d f ctxt tys = -- pprTrace "flattenMany" empty $ go tys where go [] = return ([],[]) - go (ty:tys) = do { (xi,co) <- flatten d ctxt ty + go (ty:tys) = do { (xi,co) <- flatten d f ctxt ty ; (xis,cos) <- go tys ; return (xi:xis,co:cos) } @@ -540,33 +547,34 @@ flattenMany d ctxt tys -- the new type-function-free type, and a collection of new equality -- constraints. See Note [Flattening] for more detail. flatten :: SubGoalDepth -- Depth + -> FlattenMode -> CtFlavor -> TcType -> TcS (Xi, TcCoercion) -- Postcondition: Coercion :: Xi ~ TcType -flatten d ctxt ty +flatten d f ctxt ty | Just ty' <- tcView ty - = do { (xi, co) <- flatten d ctxt ty' + = do { (xi, co) <- flatten d f ctxt ty' ; return (xi,co) } -flatten _ _ xi@(LitTy {}) = return (xi, mkTcReflCo xi) +flatten _ _ _ xi@(LitTy {}) = return (xi, mkTcReflCo xi) -flatten d ctxt (TyVarTy tv) - = flattenTyVar d ctxt tv +flatten d f ctxt (TyVarTy tv) + = flattenTyVar d f ctxt tv -flatten d ctxt (AppTy ty1 ty2) - = do { (xi1,co1) <- flatten d ctxt ty1 - ; (xi2,co2) <- flatten d ctxt ty2 +flatten d f ctxt (AppTy ty1 ty2) + = do { (xi1,co1) <- flatten d f ctxt ty1 + ; (xi2,co2) <- flatten d f ctxt ty2 ; return (mkAppTy xi1 xi2, mkTcAppCo co1 co2) } -flatten d ctxt (FunTy ty1 ty2) - = do { (xi1,co1) <- flatten d ctxt ty1 - ; (xi2,co2) <- flatten d ctxt ty2 +flatten d f ctxt (FunTy ty1 ty2) + = do { (xi1,co1) <- flatten d f ctxt ty1 + ; (xi2,co2) <- flatten d f ctxt ty2 ; return (mkFunTy xi1 xi2, mkTcFunCo co1 co2) } -flatten d fl (TyConApp tc tys) +flatten d f fl (TyConApp tc tys) -- For a normal type constructor or data family application, we just -- recursively flatten the arguments. | not (isSynFamilyTyCon tc) - = do { (xis,cos) <- flattenMany d fl tys + = do { (xis,cos) <- flattenMany d f fl tys ; return (mkTyConApp tc xis, mkTcTyConAppCo tc cos) } -- Otherwise, it's a type function application, and we have to @@ -574,7 +582,7 @@ flatten d fl (TyConApp tc tys) -- between the application and a newly generated flattening skolem variable. | otherwise = ASSERT( tyConArity tc <= length tys ) -- Type functions are saturated - do { (xis, cos) <- flattenMany d fl tys + do { (xis, cos) <- flattenMany d f fl tys ; let (xi_args, xi_rest) = splitAt (tyConArity tc) xis -- The type function might be *over* saturated -- in which case the remaining arguments should @@ -582,30 +590,34 @@ flatten d fl (TyConApp tc tys) fam_ty = mkTyConApp tc xi_args ; (ret_co, rhs_xi, ct) <- - do { flat_cache <- getFlatCache - ; case lookupTM fam_ty flat_cache of - Just ct - | cc_flavor ct `canRewrite` fl - -> -- You may think that we can just return (cc_rhs ct) but not so. - -- return (mkTcCoVarCo (ctId ct), cc_rhs ct, []) - -- The cached constraint resides in the cache so we have to flatten - -- the rhs to make sure we have applied any inert substitution to it. - -- Alternatively we could be applying the inert substitution to the - -- cache as well when we interact an equality with the inert. - -- The design choice is: do we keep the flat cache rewritten or not? - -- For now I say we don't keep it fully rewritten. - do { traceTcS "flatten/flat-cache hit" $ ppr ct - ; let rhs_xi = cc_rhs ct - ; (flat_rhs_xi,co) <- flatten (cc_depth ct) (cc_flavor ct) rhs_xi - ; let final_co = mkTcCoVarCo (ctId ct) `mkTcTransCo` (mkTcSymCo co) - ; return (final_co, flat_rhs_xi,[]) } + case f of + FMSubstOnly -> + return (mkTcReflCo fam_ty, fam_ty, []) + FMFullFlatten -> + do { flat_cache <- getFlatCache + ; case lookupTM fam_ty flat_cache of + Just ct + | cc_flavor ct `canRewrite` fl + -> -- You may think that we can just return (cc_rhs ct) but not so. + -- return (mkTcCoVarCo (ctId ct), cc_rhs ct, []) + -- The cached constraint resides in the cache so we have to flatten + -- the rhs to make sure we have applied any inert substitution to it. + -- Alternatively we could be applying the inert substitution to the + -- cache as well when we interact an equality with the inert. + -- The design choice is: do we keep the flat cache rewritten or not? + -- For now I say we don't keep it fully rewritten. + do { traceTcS "flatten/flat-cache hit" $ ppr ct + ; let rhs_xi = cc_rhs ct + ; (flat_rhs_xi,co) <- flatten (cc_depth ct) f (cc_flavor ct) rhs_xi + ; let final_co = mkTcCoVarCo (ctId ct) `mkTcTransCo` (mkTcSymCo co) + ; return (final_co, flat_rhs_xi,[]) } - _ | isGivenOrSolved fl -- Given or Solved: make new flatten skolem - -> do { traceTcS "flatten/flat-cache miss" $ empty - ; rhs_xi_var <- newFlattenSkolemTy fam_ty - ; mg <- newGivenEvVar (mkTcEqPred fam_ty rhs_xi_var) - (EvCoercion (mkTcReflCo fam_ty)) - ; case mg of + _ | isGivenOrSolved fl -- Given or Solved: make new flatten skolem + -> do { traceTcS "flatten/flat-cache miss" $ empty + ; rhs_xi_var <- newFlattenSkolemTy fam_ty + ; mg <- newGivenEvVar (mkTcEqPred fam_ty rhs_xi_var) + (EvCoercion (mkTcReflCo fam_ty)) + ; case mg of Fresh eqv -> do { let new_fl = Given (flav_gloc fl) eqv ct = CFunEqCan { cc_flavor = new_fl @@ -617,11 +629,11 @@ flatten d fl (TyConApp tc tys) ; updFlatCache ct ; return (mkTcCoVarCo eqv, rhs_xi_var, [ct]) } Cached {} -> panic "flatten TyConApp, var must be fresh!" } - | otherwise -- Wanted or Derived: make new unification variable - -> do { traceTcS "flatten/flat-cache miss" $ empty - ; rhs_xi_var <- newFlexiTcSTy (typeKind fam_ty) - ; mw <- newWantedEvVar (mkTcEqPred fam_ty rhs_xi_var) - ; case mw of + | otherwise -- Wanted or Derived: make new unification variable + -> do { traceTcS "flatten/flat-cache miss" $ empty + ; rhs_xi_var <- newFlexiTcSTy (typeKind fam_ty) + ; mw <- newWantedEvVar (mkTcEqPred fam_ty rhs_xi_var) + ; case mw of Fresh eqv -> do { let new_fl = Wanted (flav_wloc fl) eqv ct = CFunEqCan { cc_flavor = new_fl @@ -633,7 +645,7 @@ flatten d fl (TyConApp tc tys) ; updFlatCache ct ; return (mkTcCoVarCo eqv, rhs_xi_var, [ct]) } Cached {} -> panic "flatten TyConApp, var must be fresh!" } - } + } -- Emit the flat constraints ; updWorkListTcS $ appendWorkListEqs ct ; let (cos_args, cos_rest) = splitAt (tyConArity tc) cos @@ -644,12 +656,16 @@ flatten d fl (TyConApp tc tys) ) } -flatten d ctxt ty@(ForAllTy {}) +flatten d _f ctxt ty@(ForAllTy {}) -- We allow for-alls when, but only when, no type function -- applications inside the forall involve the bound type variables. = do { let (tvs, rho) = splitForAllTys ty + ; (rho', co) <- flatten d FMSubstOnly ctxt rho + ; return (mkForAllTys tvs rho', foldr mkTcForAllCo co tvs) } + {- DELETEME ; when (under_families tvs rho) $ wrapErrTcS $ flattenForAllErrorTcS ctxt ty - ; (rho', co) <- flatten d ctxt rho + ; (rho', co) <- flatten d FMSubstOnly ctxt rho + -- Only do substitutions, not flattening under ForAlls ; return (mkForAllTys tvs rho', foldr mkTcForAllCo co tvs) } -- DV: Simon and I have a better plan here related to #T5934 and that plan is to @@ -670,18 +686,22 @@ flatten d ctxt ty@(ForAllTy {}) go bound (FunTy arg res) = go bound arg || go bound res go bound (AppTy fun arg) = go bound fun || go bound arg go bound (ForAllTy tv ty) = go (bound `extendVarSet` tv) ty +-} + \end{code} \begin{code} -flattenTyVar :: SubGoalDepth -> CtFlavor -> TcTyVar -> TcS (Xi, TcCoercion) +flattenTyVar :: SubGoalDepth + -> FlattenMode + -> CtFlavor -> TcTyVar -> TcS (Xi, TcCoercion) -- "Flattening" a type variable means to apply the substitution to it -flattenTyVar d ctxt tv +flattenTyVar d f ctxt tv = do { ieqs <- getInertEqs ; let mco = tv_eq_subst (fst ieqs) tv -- co : v ~ ty ; case mco of -- Done, but make sure the kind is zonked Nothing -> do { let knd = tyVarKind tv - ; (new_knd,_kind_co) <- flatten d ctxt knd + ; (new_knd,_kind_co) <- flatten d f ctxt knd ; let ty = mkTyVarTy (setVarType tv new_knd) ; return (ty, mkTcReflCo ty) } -- NB recursive call. @@ -689,7 +709,7 @@ flattenTyVar d ctxt tv -- In fact, because of flavors, it couldn't possibly be idempotent, -- this is explained in Note [Non-idempotent inert substitution] Just (co,ty) -> - do { (ty_final,co') <- flatten d ctxt ty + do { (ty_final,co') <- flatten d f ctxt ty ; return (ty_final, co' `mkTcTransCo` mkTcSymCo co) } } where tv_eq_subst subst tv | Just ct <- lookupVarEnv subst tv @@ -820,13 +840,20 @@ canEq d fl ty1 ty2 -- e.g. F a b ~ Maybe c = canEqAppTy d fl s1 t1 s2 t2 canEq d fl s1@(ForAllTy {}) s2@(ForAllTy {}) - | tcIsForAllTy s1, tcIsForAllTy s2, - Wanted {} <- fl - = canEqFailure d fl + | tcIsForAllTy s1, tcIsForAllTy s2 + , Wanted loc orig_ev <- fl + = do { let (tvs1,body1) = tcSplitForAllTys s1 + (tvs2,body2) = tcSplitForAllTys s2 + ; if not (equalLength tvs1 tvs2) then + canEqFailure d fl + else + do { traceTcS "Creating implication for polytype equality" $ ppr fl + ; deferTcSForAllEq (loc,orig_ev) (tvs1,body1) (tvs2,body2) + ; return Stop } } | otherwise - = do { traceTcS "Ommitting decomposition of given polytype equality" (pprEq s1 s2) + = do { traceTcS "Ommitting decomposition of given polytype equality" $ + pprEq s1 s2 ; return Stop } - canEq d fl _ _ = canEqFailure d fl ------------------------ @@ -1168,8 +1195,8 @@ canEqLeafFunEqLeftRec d fl (fn,tys1) ty2 -- fl :: F tys1 ~ ty2 = do { traceTcS "canEqLeafFunEqLeftRec" $ pprEq (mkTyConApp fn tys1) ty2 ; (xis1,cos1) <- {-# SCC "flattenMany" #-} - flattenMany d fl tys1 -- Flatten type function arguments - -- cos1 :: xis1 ~ tys1 + flattenMany d FMFullFlatten fl tys1 -- Flatten type function arguments + -- cos1 :: xis1 ~ tys1 ; let fam_head = mkTyConApp fn xis1 -- Fancy higher-dimensional coercion between equalities! @@ -1194,7 +1221,7 @@ canEqLeafFunEqLeft d fl (fn,xis1) s2 do { traceTcS "canEqLeafFunEqLeft" $ pprEq (mkTyConApp fn xis1) s2 ; (xi2,co2) <- {-# SCC "flatten" #-} - flatten d fl s2 -- co2 :: xi2 ~ s2 + flatten d FMFullFlatten fl s2 -- co2 :: xi2 ~ s2 ; let fam_head = mkTyConApp fn xis1 -- Fancy coercion between equalities! But it should just work! @@ -1216,7 +1243,7 @@ canEqLeafTyVarLeftRec :: SubGoalDepth -> TcTyVar -> TcType -> TcS StopOrContinue canEqLeafTyVarLeftRec d fl tv s2 -- fl :: tv ~ s2 = do { traceTcS "canEqLeafTyVarLeftRec" $ pprEq (mkTyVarTy tv) s2 - ; (xi1,co1) <- flattenTyVar d fl tv -- co1 :: xi1 ~ tv + ; (xi1,co1) <- flattenTyVar d FMFullFlatten fl tv -- co1 :: xi1 ~ tv ; let is_still_var = isJust (getTyVar_maybe xi1) ; traceTcS "canEqLeafTyVarLeftRec2" $ empty @@ -1243,8 +1270,8 @@ canEqLeafTyVarLeft :: SubGoalDepth -- Depth canEqLeafTyVarLeft d fl tv s2 -- eqv : tv ~ s2 = do { let tv_ty = mkTyVarTy tv ; traceTcS "canEqLeafTyVarLeft" (pprEq tv_ty s2) - ; (xi2, co2) <- flatten d fl s2 -- Flatten RHS co : xi2 ~ s2 - + ; (xi2, co2) <- flatten d FMFullFlatten fl s2 -- Flatten RHS co:xi2 ~ s2 + ; traceTcS "canEqLeafTyVarLeft" (nest 2 (vcat [ text "tv =" <+> ppr tv , text "s2 =" <+> ppr s2 , text "xi2 =" <+> ppr xi2])) diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs index 571643c9f8..8ec0a5766b 100644 --- a/compiler/typecheck/TcEvidence.lhs +++ b/compiler/typecheck/TcEvidence.lhs @@ -473,7 +473,7 @@ data EvTerm | EvKindCast EvVar TcCoercion -- See Note [EvKindCast] - | EvLit EvLit -- The dictionary for class "NatI" + | EvLit EvLit -- Dictionary for class "SingI" for type lits. -- Note [EvLit] deriving( Data.Data, Data.Typeable) @@ -519,33 +519,39 @@ Conclusion: a new wanted coercion variable should be made mutable. Note [EvLit] ~~~~~~~~~~~~ -A part of the type-level naturals implementation is the class "NatI", +A part of the type-level literals implementation is the class "SingI", which provides a "smart" constructor for defining singleton values. -newtype TNat (n :: Nat) = TNat Integer +newtype Sing n = Sing (SingRep n) -class NatI n where - tNat :: TNat n +class SingI n where + sing :: Sing n + +type family SingRep a +type instance SingRep (a :: Nat) = Integer +type instance SingRep (a :: Symbol) = String Conceptually, this class has infinitely many instances: -instance NatI 0 where natS = TNat 0 -instance NatI 1 where natS = TNat 1 -instance NatI 2 where natS = TNat 2 +instance Sing 0 where sing = Sing 0 +instance Sing 1 where sing = Sing 1 +instance Sing 2 where sing = Sing 2 +instance Sing "hello" where sing = Sing "hello" ... -In practice, we solve "NatI" predicates in the type-checker because we can't +In practice, we solve "SingI" predicates in the type-checker because we can't have infinately many instances. The evidence (aka "dictionary") -for "NatI n" is of the form "EvLit (EvNum n)". +for "SingI (n :: Nat)" is of the form "EvLit (EvNum n)". We make the following assumptions about dictionaries in GHC: - 1. The "dictionary" for classes with a single method---like NatI---is + 1. The "dictionary" for classes with a single method---like SingI---is a newtype for the type of the method, so using a evidence amounts to a coercion, and 2. Newtypes use the same representation as their definition types. -So, the evidence for "NatI" is just an integer wrapped in 2 newtypes: -one to make it into a "TNat" value, and another to make it into "NatI" evidence. +So, the evidence for "SingI" is just a value of the representation type, +wrapped in two newtype constructors: one to make it into a "Sing" value, +and another to make it into "SingI" evidence. \begin{code} diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 64b839c83f..b7c953d2f7 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -836,7 +836,7 @@ mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id ; inst_sigs <- xoptM Opt_InstanceSigs ; if inst_sigs then checkTc (sig_ty `eqType` local_meth_ty) - (badInstSigErr sel_name sig_ty) + (badInstSigErr sel_name local_meth_ty) else addErrTc (misplacedInstSig sel_name hs_ty) ; return sig_ty } diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 01dcda803a..a2e0b993ed 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -26,7 +26,7 @@ import Id import Var import TcType -import PrelNames (typeNatClassName, typeStringClassName) +import PrelNames (singIClassName) import Class import TyCon @@ -91,12 +91,21 @@ If in Step 1 no such element exists, we have exceeded our context-stack depth and will simply fail. \begin{code} -solveInteractCts :: [Ct] -> TcS () +solveInteractCts :: [Ct] -> TcS (Bag Implication) +-- Returns a bag of residual implications that have arisen while solving +-- this particular worklist. solveInteractCts cts = do { traceTcS "solveInteractCtS" (vcat [ text "cts =" <+> ppr cts ]) - ; updWorkListTcS (appendWorkListCt cts) >> solveInteract } - -solveInteractGiven :: GivenLoc -> [EvVar] -> TcS () + ; updWorkListTcS (appendWorkListCt cts) >> solveInteract + ; impls <- getTcSImplics + ; updTcSImplics (const emptyBag) -- Nullify residual implications + ; return impls } + +solveInteractGiven :: GivenLoc -> [EvVar] -> TcS (Bag Implication) +-- In principle the givens can kick out some wanteds from the inert +-- resulting in solving some more wanted goals here which could emit +-- implications. That's why I return a bag of implications. Not sure +-- if this can happen in practice though. solveInteractGiven gloc evs = solveInteractCts (map mk_noncan evs) where mk_noncan ev = CNonCanonical { cc_flavor = Given gloc ev @@ -1614,9 +1623,9 @@ lkpFunEqCache fam_head , cc_fun = tc, cc_tyargs = xis , cc_rhs = xi})) = ASSERT (isSolved fl) - do { (xis_subst,cos) <- flattenMany d fl xis + do { (xis_subst,cos) <- flattenMany d FMFullFlatten fl xis -- cos :: xis_subst ~ xis - ; (xi_subst,co) <- flatten d fl xi + ; (xi_subst,co) <- flatten d FMFullFlatten fl xi -- co :: xi_subst ~ xi ; let flat_fam_head = mkTyConApp tc xis_subst @@ -1865,11 +1874,11 @@ data LookupInstResult matchClassInst :: InertSet -> Class -> [Type] -> WantedLoc -> TcS LookupInstResult -matchClassInst _ clas [ ty ] _ - | className clas == typeNatClassName +matchClassInst _ clas [ _, ty ] _ + | className clas == singIClassName , Just n <- isNumLitTy ty = return $ GenInst [] $ EvLit $ EvNum n - | className clas == typeStringClassName + | className clas == singIClassName , Just s <- isStrLitTy ty = return $ GenInst [] $ EvLit $ EvStr s diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index f480bab3fa..6a79b738fd 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -831,10 +831,15 @@ instance Outputable WhereFrom where \begin{code} --- Types without any type functions inside. However, note that xi --- types CAN contain unexpanded type synonyms; however, the --- (transitive) expansions of those type synonyms will not contain any --- type functions. +-- The syntax of xi types: +-- xi ::= a | T xis | xis -> xis | ... | forall a. tau +-- Two important notes: +-- (i) No type families, unless we are under a ForAll +-- (ii) Note that xi types can contain unexpanded type synonyms; +-- however, the (transitive) expansions of those type synonyms +-- will not contain any type functions, unless we are under a ForAll. +-- We enforce the structure of Xi types when we flatten (TcCanonical) + type Xi = Type -- In many comments, "xi" ranges over Xi type Cts = Bag Ct diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 33a049e9b0..b3a64e3b14 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -18,6 +18,8 @@ module TcSMonad ( getTcSWorkList, updWorkListTcS, updWorkListTcS_return, keepWanted, getTcSWorkListTvs, + + getTcSImplics, updTcSImplics, emitTcSImplication, Ct(..), Xi, tyVarsOfCt, tyVarsOfCts, tyVarsOfCDicts, emitFrozenError, @@ -42,6 +44,7 @@ module TcSMonad ( -- Getting and setting the flattening cache getFlatCache, updFlatCache, addToSolved, + deferTcSForAllEq, setEvBind, XEvTerm(..), @@ -136,6 +139,7 @@ import Unique import UniqFM import Maybes ( orElse ) + import Control.Monad( when ) import StaticFlags( opt_PprStyle_Debug ) import Data.IORef @@ -783,8 +787,11 @@ data TcSEnv tcs_count :: IORef Int, -- Global step count tcs_inerts :: IORef InertSet, -- Current inert set - tcs_worklist :: IORef WorkList -- Current worklist - + tcs_worklist :: IORef WorkList, -- Current worklist + + -- Residual implication constraints that are generated + -- while solving the current worklist. + tcs_implics :: IORef (Bag Implication) } type TcsUntouchables = (Untouchables,TcTyVarSet) @@ -884,6 +891,7 @@ runTcS :: SimplContext runTcS context untouch is wl tcs = do { ty_binds_var <- TcM.newTcRef emptyVarEnv ; ev_binds_var <- TcM.newTcEvBinds + ; impl_var <- TcM.newTcRef emptyBag ; step_count <- TcM.newTcRef 0 ; inert_var <- TcM.newTcRef is @@ -896,7 +904,8 @@ runTcS context untouch is wl tcs , tcs_count = step_count , tcs_ic_depth = 0 , tcs_inerts = inert_var - , tcs_worklist = wl_var } + , tcs_worklist = wl_var + , tcs_implics = impl_var } -- Run the computation ; res <- unTcS tcs env @@ -930,7 +939,8 @@ nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside) , tcs_ic_depth = idepth , tcs_context = ctxt , tcs_inerts = inert_var - , tcs_worklist = wl_var } -> + , tcs_worklist = wl_var + , tcs_implics = _impl_var } -> do { let inner_untch = (inner_range, outer_tcs `unionVarSet` inner_tcs) -- The inner_range should be narrower than the outer one -- (thus increasing the set of untouchables) but @@ -940,6 +950,10 @@ nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside) -- Inherit the inerts from the outer scope ; orig_inerts <- TcM.readTcRef inert_var ; new_inert_var <- TcM.newTcRef orig_inerts + -- Inherit residual implications from outer scope (?) or create + -- fresh var? +-- ; orig_implics <- TcM.readTcRef impl_var + ; new_implics_var <- TcM.newTcRef emptyBag ; let nest_env = TcSEnv { tcs_ev_binds = ref , tcs_ty_binds = ty_binds @@ -951,6 +965,7 @@ nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside) , tcs_worklist = wl_var -- NB: worklist is going to be empty anyway, -- so reuse the same ref cell + , tcs_implics = new_implics_var } ; thing_inside nest_env } @@ -996,6 +1011,13 @@ getTcSWorkListRef = TcS (return . tcs_worklist) getTcSInerts :: TcS InertSet getTcSInerts = getTcSInertsRef >>= wrapTcS . (TcM.readTcRef) + +getTcSImplicsRef :: TcS (IORef (Bag Implication)) +getTcSImplicsRef = TcS (return . tcs_implics) + +getTcSImplics :: TcS (Bag Implication) +getTcSImplics = getTcSImplicsRef >>= wrapTcS . (TcM.readTcRef) + getTcSWorkList :: TcS WorkList getTcSWorkList = getTcSWorkListRef >>= wrapTcS . (TcM.readTcRef) @@ -1020,6 +1042,18 @@ updWorkListTcS_return f ; let (res,new_work) = f wl_curr ; wrapTcS (TcM.writeTcRef wl_var new_work) ; return res } + + +updTcSImplics :: (Bag Implication -> Bag Implication) -> TcS () +updTcSImplics f + = do { impl_ref <- getTcSImplicsRef + ; implics <- wrapTcS (TcM.readTcRef impl_ref) + ; let new_implics = f implics + ; wrapTcS (TcM.writeTcRef impl_ref new_implics) } + +emitTcSImplication :: Implication -> TcS () +emitTcSImplication imp = updTcSImplics (consBag imp) + emitFrozenError :: CtFlavor -> SubGoalDepth -> TcS () -- Emits a non-canonical constraint that will stand for a frozen error in the inerts. @@ -1486,6 +1520,54 @@ matchFam :: TyCon -> [Type] -> TcS (Maybe (FamInst, [Type])) matchFam tycon args = wrapTcS $ tcLookupFamInst tycon args \end{code} +\begin{code} +-- Deferring forall equalities as implications +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +deferTcSForAllEq :: (WantedLoc,EvVar) -- Original wanted equality flavor + -> ([TyVar],TcType) -- ForAll tvs1 body1 + -> ([TyVar],TcType) -- ForAll tvs2 body2 + -> TcS () +-- Some of this functionality is repeated from TcUnify, +-- consider having a single place where we create fresh implications. +deferTcSForAllEq (loc,orig_ev) (tvs1,body1) (tvs2,body2) + = do { (subst1, skol_tvs) <- wrapTcS $ TcM.tcInstSkolTyVars tvs1 + ; let tys = mkTyVarTys skol_tvs + phi1 = Type.substTy subst1 body1 + phi2 = Type.substTy (zipTopTvSubst tvs2 tys) body2 + skol_info = UnifyForAllSkol skol_tvs phi1 + ; mev <- newWantedEvVar (mkTcEqPred phi1 phi2) + ; let new_fl = Wanted loc (mn_thing mev) + new_ct = mkNonCanonical new_fl + new_co = mkTcCoVarCo (mn_thing mev) + ; coe_inside <- if isFresh mev then + do { ev_binds_var <- wrapTcS $ TcM.newTcEvBinds + ; let ev_binds = TcEvBinds ev_binds_var + ; lcl_env <- wrapTcS $ TcM.getLclTypeEnv + ; loc <- wrapTcS $ TcM.getCtLoc skol_info + ; let wc = WC { wc_flat = singleCt new_ct + , wc_impl = emptyBag + , wc_insol = emptyCts } + imp = Implic { ic_untch = all_untouchables + , ic_env = lcl_env + , ic_skols = skol_tvs + , ic_given = [] + , ic_wanted = wc + , ic_insol = False + , ic_binds = ev_binds_var + , ic_loc = loc } + ; updTcSImplics (consBag imp) + ; return (TcLetCo ev_binds new_co) } + else (return new_co) + ; setEvBind orig_ev $ + EvCoercion (foldr mkTcForAllCo coe_inside skol_tvs) + } + where all_untouchables = TouchableRange u u + u = idUnique orig_ev -- HACK: empty range + +\end{code} + + -- Rewriting with respect to the inert equalities -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 3c3c7f7299..26d4c9f124 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -384,8 +384,9 @@ simplifyWithApprox wanted = do { traceTcS "simplifyApproxLoop" (ppr wanted) ; let all_flats = wc_flat wanted `unionBags` keepWanted (wc_insol wanted) - ; solveInteractCts $ bagToList all_flats - ; unsolved_implics <- simpl_loop 1 (wc_impl wanted) + ; implics_from_flats <- solveInteractCts $ bagToList all_flats + ; unsolved_implics <- simpl_loop 1 (wc_impl wanted `unionBags` + implics_from_flats) ; let (residual_implics,floats) = approximateImplications unsolved_implics @@ -777,11 +778,11 @@ solve_wanteds wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol = insols -- wrong anyway! ; let all_flats = flats `unionBags` keepWanted insols - ; solveInteractCts $ bagToList all_flats + ; impls_from_flats <- solveInteractCts $ bagToList all_flats -- solve_wanteds iterates when it is able to float equalities -- out of one or more of the implications. - ; unsolved_implics <- simpl_loop 1 implics + ; unsolved_implics <- simpl_loop 1 (implics `unionBags` impls_from_flats) ; (insoluble_flats,unsolved_flats) <- extractUnsolvedTcS @@ -832,8 +833,9 @@ simpl_loop n implics , text "unsolved_implics =" <+> ppr unsolved_implics ] ; if isEmptyBag improve_eqs then return unsolved_implics - else do { solveInteractCts $ bagToList improve_eqs - ; simpl_loop (n+1) unsolved_implics } } + else do { impls_from_eqs <- solveInteractCts $ bagToList improve_eqs + ; simpl_loop (n+1) (unsolved_implics `unionBags` + impls_from_eqs)} } solveNestedImplications :: Bag Implication -> TcS (Cts, Bag Implication) @@ -855,7 +857,9 @@ solveNestedImplications implics -- Push the unsolved wanteds inwards, but as givens ; traceTcS "solveWanteds: preparing inerts for implications {" $ vcat [ppr tcs_untouchables, ppr pushed_givens] - ; solveInteractCts pushed_givens + ; impls_from_givens <- solveInteractCts pushed_givens + ; MASSERT (isEmptyBag impls_from_givens) + ; traceTcS "solveWanteds: } now doing nested implications {" empty ; flatMapBagPairM (solveImplication tcs_untouchables) implics } @@ -904,8 +908,9 @@ solveImplication tcs_untouchables do { traceTcS "solveImplication {" (ppr imp) -- Solve flat givens - ; solveInteractGiven loc givens - + ; impls_from_givens <- solveInteractGiven loc givens + ; MASSERT (isEmptyBag impls_from_givens) + -- Simplify the wanteds ; WC { wc_flat = unsolved_flats , wc_impl = unsolved_implics @@ -1395,8 +1400,13 @@ disambigGroup (default_ty:default_tys) group in return [ CNonCanonical { cc_flavor = dfl, cc_depth = 0 } ] } ; traceTcS "disambigGroup (solving) {" - (text "trying to solve constraints along with default equations ...") - ; solveInteractCts (derived_eq ++ wanteds) + (text "trying to solve constraints along with default equations ...") + ; implics_from_defaulting <- + solveInteractCts (derived_eq ++ wanteds) + ; MASSERT (isEmptyBag implics_from_defaulting) + -- Ignore implics: I don't think that a defaulting equation can cause + -- new implications to be emitted. Maybe we have to revisit this. + ; (_,unsolved) <- extractUnsolvedTcS ; traceTcS "disambigGroup (solving) }" (text "disambigGroup unsolved =" <+> ppr (keepWanted unsolved)) diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs index 0fb206ca77..faaa62898e 100644 --- a/compiler/utils/Panic.lhs +++ b/compiler/utils/Panic.lhs @@ -24,15 +24,15 @@ module Panic ( Exception.Exception(..), showException, safeShowException, try, tryMost, throwTo, - installSignalHandlers, interruptTargetThread + installSignalHandlers, + pushInterruptTargetThread, popInterruptTargetThread ) where #include "HsVersions.h" import Config import FastTypes import Exception -import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar, modifyMVar_, - myThreadId ) +import Control.Concurrent import Data.Dynamic import Debug.Trace ( trace ) import System.IO.Unsafe @@ -51,7 +51,11 @@ import GHC.ConsoleHandler import GHC.Stack #endif --- | GHC's own exception type +#if __GLASGOW_HASKELL__ >= 705 +import System.Mem.Weak ( Weak, deRefWeak ) +#endif + +-- | GHC's own exception type -- error messages all take the form: -- -- @ @@ -233,16 +237,16 @@ tryMost action = do r <- try action installSignalHandlers :: IO () installSignalHandlers = do main_thread <- myThreadId - modifyMVar_ interruptTargetThread (return . (main_thread :)) + pushInterruptTargetThread main_thread let interrupt_exn = (toException UserInterrupt) interrupt = do - withMVar interruptTargetThread $ \targets -> - case targets of - [] -> return () - (thread:_) -> throwTo thread interrupt_exn + mt <- popInterruptTargetThread + case mt of + Nothing -> return () + Just t -> throwTo t interrupt_exn -- #if !defined(mingw32_HOST_OS) @@ -268,8 +272,41 @@ installSignalHandlers = do return () #endif +#if __GLASGOW_HASKELL__ >= 705 +{-# NOINLINE interruptTargetThread #-} +interruptTargetThread :: MVar [Weak ThreadId] +interruptTargetThread = unsafePerformIO (newMVar []) + +pushInterruptTargetThread :: ThreadId -> IO () +pushInterruptTargetThread tid = do + wtid <- mkWeakThreadId tid + modifyMVar_ interruptTargetThread $ + return . (wtid :) + +popInterruptTargetThread :: IO (Maybe ThreadId) +popInterruptTargetThread = + modifyMVar interruptTargetThread $ loop + where + loop [] = return ([], Nothing) + loop (t:ts) = do + r <- deRefWeak t + case r of + Nothing -> loop ts + Just t -> return (ts, Just t) +#else {-# NOINLINE interruptTargetThread #-} interruptTargetThread :: MVar [ThreadId] interruptTargetThread = unsafePerformIO (newMVar []) +pushInterruptTargetThread :: ThreadId -> IO () +pushInterruptTargetThread tid = do + modifyMVar_ interruptTargetThread $ + return . (tid :) + +popInterruptTargetThread :: IO (Maybe ThreadId) +popInterruptTargetThread = + modifyMVar interruptTargetThread $ + \tids -> return $! case tids of [] -> ([], Nothing) + (t:ts) -> (ts, Just t) +#endif \end{code} diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 169dd9d440..1d091d7e2f 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -494,8 +494,8 @@ </row> <row> <entry><option>-ghci-script</option></entry> - <entry>Load the given additional <filename>.ghci</filename> file</entry> - <entry>static</entry> + <entry>Read additional <filename>.ghci</filename> files</entry> + <entry>dynamic</entry> <entry>-</entry> </row> <row> @@ -1571,15 +1571,6 @@ </row> <row> - <entry><option>-fllvm-tbaa</option></entry> - <entry>Turn on Typed Based Alias Analysis information in the LLVM - backend. This enables more accurate and alias information in the LLVM - backend for better optimisation. (default: enabled)</entry> - <entry>dynamic</entry> - <entry><option>-fno-llvm-tbaa</option></entry> - </row> - - <row> <entry><option>-fmax-simplifier-iterations</option></entry> <entry>Set the max iterations for the simplifier</entry> <entry>dynamic</entry> @@ -1633,23 +1624,6 @@ </row> <row> - <entry><option>-freg-liveness</option></entry> - <entry>Track STG register liveness to avoid saving and restoring - dead registers, as well as freeing the dead ones for use in - intermediate code. (LLVM backend only, default: enabled). - - Traditionally GHC has reserved a set of machine registers for the - exclusive use of storing a stack pointer, heap pointer and - general purpose function argument registers (these are the so - called STG registers). This optimisation tracks the liveness of - the machine registers the STG registers are mapped to so that the - machine register can be used for other purposes when the STG - register are dead.</entry> - <entry>dynamic</entry> - <entry><option>-fno-reg-liveness</option></entry> - </row> - - <row> <entry><option>-fsimplifier-phases</option></entry> <entry>Set the number of phases for the simplifier (default 2). Ignored with <option>-O0</option>.</entry> diff --git a/docs/users_guide/ghci.xml b/docs/users_guide/ghci.xml index b3fa469a99..87ba79d7b1 100644 --- a/docs/users_guide/ghci.xml +++ b/docs/users_guide/ghci.xml @@ -3105,6 +3105,10 @@ warning settings: wiki page: <ulink url="http://haskell.org/haskellwiki/GHC/GHCi">GHC/GHCi</ulink></para> + <para>Additionally, any files specified with + <literal>-ghci-script</literal> flags will be read after the + standard files, allowing the use of custom .ghci files.</para> + <para>Two command-line options control whether the startup files files are read:</para> @@ -3131,13 +3135,17 @@ warning settings: be used to override a previous <option>-ignore-dot-ghci</option> option.</para> </listitem> + <term> + <option>-ghci-script</option> + <indexterm><primary><option>-ghci-script</option></primary></indexterm> + </term> + <listitem> + <para>Read a specific file after the usual startup files. + Maybe be specified repeatedly for multiple inputs.</para> + </listitem> </varlistentry> </variablelist> - <para>Additional <filename>.ghci</filename> files can be added - through the <option>-ghci-script</option> option. These are - loaded after the normal <filename>.ghci</filename> files.</para> - </sect1> <sect1 id="ghci-obj"> diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml index 6261079f92..f9cbeb1c47 100644 --- a/docs/users_guide/using.xml +++ b/docs/users_guide/using.xml @@ -1771,8 +1771,8 @@ f "2" = 2 described above, and as such, you shouldn't need to set any of them explicitly (indeed, doing so could lead to unexpected results). A flag <option>-fwombat</option> can be negated by - saying <option>-fno-wombat</option>. The flags below are off by default, - except where noted below. + saying <option>-fno-wombat</option>. The flags below are off + by default, except where noted below. </para> <variablelist> @@ -1797,7 +1797,17 @@ f "2" = 2 <listitem> <para> <emphasis>On by default.</emphasis>. Switch on the strictness analyser. There is a very old paper about GHC's - strictness analyser, <ulink url="http://research.microsoft.com/en-us/um/people/simonpj/papers/simple-strictnes-analyser.ps.gz">Measuring the effectiveness of a simple strictness analyser</ulink>, but the current one is quite a bit different. + strictness analyser, <ulink url="http://research.microsoft.com/en-us/um/people/simonpj/papers/simple-strictnes-analyser.ps.gz"> + Measuring the effectiveness of a simple strictness analyser</ulink>, + but the current one is quite a bit different. + </para> + + <para>The strictness analyser figures out when arguments and + variables in a function can be treated 'strictly' (that is they + are always evaluated in the function at some point). This allow + GHC to apply certain optimisations such as unboxing that + otherwise don't apply as they change the semantics of the program + when applied to lazy arguments. </para> </listitem> </varlistentry> @@ -1833,7 +1843,40 @@ f "2" = 2 </term> <listitem> <para><emphasis>Off by default, but enabled by -O2.</emphasis> - Turn on call-pattern specialisation; see <ulink url="http://research.microsoft.com/en-us/um/people/simonpj/papers/spec-constr/index.htm">Call-pattern specialisation for Haskell programs</ulink>.</para> + Turn on call-pattern specialisation; see + <ulink url="http://research.microsoft.com/en-us/um/people/simonpj/papers/spec-constr/index.htm"> + Call-pattern specialisation for Haskell programs</ulink>. + </para> + + <para>This optimisation specializes recursive functions according to + their argument "shapes". This is best explained by example so + consider: +<programlisting> +last :: [a] -> a +last [] = error "last" +last (x : []) = x +last (x : xs) = last xs +</programlisting> + In this code, once we pass the initial check for an empty list we + know that in the recursive case this pattern match is redundant. As + such <option>-fspec-constr</option> will transform the above code + to: +<programlisting> +last :: [a] -> a +last [] = error "last" +last (x : xs) = last' x xs + where + last' x [] = x + last' x (y : ys) = last' y ys +</programlisting> + </para> + + <para>As well avoid unnecessary pattern matching it also helps avoid + unnecessary allocation. This applies when a argument is strict in + the recursive call to itself but not on the initial entry. As + strict recursive branch of the function is created similar to the + above example. + </para> </listitem> </varlistentry> @@ -1844,9 +1887,12 @@ f "2" = 2 </term> <listitem> <para><emphasis>On by default.</emphasis> - Specialise each type-class-overloaded function defined in this module for the types at which - it is called in this module. Also specialise imported functions that have an INLINABLE pragma - (<xref linkend="inlinable-pragma"/>) for the types at which they are called in this module.</para> + Specialise each type-class-overloaded function defined in this + module for the types at which it is called in this module. Also + specialise imported functions that have an INLINABLE pragma + (<xref linkend="inlinable-pragma"/>) for the types at which they + are called in this module. + </para> </listitem> </varlistentry> @@ -1856,7 +1902,12 @@ f "2" = 2 <indexterm><primary><option>-fstatic-argument-transformation</option></primary></indexterm> </term> <listitem> - <para>Turn on the static argument transformation, which turns a recursive function into a non-recursive one with a local recursive loop. See Chapter 7 of <ulink url="http://research.microsoft.com/en-us/um/people/simonpj/papers/santos-thesis.ps.gz">Andre Santos's PhD thesis</ulink></para> + <para>Turn on the static argument transformation, which turns a + recursive function into a non-recursive one with a local + recursive loop. See Chapter 7 of + <ulink url="http://research.microsoft.com/en-us/um/people/simonpj/papers/santos-thesis.ps.gz"> + Andre Santos's PhD thesis</ulink> + </para> </listitem> </varlistentry> @@ -1866,8 +1917,25 @@ f "2" = 2 <indexterm><primary><option></option></primary></indexterm> </term> <listitem> - <para> <emphasis>On by default.</emphasis> - Float let-bindings inwards, nearer their binding site. See <ulink url="http://research.microsoft.com/en-us/um/people/simonpj/papers/float.ps.gz">Let-floating: moving bindings to give faster programs (ICFP'96)</ulink>. + <para><emphasis>On by default.</emphasis> + Float let-bindings inwards, nearer their binding site. See + <ulink url="http://research.microsoft.com/en-us/um/people/simonpj/papers/float.ps.gz"> + Let-floating: moving bindings to give faster programs (ICFP'96)</ulink>. + </para> + + <para>This optimisation moves let bindings closer to their use + site. The benefit here is that this may avoid unnecessary + allocation if the branch the let is now on is never executed. It + also enables other optimisation passes to work more effectively + as they have more information locally. + </para> + + <para>This optimisation isn't always beneficial though (so GHC + applies some heuristics to decide when to apply it). The details + get complicated but a simple example is that it is often beneficial + to move let bindings outwards so that multiple let bindings can be + grouped into a larger single let binding, effectively batching + their allocation and helping the garbage collector and allocator. </para> </listitem> </varlistentry> @@ -1879,20 +1947,23 @@ f "2" = 2 </term> <listitem> <para><emphasis>On by default.</emphasis> - Run the full laziness optimisation (also known as - let-floating), which floats let-bindings outside enclosing lambdas, in the hope they will be thereby be computed less often. - See <ulink url="http://research.microsoft.com/en-us/um/people/simonpj/papers/float.ps.gz">Let-floating: moving bindings to give faster programs (ICFP'96)</ulink>. - Full laziness increases sharing, which can lead - to increased memory residency.</para> + Run the full laziness optimisation (also known as let-floating), + which floats let-bindings outside enclosing lambdas, in the hope + they will be thereby be computed less often. See + <ulink url="http://research.microsoft.com/en-us/um/people/simonpj/papers/float.ps.gz">Let-floating: + moving bindings to give faster programs (ICFP'96)</ulink>. + Full laziness increases sharing, which can lead to increased memory + residency. + </para> + <para>NOTE: GHC doesn't implement complete full-laziness. - When optimisation in on, and - <option>-fno-full-laziness</option> is not given, some - transformations that increase sharing are performed, such - as extracting repeated computations from a loop. These - are the same transformations that a fully lazy - implementation would do, the difference is that GHC - doesn't consistently apply full-laziness, so don't rely on - it.</para> + When optimisation in on, and <option>-fno-full-laziness</option> + is not given, some transformations that increase sharing are + performed, such as extracting repeated computations from a loop. + These are the same transformations that a fully lazy + implementation would do, the difference is that GHC doesn't + consistently apply full-laziness, so don't rely on it. + </para> </listitem> </varlistentry> @@ -1901,7 +1972,9 @@ f "2" = 2 <option>-fdo-lambda-eta-expansion</option> <indexterm><primary><option></option></primary></indexterm> </term> - <listitem><para> <emphasis>On by default.</emphasis> Eta-expand let-bindings to increase their arity. + <listitem> + <para><emphasis>On by default.</emphasis> + Eta-expand let-bindings to increase their arity. </para> </listitem> </varlistentry> @@ -1911,8 +1984,10 @@ f "2" = 2 <option>-fdo-eta-reduction</option> <indexterm><primary><option></option></primary></indexterm> </term> - <listitem> <para> <emphasis>On by default.</emphasis> - Eta-reduce lambda expressions, if doing so gets rid of a whole group of lambdas. + <listitem> + <para><emphasis>On by default.</emphasis> + Eta-reduce lambda expressions, if doing so gets rid of a whole + group of lambdas. </para> </listitem> </varlistentry> @@ -1948,9 +2023,12 @@ f "2" = 2 </term> <listitem> <para><emphasis>Off by default, but enabled by -O2.</emphasis> - Turn on the liberate-case transformation. This unrolls recursive function once in its own RHS, to - avoid repeated case analysis of free variables. It's a bit like the call-pattern specialiser - (<option>-fspec-constr</option>) but for free variables rather than arguments.</para> + Turn on the liberate-case transformation. This unrolls recursive + function once in its own RHS, to avoid repeated case analysis of + free variables. It's a bit like the call-pattern specialiser + (<option>-fspec-constr</option>) but for free variables rather than + arguments. + </para> </listitem> </varlistentry> @@ -1960,7 +2038,8 @@ f "2" = 2 <indexterm><primary><option></option></primary></indexterm> </term> <listitem> - <para> A very experimental flag that makes dictionary-valued expressions seem cheap to the optimiser. + <para>A very experimental flag that makes dictionary-valued + expressions seem cheap to the optimiser. </para> </listitem> </varlistentry> @@ -1971,8 +2050,10 @@ f "2" = 2 <indexterm><primary><option></option></primary></indexterm> </term> <listitem> - <para> Usually GHC black-holes a thunk only when it switches threads. This flag makes it do so - as soon as the thunk is entered. See <ulink url="http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/">Haskell on a shared-memory multiprocessor</ulink>. + <para>Usually GHC black-holes a thunk only when it switches + threads. This flag makes it do so as soon as the thunk is + entered. See <ulink url="http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/"> + Haskell on a shared-memory multiprocessor</ulink>. </para> </listitem> </varlistentry> @@ -1987,7 +2068,8 @@ f "2" = 2 <literal>State#</literal> token as argument is considered to be single-entry, hence it is considered OK to inline things inside it. This can improve performance of IO and ST monad code, but it - runs the risk of reducing sharing.</para> + runs the risk of reducing sharing. + </para> </listitem> </varlistentry> @@ -2001,7 +2083,8 @@ f "2" = 2 <option>-fno-state-hack</option>). In particular, stop GHC eta-expanding through a case expression, which is good for performance, but bad if you are using <literal>seq</literal> on - partial applications.</para> + partial applications. + </para> </listitem> </varlistentry> @@ -2011,19 +2094,24 @@ f "2" = 2 <indexterm><primary><option>-fsimpl-tick-factor</option></primary></indexterm> </term> <listitem> - <para>GHC's optimiser can diverge if you write rewrite rules (<xref linkend="rewrite-rules"/>) - that don't terminate, or (less satisfactorily) if you - code up recursion through data types - (<xref linkend="bugs-ghc"/>). To avoid making the compiler fall into an infinite - loop, the optimiser carries a "tick count" and stops inlining and applying rewrite rules - when this count is exceeded. The limit is set as a multiple of the program size, so - bigger programs get more ticks. The <option>-fsimpl-tick-factor</option> flag lets - you change the multiplier. The default is 100; numbers larger than 100 give more ticks, - and numbers smaller than 100 give fewer.</para> - - <para>If the tick-count expires, GHC summarises what simplifier steps it has done; - you can use <option>-fddump-simpl-stats</option> to generate a much more detailed list. - Usually that identifies the loop quite accurately, because some numbers are very large. + <para>GHC's optimiser can diverge if you write rewrite rules ( + <xref linkend="rewrite-rules"/>) that don't terminate, or (less + satisfactorily) if you code up recursion through data types + (<xref linkend="bugs-ghc"/>). To avoid making the compiler fall + into an infinite loop, the optimiser carries a "tick count" and + stops inlining and applying rewrite rules when this count is + exceeded. The limit is set as a multiple of the program size, so + bigger programs get more ticks. The + <option>-fsimpl-tick-factor</option> flag lets you change the + multiplier. The default is 100; numbers larger than 100 give more + ticks, and numbers smaller than 100 give fewer. + </para> + + <para>If the tick-count expires, GHC summarises what simplifier + steps it has done; you can use + <option>-fddump-simpl-stats</option> to generate a much more + detailed list. Usually that identifies the loop quite + accurately, because some numbers are very large. </para> </listitem> </varlistentry> @@ -2040,12 +2128,13 @@ f "2" = 2 function unfolding to be. (An unfolding has a “size” that reflects the cost in terms of “code bloat” of expanding (aka inlining) that unfolding at a call site. A bigger - function would be assigned a bigger cost.) </para> + function would be assigned a bigger cost.) + </para> - <para>Consequences: (a) nothing larger than this will be - inlined (unless it has an INLINE pragma); (b) nothing - larger than this will be spewed into an interface - file. </para> + <para>Consequences: (a) nothing larger than this will be inlined + (unless it has an INLINE pragma); (b) nothing larger than this + will be spewed into an interface file. + </para> <para>Increasing this figure is more likely to result in longer compile times than faster code. The @@ -2067,13 +2156,16 @@ f "2" = 2 unfolded at the call-site, any bigger and it won't. The size computed for a function depends on two things: the actual size of the expression minus any discounts that - apply (see <option>-funfolding-con-discount</option>).</para> + apply (see <option>-funfolding-con-discount</option>). + </para> <para>The difference between this and <option>-funfolding-creation-threshold</option> is that this one - determines if a function definition will be inlined <emphasis>at a call - site</emphasis>. The other option determines if a function definition will - be kept around at all for potential inlining.</para> + determines if a function definition will be inlined <emphasis>at + a call site</emphasis>. The other option determines if a + function definition will be kept around at all for potential + inlining. + </para> </listitem> </varlistentry> @@ -2083,7 +2175,9 @@ f "2" = 2 <indexterm><primary><option></option></primary></indexterm> </term> <listitem> - <para>An experimental flag to expose all unfoldings, even for very large or recursive functions. + <para>An experimental flag to expose all unfoldings, even for very + large or recursive functions. This allows for all functions to be + inlined while usually GHC would avoid inlining larger functions. </para> </listitem> </varlistentry> @@ -2118,9 +2212,13 @@ f "2" = 2 <indexterm><primary><option></option></primary></indexterm> </term> <listitem> - <para> + <para><emphasis>Off by default, but enabled by -O2. Only applies in + combination with the native code generator.</emphasis> + Use the graph colouring register allocator for register allocation + in the native code generator. By default, GHC uses a simpler, + faster linear register allocator. The downside being that the + linear register allocator usually generates worse code. </para> - TODO: Document optimisation </listitem> </varlistentry> @@ -2130,9 +2228,13 @@ f "2" = 2 <indexterm><primary><option></option></primary></indexterm> </term> <listitem> - <para> + <para><emphasis>Off by default, only applies in combination with + the native code generator.</emphasis> + Use the iterative coalescing graph colouring register allocator for + register allocation in the native code generator. This is the same + register allocator as the <option>-freg-graph</option> one but also + enables iterative coalescing during register allocation. </para> - TODO: Document optimisation </listitem> </varlistentry> diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 4525942296..8d6e23c678 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -432,9 +432,9 @@ runGHCi paths maybe_exprs = do setGHCContextFromGHCiState + dflags <- getDynFlags when (read_dot_files) $ do - mcfgs0 <- sequence $ [ current_dir, app_user_dir, home_dir ] - ++ map (return . Just) opt_GhciScripts + mcfgs0 <- sequence $ [ current_dir, app_user_dir, home_dir ] ++ map (return . Just ) (ghciScripts dflags) mcfgs <- liftIO $ mapM canonicalizePath' (catMaybes mcfgs0) mapM_ sourceConfigFile $ nub $ catMaybes mcfgs -- nub, because we don't want to read .ghci twice if the @@ -446,17 +446,14 @@ runGHCi paths maybe_exprs = do when (not (null paths)) $ do ok <- ghciHandle (\e -> do showException e; return Failed) $ -- TODO: this is a hack. - runInputTWithPrefs defaultPrefs defaultSettings $ do - let (filePaths, phases) = unzip paths - filePaths' <- mapM (Encoding.decode . BS.pack) filePaths - loadModule (zip filePaths' phases) + runInputTWithPrefs defaultPrefs defaultSettings $ + loadModule paths when (isJust maybe_exprs && failed ok) $ liftIO (exitWith (ExitFailure 1)) -- if verbosity is greater than 0, or we are connected to a -- terminal, display the prompt in the interactive loop. is_tty <- liftIO (hIsTerminalDevice stdin) - dflags <- getDynFlags let show_prompt = verbosity dflags > 0 || is_tty -- reset line number @@ -2885,10 +2882,7 @@ isHomeModule m = GHC.modulePackageId m == mainPackageId -- TODO: won't work if home dir is encoded. -- (changeDirectory may not work either in that case.) expandPath :: MonadIO m => String -> InputT m String -expandPath p = do - exp_path <- liftIO $ expandPathIO p - e <- fmap BS.unpack $ Encoding.encode exp_path - return e +expandPath = liftIO . expandPathIO expandPathIO :: String -> IO String expandPathIO p = diff --git a/includes/rts/storage/TSO.h b/includes/rts/storage/TSO.h index 5e54bff72c..82f5a75948 100644 --- a/includes/rts/storage/TSO.h +++ b/includes/rts/storage/TSO.h @@ -57,7 +57,7 @@ typedef union { #if !defined(THREADED_RTS) StgWord target; // Only for the non-threaded RTS: the target time for a thread - // blocked in threadDelay, in units of 10ms. This is a + // blocked in threadDelay, in units of 1ms. This is a // compromise: we don't want to take up much space in the TSO. If // you want better resolution for threadDelay, use -threaded. #endif diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index e368ed195b..aaedabb951 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -1838,11 +1838,7 @@ stg_delayzh #else - W_ time; - (time) = foreign "C" getourtimeofday() [R1]; - // getourtimeofday() returns a value in units of 10ms - // R1 is in microseconds, we need to (/ 10000), rounding up - target = time + 1 + (R1 + 10000-1) / 10000; + (target) = foreign "C" getDelayTarget(R1) [R1]; StgTSO_block_info(CurrentTSO) = target; diff --git a/rts/RtsProbes.d b/rts/RtsProbes.d index f5470dfe0b..40665acc56 100644 --- a/rts/RtsProbes.d +++ b/rts/RtsProbes.d @@ -56,12 +56,13 @@ provider HaskellEvent { probe gc__work (EventCapNo); probe gc__done (EventCapNo); probe gc__sync (EventCapNo); +/* FIXME: leads to a validate failure on OS X (Lion) probe gc__stats (CapsetID, StgWord, StgWord, StgWord, StgWord, StgWord, StgWord, StgWord); probe heap__info (CapsetID, StgWord, StgWord, StgWord, StgWord, StgWord); probe heap__allocated (EventCapNo, CapsetID, StgWord64); probe heap__size (CapsetID, StgWord); probe heap__live (CapsetID, StgWord); - + */ /* capability events */ probe startup (EventCapNo); probe cap__create (EventCapNo); diff --git a/rts/Threads.c b/rts/Threads.c index 802a37c94c..61bf4445e8 100644 --- a/rts/Threads.c +++ b/rts/Threads.c @@ -66,8 +66,8 @@ createThread(Capability *cap, nat size) /* sched_mutex is *not* required */ /* catch ridiculously small stack sizes */ - if (size < MIN_STACK_WORDS + sizeofW(StgStack)) { - size = MIN_STACK_WORDS + sizeofW(StgStack); + if (size < MIN_STACK_WORDS + sizeofW(StgStack) + sizeofW(StgTSO)) { + size = MIN_STACK_WORDS + sizeofW(StgStack) + sizeofW(StgTSO); } /* The size argument we are given includes all the per-thread @@ -424,12 +424,16 @@ updateThunk (Capability *cap, StgTSO *tso, StgClosure *thunk, StgClosure *val) updateWithIndirection(cap, thunk, val); + // sometimes the TSO is locked when we reach here, so its header + // might be WHITEHOLE. Hence check for the correct owner using + // pointer equality first. + if ((StgTSO*)v == tso) { + return; + } + i = v->header.info; if (i == &stg_TSO_info) { - owner = (StgTSO*)v; - if (owner != tso) { - checkBlockingQueues(cap, tso); - } + checkBlockingQueues(cap, tso); return; } diff --git a/rts/Trace.c b/rts/Trace.c index 089bf24423..e5a4beba61 100644 --- a/rts/Trace.c +++ b/rts/Trace.c @@ -97,7 +97,8 @@ void initTracing (void) // -Dg turns on gc tracing too TRACE_gc = RtsFlags.TraceFlags.gc || - RtsFlags.DebugFlags.gc; + RtsFlags.DebugFlags.gc || + RtsFlags.DebugFlags.scheduler; if (TRACE_gc && RtsFlags.GcFlags.giveStats == NO_GC_STATS) { RtsFlags.GcFlags.giveStats = COLLECT_GC_STATS; } @@ -325,8 +326,14 @@ void traceHeapEvent_ (Capability *cap, CapsetID heap_capset, lnat info1) { - /* no stderr equivalent for these ones */ - postHeapEvent(cap, tag, heap_capset, info1); +#ifdef DEBUG + if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) { + /* no stderr equivalent for these ones */ + } else +#endif + { + postHeapEvent(cap, tag, heap_capset, info1); + } } void traceEventHeapInfo_ (CapsetID heap_capset, @@ -336,10 +343,16 @@ void traceEventHeapInfo_ (CapsetID heap_capset, lnat mblockSize, lnat blockSize) { - /* no stderr equivalent for this one */ - postEventHeapInfo(heap_capset, gens, - maxHeapSize, allocAreaSize, - mblockSize, blockSize); +#ifdef DEBUG + if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) { + /* no stderr equivalent for these ones */ + } else +#endif + { + postEventHeapInfo(heap_capset, gens, + maxHeapSize, allocAreaSize, + mblockSize, blockSize); + } } void traceEventGcStats_ (Capability *cap, @@ -352,10 +365,16 @@ void traceEventGcStats_ (Capability *cap, lnat par_max_copied, lnat par_tot_copied) { - /* no stderr equivalent for this one */ - postEventGcStats(cap, heap_capset, gen, - copied, slop, fragmentation, - par_n_threads, par_max_copied, par_tot_copied); +#ifdef DEBUG + if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) { + /* no stderr equivalent for these ones */ + } else +#endif + { + postEventGcStats(cap, heap_capset, gen, + copied, slop, fragmentation, + par_n_threads, par_max_copied, par_tot_copied); + } } void traceCapEvent (Capability *cap, diff --git a/rts/Trace.h b/rts/Trace.h index c4c4e41608..58ce43df68 100644 --- a/rts/Trace.h +++ b/rts/Trace.h @@ -352,6 +352,7 @@ INLINE_HEADER void dtraceStartup (int num_caps) { HASKELLEVENT_GC_DONE(cap) #define dtraceGcGlobalSync(cap) \ HASKELLEVENT_GC_GLOBAL_SYNC(cap) +/* FIXME: leads to a validate failure on OS X (Lion) #define dtraceEventGcStats(heap_capset, gens, \ copies, slop, fragmentation, \ par_n_threads, \ @@ -373,10 +374,23 @@ INLINE_HEADER void dtraceStartup (int num_caps) { HASKELLEVENT_HEAP_ALLOCATED(cap, heap_capset, \ allocated) #define dtraceEventHeapSize(heap_capset, size) \ - HASKELLEVENT_HEAP_LIVE(heap_capset, size) + HASKELLEVENT_HEAP_SIZE(heap_capset, size) #define dtraceEventHeapLive(heap_capset, live) \ HASKELLEVENT_HEAP_LIVE(heap_capset, live) - + */ +#define dtraceEventGcStats(heap_capset, gens, \ + copies, slop, fragmentation, \ + par_n_threads, \ + par_max_copied, \ + par_tot_copied) +#define dtraceHeapInfo(heap_capset, gens, \ + maxHeapSize, allocAreaSize, \ + mblockSize, blockSize) +#define dtraceEventHeapAllocated(cap, heap_capset, \ + allocated) +#define dtraceEventHeapSize(heap_capset, size) +#define dtraceEventHeapLive(heap_capset, live) + #define dtraceCapsetCreate(capset, capset_type) \ HASKELLEVENT_CAPSET_CREATE(capset, capset_type) #define dtraceCapsetDelete(capset) \ @@ -517,7 +531,9 @@ INLINE_HEADER void traceEventMigrateThread(Capability *cap STG_UNUSED, INLINE_HEADER void traceCapCreate(Capability *cap STG_UNUSED) { traceCapEvent(cap, EVENT_CAP_CREATE); +/* FIXME: leads to a validate failure on OS X (Lion) dtraceCapCreate((EventCapNo)cap->no); + */ } INLINE_HEADER void traceCapDelete(Capability *cap STG_UNUSED) @@ -616,7 +632,9 @@ INLINE_HEADER void traceEventGcDone(Capability *cap STG_UNUSED) INLINE_HEADER void traceEventGcGlobalSync(Capability *cap STG_UNUSED) { traceGcEvent(cap, EVENT_GC_GLOBAL_SYNC); +/* FIXME: leads to a validate failure on OS X (Lion) dtraceGcGlobalSync((EventCapNo)cap->no); + */ } INLINE_HEADER void traceEventGcStats(Capability *cap STG_UNUSED, diff --git a/rts/posix/Select.c b/rts/posix/Select.c index 013b374d1a..a2a66a6b8a 100644 --- a/rts/posix/Select.c +++ b/rts/posix/Select.c @@ -2,7 +2,10 @@ * * (c) The GHC Team 1995-2002 * - * Support for concurrent non-blocking I/O and thread waiting. + * Support for concurrent non-blocking I/O and thread waiting in the + * non-threaded RTS. In the threded RTS, this file is not used at + * all, instead we use the IO manager thread implemented in Haskell in + * the base package. * * ---------------------------------------------------------------------------*/ @@ -39,21 +42,39 @@ #if !defined(THREADED_RTS) -/* - * The threaded RTS uses an IO-manager thread in Haskell instead (see GHC.Conc) - */ - -#define LowResTimeToTime(t) (USToTime((t) * 10000)) +// The target time for a threadDelay is stored in a one-word quantity +// in the TSO (tso->block_info.target). On a 32-bit machine we +// therefore can't afford to use nanosecond resolution because it +// would overflow too quickly, so instead we use millisecond +// resolution. + +#if SIZEOF_VOID_P == 4 +#define LowResTimeToTime(t) (USToTime((t) * 1000)) +#define TimeToLowResTimeRoundDown(t) (TimeToUS(t) / 1000) +#define TimeToLowResTimeRoundUp(t) ((TimeToUS(t) + 1000-1) / 1000) +#else +#define LowResTimeToTime(t) (t) +#define TimeToLowResTimeRoundDown(t) (t) +#define TimeToLowResTimeRoundUp(t) (t) +#endif /* * Return the time since the program started, in LowResTime, * rounded down. - * - * This is only used by posix/Select.c. It should probably go away. */ -LowResTime getourtimeofday(void) +static LowResTime getLowResTimeOfDay(void) +{ + return TimeToLowResTimeRoundDown(stat_getElapsedTime()); +} + +/* + * For a given microsecond delay, return the target time in LowResTime. + */ +LowResTime getDelayTarget (HsInt us) { - return TimeToUS(stat_getElapsedTime()) / 10000; + // round up the target time, because we never want to sleep *less* + // than the desired amount. + return TimeToLowResTimeRoundUp(stat_getElapsedTime() + USToTime(us)); } /* There's a clever trick here to avoid problems when the time wraps @@ -136,7 +157,7 @@ awaitEvent(rtsBool wait) */ do { - now = getourtimeofday(); + now = getLowResTimeOfDay(); if (wakeUpSleepingThreads(now)) { return; } @@ -196,10 +217,19 @@ awaitEvent(rtsBool wait) ptv = NULL; } - /* Check for any interesting events */ - - while ((numFound = select(maxfd+1, &rfd, &wfd, NULL, ptv)) < 0) { - if (errno != EINTR) { + while (1) { // repeat the select on EINTR + + // Disable the timer signal while blocked in + // select(), to conserve power. (#1623, #5991) + if (wait) stopTimer(); + + numFound = select(maxfd+1, &rfd, &wfd, NULL, ptv); + + if (wait) startTimer(); + + if (numFound >= 0) break; + + if (errno != EINTR) { /* Handle bad file descriptors by unblocking all the waiting threads. Why? Because a thread might have been a bit naughty and closed a file descriptor while another @@ -218,12 +248,12 @@ awaitEvent(rtsBool wait) the RTS won't loop. */ if ( errno == EBADF ) { - unblock_all = rtsTrue; - break; + unblock_all = rtsTrue; + break; } else { - perror("select"); - barf("select failed"); - } + sysErrorBelch("select"); + stg_exit(EXIT_FAILURE); + } } /* We got a signal; could be one of ours. If so, we need @@ -246,7 +276,7 @@ awaitEvent(rtsBool wait) /* check for threads that need waking up */ - wakeUpSleepingThreads(getourtimeofday()); + wakeUpSleepingThreads(getLowResTimeOfDay()); /* If new runnable threads have arrived, stop waiting for * I/O and run them. diff --git a/rts/posix/Select.h b/rts/posix/Select.h index 15fa00ac66..50d49d4ba5 100644 --- a/rts/posix/Select.h +++ b/rts/posix/Select.h @@ -12,6 +12,6 @@ // An absolute time value in units of 10ms. typedef StgWord LowResTime; -RTS_PRIVATE LowResTime getourtimeofday ( void ); +RTS_PRIVATE LowResTime getDelayTarget (HsInt us); #endif /* POSIX_SELECT_H */ |