diff --git a/GHC.hs b/GHC.hs --- a/GHC.hs +++ b/GHC.hs @@ -1482,9 +1482,7 @@ modInfoModBreaks = minf_modBreaks isDictonaryId :: Id -> Bool -isDictonaryId id - = case tcSplitSigmaTy (idType id) of { - (_tvs, _theta, tau) -> isDictTy tau } +isDictonaryId id = isDictTy (idType id) -- | Looks up a global name: that is, any top-level name in any -- visible module. Unlike 'lookupName', lookupGlobalName does not use diff --git a/GHC/Builtin/primops.txt.pp b/GHC/Builtin/primops.txt.pp --- a/GHC/Builtin/primops.txt.pp +++ b/GHC/Builtin/primops.txt.pp @@ -3859,10 +3859,25 @@ more complicated settings, e.g. converting a list of newtypes to a list of concrete types. + When used in conversions involving a newtype wrapper, + make sure the newtype constructor is in scope. + This function is representation-polymorphic, but the 'RuntimeRep' type argument is marked as 'Inferred', meaning that it is not available for visible type application. This means - the typechecker will accept @'coerce' @'Int' @Age 42@. + the typechecker will accept @'coerce' \@'Int' \@Age 42@. + + === __Examples__ + + >>> newtype TTL = TTL Int deriving (Eq, Ord, Show) + >>> newtype Age = Age Int deriving (Eq, Ord, Show) + >>> coerce (Age 42) :: TTL + TTL 42 + >>> coerce (+ (1 :: Int)) (Age 42) :: TTL + TTL 43 + >>> coerce (map (+ (1 :: Int))) [Age 42, Age 24] :: [TTL] + [TTL 43,TTL 25] + } ------------------------------------------------------------------------ diff --git a/GHC/Cmm/Lexer.hs b/GHC/Cmm/Lexer.hs --- a/GHC/Cmm/Lexer.hs +++ b/GHC/Cmm/Lexer.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 13 "_build/source-dist/ghc-9.6.4-src/ghc-9.6.4/compiler/GHC/Cmm/Lexer.x" #-} +{-# LINE 13 "_build/source-dist/ghc-9.6.5-src/ghc-9.6.5/compiler/GHC/Cmm/Lexer.x" #-} module GHC.Cmm.Lexer ( CmmToken(..), cmmlex, ) where @@ -385,7 +385,7 @@ , (0,alex_action_20) ] -{-# LINE 133 "_build/source-dist/ghc-9.6.4-src/ghc-9.6.4/compiler/GHC/Cmm/Lexer.x" #-} +{-# LINE 133 "_build/source-dist/ghc-9.6.5-src/ghc-9.6.5/compiler/GHC/Cmm/Lexer.x" #-} data CmmToken = CmmT_SpecChar Char | CmmT_DotDot diff --git a/GHC/CmmToAsm/Wasm/FromCmm.hs b/GHC/CmmToAsm/Wasm/FromCmm.hs --- a/GHC/CmmToAsm/Wasm/FromCmm.hs +++ b/GHC/CmmToAsm/Wasm/FromCmm.hs @@ -877,7 +877,7 @@ pure $ SomeWasmExpr ty_word $ WasmExpr $ - WasmSymConst "stg_EAGER_BLACKHOLE_info" + WasmSymConst "__stg_EAGER_BLACKHOLE_info" lower_CmmReg _ (CmmGlobal GCEnter1) = do ty_word <- wasmWordTypeM ty_word_cmm <- wasmWordCmmTypeM diff --git a/GHC/Core/Predicate.hs b/GHC/Core/Predicate.hs --- a/GHC/Core/Predicate.hs +++ b/GHC/Core/Predicate.hs @@ -100,7 +100,14 @@ mkClassPred clas tys = mkTyConApp (classTyCon clas) tys isDictTy :: Type -> Bool -isDictTy = isClassPred +-- True of dictionaries (Eq a) and +-- dictionary functions (forall a. Eq a => Eq [a]) +-- See Note [Type determines value] +-- See #24370 (and the isDictId call in GHC.HsToCore.Binds.decomposeRuleLhs) +-- for why it's important to catch dictionary bindings +isDictTy ty = isClassPred pred + where + (_, pred) = splitInvisPiTys ty typeDeterminesValue :: Type -> Bool -- See Note [Type determines value] diff --git a/GHC/Core/Unify.hs b/GHC/Core/Unify.hs --- a/GHC/Core/Unify.hs +++ b/GHC/Core/Unify.hs @@ -31,6 +31,7 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Name( Name, mkSysTvName, mkSystemVarName ) +import GHC.Builtin.Names( tYPETyConKey, cONSTRAINTTyConKey ) import GHC.Core.Type hiding ( getTvSubstEnv ) import GHC.Core.Coercion hiding ( getCvSubstEnv ) import GHC.Core.TyCon @@ -1150,8 +1151,10 @@ -- TYPE and CONSTRAINT are not Apart -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim -- NB: at this point we know that the two TyCons do not match - | Just {} <- sORTKind_maybe ty1 - , Just {} <- sORTKind_maybe ty2 + | Just (tc1,_) <- mb_tc_app1, let u1 = tyConUnique tc1 + , Just (tc2,_) <- mb_tc_app2, let u2 = tyConUnique tc2 + , (u1 == tYPETyConKey && u2 == cONSTRAINTTyConKey) || + (u2 == tYPETyConKey && u1 == cONSTRAINTTyConKey) = maybeApart MARTypeVsConstraint -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim -- Note [Type and Constraint are not apart] diff --git a/GHC/Data/Graph/Directed.hs b/GHC/Data/Graph/Directed.hs --- a/GHC/Data/Graph/Directed.hs +++ b/GHC/Data/Graph/Directed.hs @@ -45,7 +45,7 @@ import GHC.Prelude -import GHC.Utils.Misc ( minWith, count ) +import GHC.Utils.Misc ( sortWith, count ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.Maybe ( expectJust ) @@ -218,47 +218,52 @@ [payload]) -- Rest of the path; -- [a,b,c] means c depends on b, b depends on a --- | Find a reasonably short cycle a->b->c->a, in a strongly --- connected component. The input nodes are presumed to be --- a SCC, so you can start anywhere. +-- | Find a reasonably short cycle a->b->c->a, in a graph +-- The graph might not necessarily be strongly connected. findCycle :: forall payload key. Ord key => [Node key payload] -- The nodes. The dependencies can -- contain extra keys, which are ignored -> Maybe [payload] -- A cycle, starting with node -- so each depends on the next findCycle graph - = go Set.empty (new_work root_deps []) [] + = goRoots plausible_roots where env :: Map.Map key (Node key payload) env = Map.fromList [ (node_key node, node) | node <- graph ] - -- Find the node with fewest dependencies among the SCC modules - -- This is just a heuristic to find some plausible root module - root :: Node key payload - root = fst (minWith snd [ (node, count (`Map.member` env) - (node_dependencies node)) - | node <- graph ]) - DigraphNode root_payload root_key root_deps = root + goRoots [] = Nothing + goRoots (root:xs) = + case go Set.empty (new_work root_deps []) [] of + Nothing -> goRoots xs + Just res -> Just res + where + DigraphNode root_payload root_key root_deps = root + -- 'go' implements Dijkstra's algorithm, more or less + go :: Set.Set key -- Visited + -> [WorkItem key payload] -- Work list, items length n + -> [WorkItem key payload] -- Work list, items length n+1 + -> Maybe [payload] -- Returned cycle + -- Invariant: in a call (go visited ps qs), + -- visited = union (map tail (ps ++ qs)) + go _ [] [] = Nothing -- No cycles + go visited [] qs = go visited qs [] + go visited (((DigraphNode payload key deps), path) : ps) qs + | key == root_key = Just (root_payload : reverse path) + | key `Set.member` visited = go visited ps qs + | key `Map.notMember` env = go visited ps qs + | otherwise = go (Set.insert key visited) + ps (new_qs ++ qs) + where + new_qs = new_work deps (payload : path) - -- 'go' implements Dijkstra's algorithm, more or less - go :: Set.Set key -- Visited - -> [WorkItem key payload] -- Work list, items length n - -> [WorkItem key payload] -- Work list, items length n+1 - -> Maybe [payload] -- Returned cycle - -- Invariant: in a call (go visited ps qs), - -- visited = union (map tail (ps ++ qs)) - go _ [] [] = Nothing -- No cycles - go visited [] qs = go visited qs [] - go visited (((DigraphNode payload key deps), path) : ps) qs - | key == root_key = Just (root_payload : reverse path) - | key `Set.member` visited = go visited ps qs - | key `Map.notMember` env = go visited ps qs - | otherwise = go (Set.insert key visited) - ps (new_qs ++ qs) - where - new_qs = new_work deps (payload : path) + -- Find the nodes with fewest dependencies among the SCC modules + -- This is just a heuristic to find some plausible root module + plausible_roots :: [Node key payload] + plausible_roots = map fst (sortWith snd [ (node, count (`Map.member` env) (node_dependencies node)) + | node <- graph ]) + new_work :: [key] -> [payload] -> [WorkItem key payload] new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ] diff --git a/GHC/Driver/Config/CmmToAsm.hs b/GHC/Driver/Config/CmmToAsm.hs --- a/GHC/Driver/Config/CmmToAsm.hs +++ b/GHC/Driver/Config/CmmToAsm.hs @@ -66,7 +66,8 @@ , ncgDwarfSourceNotes = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 2 -- We produce GHC-specific source-note DIEs only with -g3 , ncgExposeInternalSymbols = gopt Opt_ExposeInternalSymbols dflags , ncgCmmStaticPred = gopt Opt_CmmStaticPred dflags - , ncgEnableShortcutting = gopt Opt_AsmShortcutting dflags + -- Disabled due to https://gitlab.haskell.org/ghc/ghc/-/issues/24507 + , ncgEnableShortcutting = False -- gopt Opt_AsmShortcutting dflags , ncgComputeUnwinding = debugLevel dflags > 0 , ncgEnableDeadCodeElimination = not (gopt Opt_InfoTableMap dflags) -- Disable when -finfo-table-map is on (#20428) diff --git a/GHC/Driver/Make.hs b/GHC/Driver/Make.hs --- a/GHC/Driver/Make.hs +++ b/GHC/Driver/Make.hs @@ -629,7 +629,7 @@ collapseSCC :: [SCC ModuleGraphNode] -> Either [ModuleGraphNode] [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)] -- Must be at least two nodes, as we were in a cycle collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Right [toNodeWithBoot node1, toNodeWithBoot node2] - collapseSCC (AcyclicSCC node : nodes) = (toNodeWithBoot node :) <$> collapseSCC nodes + collapseSCC (AcyclicSCC node : nodes) = either (Left . (node :)) (Right . (toNodeWithBoot node :)) (collapseSCC nodes) -- Cyclic collapseSCC nodes = Left (flattenSCCs nodes) diff --git a/GHC/Driver/Session.hs b/GHC/Driver/Session.hs --- a/GHC/Driver/Session.hs +++ b/GHC/Driver/Session.hs @@ -3363,7 +3363,8 @@ -- See Note [Updating flag description in the User's Guide] -- See Note [Supporting CLI completion] -- Please keep the list of flags below sorted alphabetically - flagSpec "asm-shortcutting" Opt_AsmShortcutting, + depFlagSpec "asm-shortcutting" Opt_AsmShortcutting + "this flag is disabled on this ghc version due to unsoundness concerns (https://gitlab.haskell.org/ghc/ghc/-/issues/24507)", flagGhciSpec "break-on-error" Opt_BreakOnError, flagGhciSpec "break-on-exception" Opt_BreakOnException, flagSpec "building-cabal-package" Opt_BuildingCabalPackage, @@ -4002,7 +4003,8 @@ , ([1,2], Opt_CaseMerge) , ([1,2], Opt_CaseFolding) , ([1,2], Opt_CmmElimCommonBlocks) - , ([2], Opt_AsmShortcutting) + -- Disabled due to #24507 + -- , ([2], Opt_AsmShortcutting) , ([1,2], Opt_CmmSink) , ([1,2], Opt_CmmStaticPred) , ([1,2], Opt_CSE) diff --git a/GHC/HsToCore/Binds.hs b/GHC/HsToCore/Binds.hs --- a/GHC/HsToCore/Binds.hs +++ b/GHC/HsToCore/Binds.hs @@ -847,7 +847,16 @@ = Left (DsRuleIgnoredDueToConstructor con) -- See Note [No RULES on datacons] | otherwise = case decompose fun2 args2 of - Nothing -> Left (DsRuleLhsTooComplicated orig_lhs lhs2) + Nothing -> -- pprTrace "decomposeRuleLhs 3" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs + -- , text "orig_lhs:" <+> ppr orig_lhs + -- , text "rhs_fvs:" <+> ppr rhs_fvs + -- , text "orig_lhs:" <+> ppr orig_lhs + -- , text "lhs1:" <+> ppr lhs1 + -- , text "lhs2:" <+> ppr lhs2 + -- , text "fun2:" <+> ppr fun2 + -- , text "args2:" <+> ppr args2 + -- ]) $ + Left (DsRuleLhsTooComplicated orig_lhs lhs2) Just (fn_id, args) | not (null unbound) -> -- Check for things unbound on LHS @@ -919,7 +928,9 @@ split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr) split_lets (Let (NonRec d r) body) - | isDictId d + | isDictId d -- Catches dictionaries, yes, but also catches dictionary + -- /functions/ arising from solving a + -- quantified contraint (#24370) = ((d,r):bs, body') where (bs, body') = split_lets body diff --git a/GHC/HsToCore/Foreign/C.hs b/GHC/HsToCore/Foreign/C.hs --- a/GHC/HsToCore/Foreign/C.hs +++ b/GHC/HsToCore/Foreign/C.hs @@ -554,7 +554,7 @@ , ppUnless res_hty_is_unit $ if libffi then char '*' <> parens (ffi_cResType <> char '*') <> - text "resp = cret;" + text "resp = " <> parens ffi_cResType <> text "cret;" else text "return cret;" , rbrace ] diff --git a/GHC/Parser/HaddockLex.hs b/GHC/Parser/HaddockLex.hs --- a/GHC/Parser/HaddockLex.hs +++ b/GHC/Parser/HaddockLex.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 1 "_build/source-dist/ghc-9.6.4-src/ghc-9.6.4/compiler/GHC/Parser/HaddockLex.x" #-} +{-# LINE 1 "_build/source-dist/ghc-9.6.5-src/ghc-9.6.5/compiler/GHC/Parser/HaddockLex.x" #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -funbox-strict-fields #-} @@ -110,7 +110,7 @@ , (0,alex_action_1) ] -{-# LINE 87 "_build/source-dist/ghc-9.6.4-src/ghc-9.6.4/compiler/GHC/Parser/HaddockLex.x" #-} +{-# LINE 87 "_build/source-dist/ghc-9.6.5-src/ghc-9.6.5/compiler/GHC/Parser/HaddockLex.x" #-} data AlexInput = AlexInput { alexInput_position :: !RealSrcLoc , alexInput_string :: !ByteString diff --git a/GHC/Parser/Lexer.hs b/GHC/Parser/Lexer.hs --- a/GHC/Parser/Lexer.hs +++ b/GHC/Parser/Lexer.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 43 "_build/source-dist/ghc-9.6.4-src/ghc-9.6.4/compiler/GHC/Parser/Lexer.x" #-} +{-# LINE 43 "_build/source-dist/ghc-9.6.5-src/ghc-9.6.5/compiler/GHC/Parser/Lexer.x" #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} @@ -592,7 +592,7 @@ , (0,alex_action_86) ] -{-# LINE 704 "_build/source-dist/ghc-9.6.4-src/ghc-9.6.4/compiler/GHC/Parser/Lexer.x" #-} +{-# LINE 704 "_build/source-dist/ghc-9.6.5-src/ghc-9.6.5/compiler/GHC/Parser/Lexer.x" #-} -- Operator whitespace occurrence. See Note [Whitespace-sensitive operator parsing]. data OpWs = OpWsPrefix -- a !b @@ -1281,7 +1281,7 @@ nested_doc_comment :: Action nested_doc_comment span buf _len _buf2 = {-# SCC "nested_doc_comment" #-} withLexedDocType worker where - worker input docType _checkNextLine = nested_comment_logic endComment "" input span + worker input@(AI start_loc _) docType _checkNextLine = nested_comment_logic endComment "" input (mkPsSpan start_loc (psSpanEnd span)) where endComment input lcomment = docCommentEnd input (docType (\d -> NestedDocString d (mkHsDocStringChunk . dropTrailingDec <$> lcomment))) buf span diff --git a/GHC/Settings/IO.hs b/GHC/Settings/IO.hs --- a/GHC/Settings/IO.hs +++ b/GHC/Settings/IO.hs @@ -16,9 +16,11 @@ import GHC.Utils.Fingerprint import GHC.Platform import GHC.Utils.Panic +import GHC.ResponseFile import GHC.Settings import GHC.SysTools.BaseDir +import Data.Char import Control.Monad.Trans.Except import Control.Monad.IO.Class import qualified Data.Map as Map @@ -72,9 +74,13 @@ -- just partially applying those functions and throwing 'Left's; they're -- written in a very portable style to keep ghc-boot light. let getSetting key = either pgmError pure $ - getRawFilePathSetting top_dir settingsFile mySettings key + -- Escape the 'top_dir', to make sure we don't accidentally introduce an + -- unescaped space + getRawFilePathSetting (escapeArg top_dir) settingsFile mySettings key getToolSetting :: String -> ExceptT SettingsError m String - getToolSetting key = expandToolDir useInplaceMinGW mtool_dir <$> getSetting key + -- Escape the 'mtool_dir', to make sure we don't accidentally introduce + -- an unescaped space + getToolSetting key = expandToolDir useInplaceMinGW (fmap escapeArg mtool_dir) <$> getSetting key targetPlatformString <- getSetting "target platform string" myExtraGccViaCFlags <- getSetting "GCC extra via C opts" cc_prog <- getToolSetting "C compiler command" @@ -90,9 +96,9 @@ let unreg_cc_args = if platformUnregisterised platform then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] else [] - cpp_args = map Option (words cpp_args_str) - cc_args = words cc_args_str ++ unreg_cc_args - cxx_args = words cxx_args_str + cpp_args = map Option (unescapeArgs cpp_args_str) + cc_args = unescapeArgs cc_args_str ++ unreg_cc_args + cxx_args = unescapeArgs cxx_args_str ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind" ldSupportsFilelist <- getBooleanSetting "ld supports filelist" ldSupportsSingleModule <- getBooleanSetting "ld supports single module" @@ -128,12 +134,12 @@ let as_prog = cc_prog as_args = map Option cc_args ld_prog = cc_prog - ld_args = map Option (cc_args ++ words cc_link_args_str) + ld_args = map Option (cc_args ++ unescapeArgs cc_link_args_str) ld_r_prog <- getToolSetting "Merge objects command" ld_r_args <- getToolSetting "Merge objects flags" let ld_r | null ld_r_prog = Nothing - | otherwise = Just (ld_r_prog, map Option $ words ld_r_args) + | otherwise = Just (ld_r_prog, map Option $ unescapeArgs ld_r_args) llvmTarget <- getSetting "LLVM target" @@ -254,3 +260,19 @@ , platformHasLibm = targetHasLibm , platform_constants = Nothing -- will be filled later when loading (or building) the RTS unit } + +-- ---------------------------------------------------------------------------- +-- Escape Args helpers +-- ---------------------------------------------------------------------------- + +-- | Just like 'GHC.ResponseFile.escapeArg', but it is not exposed from base. +escapeArg :: String -> String +escapeArg = reverse . foldl' escape [] + +escape :: String -> Char -> String +escape cs c + | isSpace c + || '\\' == c + || '\'' == c + || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result + | otherwise = c:cs diff --git a/GHC/StgToCmm/Bind.hs b/GHC/StgToCmm/Bind.hs --- a/GHC/StgToCmm/Bind.hs +++ b/GHC/StgToCmm/Bind.hs @@ -553,7 +553,13 @@ -- Extend reader monad with information that -- self-recursive tail calls can be optimized into local -- jumps. See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr. - ; withSelfLoop (bndr, loop_header_id, arg_regs) $ do + ; let !self_loop_info = MkSelfLoopInfo + { sli_id = bndr + , sli_arity = arity + , sli_header_block = loop_header_id + , sli_registers = arg_regs + } + ; withSelfLoop self_loop_info $ do { -- Main payload ; entryHeapCheck cl_info node' arity arg_regs $ do diff --git a/GHC/StgToCmm/Closure.hs b/GHC/StgToCmm/Closure.hs --- a/GHC/StgToCmm/Closure.hs +++ b/GHC/StgToCmm/Closure.hs @@ -95,7 +95,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Utils.Misc import Data.Coerce (coerce) import qualified Data.ByteString.Char8 as BS8 @@ -601,12 +600,12 @@ getCallMethod :: StgToCmmConfig -> Name -- Function being applied - -> Id -- Function Id used to chech if it can refer to + -> Id -- Function Id used to check if it can refer to -- CAF's and whether the function is tail-calling -- itself -> LambdaFormInfo -- Its info -> RepArity -- Number of available arguments - -> RepArity -- Number of them being void arguments + -- (including void args) -> CgLoc -- Passed in from cgIdApp so that we can -- handle let-no-escape bindings and self-recursive -- tail calls using the same data constructor, @@ -615,19 +614,22 @@ -> Maybe SelfLoopInfo -- can we perform a self-recursive tail-call -> CallMethod -getCallMethod cfg _ id _ n_args v_args _cg_loc (Just (self_loop_id, block_id, args)) +getCallMethod cfg _ id _ n_args _cg_loc (Just self_loop) | stgToCmmLoopification cfg - , id == self_loop_id - , args `lengthIs` (n_args - v_args) + , MkSelfLoopInfo + { sli_id = loop_id, sli_arity = arity + , sli_header_block = blk_id, sli_registers = arg_regs + } <- self_loop + , id == loop_id + , n_args == arity -- If these patterns match then we know that: -- * loopification optimisation is turned on -- * function is performing a self-recursive call in a tail position - -- * number of non-void parameters of the function matches functions arity. - -- See Note [Self-recursive tail calls] and Note [Void arguments in - -- self-recursive tail calls] in GHC.StgToCmm.Expr for more details - = JumpToIt block_id args + -- * number of parameters matches the function's arity. + -- See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr for more details + = JumpToIt blk_id arg_regs -getCallMethod cfg name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc _self_loop_info +getCallMethod cfg name id (LFReEntrant _ arity _ _) n_args _cg_loc _self_loop_info | n_args == 0 -- No args at all && not (profileIsProfiling (stgToCmmProfile cfg)) -- See Note [Evaluating functions with profiling] in rts/Apply.cmm @@ -635,16 +637,16 @@ | n_args < arity = SlowCall -- Not enough args | otherwise = DirectEntry (enterIdLabel (stgToCmmPlatform cfg) name (idCafInfo id)) arity -getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info +getCallMethod _ _name _ LFUnlifted n_args _cg_loc _self_loop_info = assert (n_args == 0) ReturnIt -getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info +getCallMethod _ _name _ (LFCon _) n_args _cg_loc _self_loop_info = assert (n_args == 0) ReturnIt -- n_args=0 because it'd be ill-typed to apply a saturated -- constructor application to anything getCallMethod cfg name id (LFThunk _ _ updatable std_form_info is_fun) - n_args _v_args _cg_loc _self_loop_info + n_args _cg_loc _self_loop_info | Just sig <- idTagSig_maybe id , isTaggedSig sig -- Infered to be already evaluated by Tag Inference @@ -682,7 +684,7 @@ updatable) 0 -- Imported(Unknown) Ids -getCallMethod cfg name id (LFUnknown might_be_a_function) n_args _v_args _cg_locs _self_loop_info +getCallMethod cfg name id (LFUnknown might_be_a_function) n_args _cg_locs _self_loop_info | n_args == 0 , Just sig <- idTagSig_maybe id , isTaggedSig sig -- Infered to be already evaluated by Tag Inference @@ -699,14 +701,14 @@ EnterIt -- Not a function -- TODO: Redundant with above match? --- getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info +-- getCallMethod _ name _ (LFUnknown False) n_args _cg_loc _self_loop_info -- = assertPpr (n_args == 0) (ppr name <+> ppr n_args) -- EnterIt -- Not a function -getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs) _self_loop_info +getCallMethod _ _name _ LFLetNoEscape _n_args (LneLoc blk_id lne_regs) _self_loop_info = JumpToIt blk_id lne_regs -getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method" +getCallMethod _ _ _ _ _ _ _ = panic "Unknown call method" ----------------------------------------------------------------------------- -- Data types for closure information diff --git a/GHC/StgToCmm/Expr.hs b/GHC/StgToCmm/Expr.hs --- a/GHC/StgToCmm/Expr.hs +++ b/GHC/StgToCmm/Expr.hs @@ -1003,8 +1003,7 @@ fun = idInfoToAmode fun_info lf_info = cg_lf fun_info n_args = length args - v_args = length $ filter (isZeroBitTy . stgArgType) args - case getCallMethod cfg fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop of + case getCallMethod cfg fun_name fun_id lf_info n_args (cg_loc fun_info) self_loop of -- A value in WHNF, so we can just return it. ReturnIt | isZeroBitTy (idType fun_id) -> emitReturn [] @@ -1099,12 +1098,14 @@ -- -- Implementation is spread across a couple of places in the code: -- --- * FCode monad stores additional information in its reader environment --- (stgToCmmSelfLoop field). This information tells us which function can --- tail call itself in an optimized way (it is the function currently --- being compiled), what is the label of a loop header (L1 in example above) --- and information about local registers in which we should arguments --- before making a call (this would be a and b in example above). +-- * FCode monad stores additional information in its reader +-- environment (stgToCmmSelfLoop field). This `SelfLoopInfo` +-- record tells us which function can tail call itself in an +-- optimized way (it is the function currently being compiled), +-- its RepArity, what is the label of its loop header (L1 in +-- example above) and information about which local registers +-- should receive arguments when making a call (this would be a +-- and b in the example above). -- -- * Whenever we are compiling a function, we set that information to reflect -- the fact that function currently being compiled can be jumped to, instead @@ -1128,36 +1129,13 @@ -- of call will be generated. getCallMethod decides to generate a self -- recursive tail call when (a) environment stores information about -- possible self tail-call; (b) that tail call is to a function currently --- being compiled; (c) number of passed non-void arguments is equal to --- function's arity. (d) loopification is turned on via -floopification --- command-line option. +-- being compiled; (c) number of passed arguments is equal to +-- function's unarised arity. (d) loopification is turned on via +-- -floopification command-line option. -- -- * Command line option to turn loopification on and off is implemented in -- DynFlags, then passed to StgToCmmConfig for this phase. --- --- --- Note [Void arguments in self-recursive tail calls] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- State# tokens can get in the way of the loopification optimization as seen in --- #11372. Consider this: --- --- foo :: [a] --- -> (a -> State# s -> (# State s, Bool #)) --- -> State# s --- -> (# State# s, Maybe a #) --- foo [] f s = (# s, Nothing #) --- foo (x:xs) f s = case f x s of --- (# s', b #) -> case b of --- True -> (# s', Just x #) --- False -> foo xs f s' --- --- We would like to compile the call to foo as a local jump instead of a call --- (see Note [Self-recursive tail calls]). However, the generated function has --- an arity of 2 while we apply it to 3 arguments, one of them being of void --- type. Thus, we mustn't count arguments of void type when checking whether --- we can turn a call into a self-recursive jump. --- + emitEnter :: CmmExpr -> FCode ReturnKind emitEnter fun = do diff --git a/GHC/StgToCmm/Heap.hs b/GHC/StgToCmm/Heap.hs --- a/GHC/StgToCmm/Heap.hs +++ b/GHC/StgToCmm/Heap.hs @@ -634,7 +634,7 @@ -- See Note [Self-recursive loop header]. self_loop_info <- getSelfLoop case self_loop_info of - Just (_, loop_header_id, _) + Just MkSelfLoopInfo { sli_header_block = loop_header_id } | checkYield && isJust mb_stk_hwm -> emitLabel loop_header_id _otherwise -> return () diff --git a/GHC/StgToCmm/Monad.hs b/GHC/StgToCmm/Monad.hs --- a/GHC/StgToCmm/Monad.hs +++ b/GHC/StgToCmm/Monad.hs @@ -42,6 +42,8 @@ Sequel(..), ReturnKind(..), withSequel, getSequel, + SelfLoopInfo(..), + setTickyCtrLabel, getTickyCtrLabel, tickScope, getTickScope, @@ -298,7 +300,7 @@ -- else the RTS will deadlock _and_ also experience a severe -- performance degradation , fcs_sequel :: !Sequel -- ^ What to do at end of basic block - , fcs_selfloop :: Maybe SelfLoopInfo -- ^ Which tail calls can be compiled as local jumps? + , fcs_selfloop :: !(Maybe SelfLoopInfo) -- ^ Which tail calls can be compiled as local jumps? -- See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr , fcs_ticky :: !CLabel -- ^ Destination for ticky counts , fcs_tickscope :: !CmmTickScope -- ^ Tick scope for new blocks & ticks diff --git a/GHC/StgToCmm/Sequel.hs b/GHC/StgToCmm/Sequel.hs --- a/GHC/StgToCmm/Sequel.hs +++ b/GHC/StgToCmm/Sequel.hs @@ -12,13 +12,14 @@ module GHC.StgToCmm.Sequel ( Sequel(..) - , SelfLoopInfo + , SelfLoopInfo(..) ) where import GHC.Cmm.BlockId import GHC.Cmm import GHC.Types.Id +import GHC.Types.Basic (RepArity) import GHC.Utils.Outputable import GHC.Prelude @@ -41,5 +42,14 @@ ppr Return = text "Return" ppr (AssignTo regs b) = text "AssignTo" <+> ppr regs <+> ppr b -type SelfLoopInfo = (Id, BlockId, [LocalReg]) +data SelfLoopInfo = MkSelfLoopInfo + { sli_id :: !Id + , sli_arity :: !RepArity + -- ^ always equal to 'idFunRepArity' of sli_id, + -- i.e. unarised arity, including void arguments + , sli_registers :: ![LocalReg] + -- ^ Excludes void arguments (LocalReg is never void) + , sli_header_block :: !BlockId + } + -------------------------------------------------------------------------------- diff --git a/GHC/Utils/Lexeme.hs b/GHC/Utils/Lexeme.hs --- a/GHC/Utils/Lexeme.hs +++ b/GHC/Utils/Lexeme.hs @@ -227,10 +227,11 @@ , "module", "newtype", "of", "then", "type", "where" , "_" ] --- | All reserved operators. Taken from section 2.4 of the 2010 Report. +-- | All reserved operators. Taken from section 2.4 of the 2010 Report, +-- excluding @\@@ and @~@ that are allowed by GHC (see GHC Proposal #229). reservedOps :: Set.Set String reservedOps = Set.fromList [ "..", ":", "::", "=", "\\", "|", "<-", "->" - , "@", "~", "=>" ] + , "=>" ] -- | Does this string contain only dashes and has at least 2 of them? isDashes :: String -> Bool diff --git a/ghc.cabal b/ghc.cabal --- a/ghc.cabal +++ b/ghc.cabal @@ -3,7 +3,7 @@ -- ./configure. Make sure you are editing ghc.cabal.in, not ghc.cabal. Name: ghc -Version: 9.6.4 +Version: 9.6.5 License: BSD-3-Clause License-File: LICENSE Author: The GHC Team @@ -86,9 +86,9 @@ transformers >= 0.5 && < 0.7, exceptions == 0.10.*, stm, - ghc-boot == 9.6.4, - ghc-heap == 9.6.4, - ghci == 9.6.4 + ghc-boot == 9.6.5, + ghc-heap == 9.6.5, + ghci == 9.6.5 if os(windows) Build-Depends: Win32 >= 2.3 && < 2.14