ghc 9.6.4 → 9.6.5

raw patch · 23 files changed

+185/−122 lines, 23 filesdep ~ghc-bootdep ~ghc-heapdep ~ghciPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: ghc-boot, ghc-heap, ghci

API changes (from Hackage documentation)

Files

• GHC.hs +1/−3
• GHC/Builtin/primops.txt.pp +16/−1
• GHC/Cmm/Lexer.hs +2/−2
• GHC/CmmToAsm/Wasm/FromCmm.hs +1/−1
• GHC/Core/Predicate.hs +8/−1
• GHC/Core/Unify.hs +5/−2
• GHC/Data/Graph/Directed.hs +34/−29
• GHC/Driver/Config/CmmToAsm.hs +2/−1
• GHC/Driver/Make.hs +1/−1
• GHC/Driver/Session.hs +4/−2
• GHC/HsToCore/Binds.hs +13/−2
• GHC/HsToCore/Foreign/C.hs +1/−1
• GHC/Parser/HaddockLex.hs +2/−2
• GHC/Parser/Lexer.hs +3/−3
• GHC/Settings/IO.hs +29/−7
• GHC/StgToCmm/Bind.hs +7/−1
• GHC/StgToCmm/Closure.hs +20/−18
• GHC/StgToCmm/Expr.hs +13/−35
• GHC/StgToCmm/Heap.hs +1/−1
• GHC/StgToCmm/Monad.hs +3/−1
• GHC/StgToCmm/Sequel.hs +12/−2
• GHC/Utils/Lexeme.hs +3/−2
• ghc.cabal +4/−4

@@ -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

@@ -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]+    }  ------------------------------------------------------------------------

@@ -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

@@ -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

@@ -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]

@@ -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]

@@ -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 ]

@@ -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)

@@ -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) 

@@ -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)

@@ -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 

@@ -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      ]

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 () 

@@ -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

@@ -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+  }+ --------------------------------------------------------------------------------

@@ -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

@@ -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