- ghc-commits - Haskell.org

[Git][ghc/ghc][master] Split GHC.Driver.Main.hs up into multiple components.
by Marge Bot (＠marge-bot) 30 Apr '26

30 Apr '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 3d41368f by Andreas Klebinger at 2026-04-30T04:55:32-04:00 Split GHC.Driver.Main.hs up into multiple components. This commit splits GHC.Driver.Main into four components: * GHC.Driver.Main.Compile * GHC.Driver.Main.Hsc * GHC.Driver.Main.Interactive * GHC.Driver.Main.Passes We might improve that separation further in the future but this should hopefully make it easier to reason about and work with this part of the code. - - - - - 15 changed files: - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Main.hs - + compiler/GHC/Driver/Main/Compile.hs - compiler/GHC/Driver/Main.hs-boot → compiler/GHC/Driver/Main/Compile.hs-boot - + compiler/GHC/Driver/Main/Hsc.hs - + compiler/GHC/Driver/Main/Interactive.hs - + compiler/GHC/Driver/Main/Passes.hs - + compiler/GHC/Driver/Main/Passes.hs-boot - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Types/Error.hs-boot - compiler/ghc.cabal.in - testsuite/tests/linters/notes.stdout The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3d41368f3c55a23d4fe50bc59ff52c7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3d41368f3c55a23d4fe50bc59ff52c7… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 2 commits: Hadrian: withResponseFile outputs response file when verbodity is Verbose
by Marge Bot (＠marge-bot) 30 Apr '26

30 Apr '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: a4ff6315 by David Eichmann at 2026-04-30T04:54:51-04:00 Hadrian: withResponseFile outputs response file when verbodity is Verbose At the Verbose verbosity, shake will display full commandlines. With the use of response files, the full command is hidden. That makes it hard to run the command manually. This commit outputs the contents of the response file so that that full command can be recreated and also hints at the use of the --keep-response-files hadrian flag. - - - - - cd732ee3 by Duncan Coutts at 2026-04-30T04:54:51-04:00 Use response files for hadrian linking with ghc (support long command lines) In future support for windows dynamic linking, we expect long command lines for linking dll files with ghc. Experiments with dynamic linking the ghc-internal library yielded a link command well over 32kb. We did not encounter this before for static libs, since we already use ar's @file feature (if available, which it is for the llvm toolchain). Co-authored-by: David Eichmann <davide(a)well-typed.com> - - - - - 4 changed files: - hadrian/src/Builder.hs - hadrian/src/Hadrian/Builder.hs - hadrian/src/Hadrian/Utilities.hs - hadrian/src/Settings/Builders/Ghc.hs Changes: ===================================== hadrian/src/Builder.hs ===================================== @@ -345,11 +345,7 @@ instance H.Builder Builder where Haddock BuildPackage -> runHaddock path buildArgs buildInputs - Ghc FindHsDependencies _ -> do - -- Use a response file for ghc -M invocations, to - -- avoid issues with command line size limit on - -- Windows (#26637) - runGhcWithResponse path buildArgs buildInputs + Ghc _ _ -> runGhcWithResponse path buildArgs buildInputs buildOptions HsCpp -> captureStdout @@ -393,14 +389,19 @@ runHaddock haddockPath flagArgs fileInputs = withResponseFile $ \tmp -> do writeFile' tmp $ escapeArgs fileInputs cmd [haddockPath] flagArgs ('@' : tmp) -runGhcWithResponse :: FilePath -> [String] -> [FilePath] -> Action () -runGhcWithResponse ghcPath flagArgs fileInputs = withResponseFile $ \tmp -> do - writeFile' tmp $ escapeArgs fileInputs - -- We can't put the flags in a response file, because some flags - -- require empty arguments (such as the -dep-suffix flag), but - -- that isn't supported yet due to #26560. - cmd [ghcPath] flagArgs ('@' : tmp) - +-- | Use a response file for ghc invocations to avoid issues with command line +-- size limit on Windows (#26637). +runGhcWithResponse :: FilePath -- ^ Path to ghc + -> [String] -- ^ Arguments passed on the command line + -> [FilePath] -- ^ Input file paths (passed via response file) + -> [CmdOption] + -> Action () +runGhcWithResponse ghcPath buildArgs buildInputs buildOptions = withResponseFile $ \tmp -> do + -- We can't put the buildArgs in a response file, because some flags require + -- empty arguments (such as the -dep-suffix flag), but that isn't supported + -- yet due to #26560. + writeFile' tmp (escapeArgs buildInputs) + cmd [ghcPath] buildArgs ('@' : tmp) buildOptions -- TODO: Some builders are required only on certain platforms. For example, -- 'Objdump' is only required on OpenBSD and AIX. Add support for platform ===================================== hadrian/src/Hadrian/Builder.hs ===================================== @@ -29,7 +29,9 @@ import Hadrian.Utilities -- | This data structure captures all information relevant to invoking a builder. data BuildInfo = BuildInfo { - -- | Command line arguments. + -- | Command line arguments. Some builders (e.g. Ar, Ghc, Haddock) omit + -- buildInputs from buildArgs so that buildInputs can be passed separately + -- using a response file. buildArgs :: [String], -- | Input files. buildInputs :: [FilePath], ===================================== hadrian/src/Hadrian/Utilities.hs ===================================== @@ -334,13 +334,23 @@ keepResponseFiles = do withResponseFile :: (FilePath -> Action a) -> Action a withResponseFile action = do keep <- keepResponseFiles + let putVerboseResponseFile tmp = do + verbosity <- getVerbosity + when (verbosity >= Verbose) $ do + tmpContent <- liftIO (readFile tmp) + putVerbose (tmp <> " (use hadrian flag --keep-response-files to keep this file):\n" <> tmpContent) if keep then do (tmp, h) <- liftIO $ openTempFile "." "hadrian-rsp" liftIO $ hClose h putInfo $ "Keeping response file: " ++ tmp - action tmp - else withTempFile action + result <- action tmp + putVerboseResponseFile tmp + return result + else withTempFile $ \tmp -> do + result <- action tmp + putVerboseResponseFile tmp + return result -- | Link a file tracking the link target. Create the target directory if -- missing. ===================================== hadrian/src/Settings/Builders/Ghc.hs ===================================== @@ -62,7 +62,6 @@ compileAndLinkHs = (builder (Ghc CompileHs) ||^ builder (Ghc LinkHs)) ? do [ arg "-fwrite-ide-info" , arg "-hiedir", arg hie_path ] - , getInputs , arg "-o", arg =<< getOutput ] compileC :: Args @@ -78,7 +77,6 @@ compileC = builder (Ghc CompileCWithGhc) ? do , mconcat (map (map ("-optc" ++) <$>) ccArgs) , defaultGhcWarningsArgs , arg "-c" - , getInputs , arg "-o" , arg =<< getOutput ] @@ -95,7 +93,6 @@ compileCxx = builder (Ghc CompileCppWithGhc) ? do , mconcat (map (map ("-optcxx" ++) <$>) ccArgs) , defaultGhcWarningsArgs , arg "-c" - , getInputs , arg "-o" , arg =<< getOutput ] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ce97fd3ed13028034ba27c34a6decd… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ce97fd3ed13028034ba27c34a6decd… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 2 commits: New rts Message to {set,unset} TSO flags
by Marge Bot (＠marge-bot) 30 Apr '26

30 Apr '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 5bd6a964 by Rodrigo Mesquita at 2026-04-30T04:54:08-04:00 New rts Message to {set,unset} TSO flags This commit introduces stg_MSG_SET_TSO_FLAG_info and stg_MSG_UNSET_TSO_FLAG_info, which allows setting flags of a TSO other than yourself. This is especially useful/necessary to set breakpoints and toggle breakpoints of different threads, which is needed to safely implement features like pausing, toggling step-out, toggling step-in per thread, etc. Fixes #27131 ------------------------- Metric Decrease: T3294 ------------------------- - - - - - ce97fd3e by Rodrigo Mesquita at 2026-04-30T04:54:08-04:00 test: Add test setting another TSO's flags Introduces a test that runs on two capabilities. The main thread running on Capability 0 sets the flags on a TSO running on Capability 1. The TSO from Capability 1 itself checks whether its flags were set and reports that back. This validates that the RTS messages for setting TSO flags work, even if it doesn't test a harsher scenario with race conditions to exercise why the message passing is necessary for safely setting another TSO's flags. Part of #27131 - - - - - 12 changed files: - + changelog.d/T27131 - rts/Interpreter.c - rts/Messages.c - rts/StgMiscClosures.cmm - rts/Threads.c - rts/Threads.h - rts/include/rts/storage/Closures.h - rts/include/stg/MiscClosures.h - + testsuite/tests/rts/T27131.hs - + testsuite/tests/rts/T27131.stdout - + testsuite/tests/rts/T27131_c.c - testsuite/tests/rts/all.T Changes: ===================================== changelog.d/T27131 ===================================== @@ -0,0 +1,8 @@ +section: rts +synopsis: Add rts Message to set/unset TSO flags +issues: #27131 +mrs: !15831 +description: This enables e.g. toggling breakpoints from different threads, + which is necessary to safely implement features like pausing, per-thread + step-in, and more in the haskell debugger. + ===================================== rts/Interpreter.c ===================================== @@ -416,12 +416,22 @@ void rts_disableStopNextBreakpointAll(void) void rts_enableStopNextBreakpoint(StgTSO* tso) { - tso->flags |= TSO_STOP_NEXT_BREAKPOINT; +#if defined(THREADED_RTS) + Capability* cap = rts_unsafeGetMyCapability(); + setThreadFlag(cap, tso, TSO_STOP_NEXT_BREAKPOINT); +#else + tso->flags |= TSO_STOP_NEXT_BREAKPOINT; +#endif } void rts_disableStopNextBreakpoint(StgTSO* tso) { - tso->flags &= ~TSO_STOP_NEXT_BREAKPOINT; +#if defined(THREADED_RTS) + Capability* cap = rts_unsafeGetMyCapability(); + unsetThreadFlag(cap, tso, TSO_STOP_NEXT_BREAKPOINT); +#else + tso->flags &= ~TSO_STOP_NEXT_BREAKPOINT; +#endif } /* --------------------------------------------------------------------------- @@ -430,12 +440,22 @@ void rts_disableStopNextBreakpoint(StgTSO* tso) void rts_enableStopAfterReturn(StgTSO* tso) { +#if defined(THREADED_RTS) + Capability* cap = rts_unsafeGetMyCapability(); + setThreadFlag(cap, tso, TSO_STOP_AFTER_RETURN); +#else tso->flags |= TSO_STOP_AFTER_RETURN; +#endif } void rts_disableStopAfterReturn(StgTSO* tso) { +#if defined(THREADED_RTS) + Capability* cap = rts_unsafeGetMyCapability(); + unsetThreadFlag(cap, tso, TSO_STOP_AFTER_RETURN); +#else tso->flags &= ~TSO_STOP_AFTER_RETURN; +#endif } /* ===================================== rts/Messages.c ===================================== @@ -35,7 +35,9 @@ void sendMessage(Capability *from_cap, Capability *to_cap, Message *msg) i != &stg_MSG_TRY_WAKEUP_info && i != &stg_IND_info && // can happen if a MSG_BLACKHOLE is revoked i != &stg_WHITEHOLE_info && - i != &stg_MSG_CLONE_STACK_info) { + i != &stg_MSG_CLONE_STACK_info && + i != &stg_MSG_SET_TSO_FLAG_info && + i != &stg_MSG_UNSET_TSO_FLAG_info) { barf("sendMessage: %p", i); } } @@ -137,6 +139,16 @@ loop: MessageCloneStack *cloneStackMessage = (MessageCloneStack*) m; handleCloneStackMessage(cap, cloneStackMessage); } + else if(i == &stg_MSG_SET_TSO_FLAG_info){ + MessageUpdTSOFlag *u = (MessageUpdTSOFlag*) m; + u->tso->flags |= u->flag; + return; + } + else if(i == &stg_MSG_UNSET_TSO_FLAG_info){ + MessageUpdTSOFlag *u = (MessageUpdTSOFlag*) m; + u->tso->flags &= ~u->flag; + return; + } else { barf("executeMessage: %p", i); ===================================== rts/StgMiscClosures.cmm ===================================== @@ -855,6 +855,12 @@ INFO_TABLE_CONSTR(stg_MSG_NULL,1,0,0,PRIM,"MSG_NULL","MSG_NULL") INFO_TABLE_CONSTR(stg_MSG_CLONE_STACK,3,0,0,PRIM,"MSG_CLONE_STACK","MSG_CLONE_STACK") { ccall pbarf("stg_MSG_CLONE_STACK object (%p) entered!", R1 "ptr") never returns; } +INFO_TABLE_CONSTR(stg_MSG_SET_TSO_FLAG,2,1,0,PRIM,"MSG_SET_TSO_FLAG","MSG_SET_TSO_FLAG") +{ foreign "C" barf("stg_MSG_SET_TSO_FLAG object (%p) entered!", R1) never returns; } + +INFO_TABLE_CONSTR(stg_MSG_UNSET_TSO_FLAG,2,1,0,PRIM,"MSG_UNSET_TSO_FLAG","MSG_UNSET_TSO_FLAG") +{ foreign "C" barf("stg_MSG_UNSET_TSO_FLAG object (%p) entered!", R1) never returns; } + /* ---------------------------------------------------------------------------- END_TSO_QUEUE ===================================== rts/Threads.c ===================================== @@ -376,6 +376,38 @@ migrateThread (Capability *from, StgTSO *tso, Capability *to) tryWakeupThread(from, tso); } +/* ---------------------------------------------------------------------------- + {set,unset}ThreadFlag + + sets or unsets a flag in a given TSO + ------------------------------------------------------------------------- */ + +#if defined(THREADED_RTS) +static void +updThreadFlag(Capability *from, StgTSO *tso, StgWord32 flag, const StgInfoTable* info); + +void setThreadFlag(Capability *from, StgTSO *tso, StgWord32 flag) +{ + updThreadFlag(from, tso, flag, &stg_MSG_SET_TSO_FLAG_info); +} + +void unsetThreadFlag(Capability *from, StgTSO *tso, StgWord32 flag) +{ + updThreadFlag(from, tso, flag, &stg_MSG_UNSET_TSO_FLAG_info); +} + +static void +updThreadFlag(Capability *from, StgTSO *tso, StgWord32 flag, const StgInfoTable* info) +{ + MessageUpdTSOFlag *msg; + msg = (MessageUpdTSOFlag *)allocate(from,sizeofW(MessageUpdTSOFlag)); + msg->tso = tso; + msg->flag = flag; + SET_HDR_RELEASE(msg, info, CCS_SYSTEM); + sendMessage(from, tso->cap, (Message*)msg); +} +#endif + /* ---------------------------------------------------------------------------- awakenBlockedQueue ===================================== rts/Threads.h ===================================== @@ -19,6 +19,11 @@ void checkBlockingQueues (Capability *cap, StgTSO *tso); void tryWakeupThread (Capability *cap, StgTSO *tso); void migrateThread (Capability *from, StgTSO *tso, Capability *to); +#if defined(THREADED_RTS) +void setThreadFlag (Capability *from, StgTSO *tso, StgWord32 flag); +void unsetThreadFlag (Capability *from, StgTSO *tso, StgWord32 flag); +#endif + // Wakes up a thread on a Capability (probably a different Capability // from the one held by the current Task). // ===================================== rts/include/rts/storage/Closures.h ===================================== @@ -620,6 +620,12 @@ typedef struct MessageCloneStack_ { StgTSO *tso; } MessageCloneStack; +typedef struct MessageUpdTSOFlag_ { + StgHeader header; + Message *link; + StgTSO *tso; + StgWord flag; +} MessageUpdTSOFlag; /* ---------------------------------------------------------------------------- Compact Regions ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -152,6 +152,8 @@ RTS_ENTRY(stg_MSG_TRY_WAKEUP); RTS_ENTRY(stg_MSG_THROWTO); RTS_ENTRY(stg_MSG_BLACKHOLE); RTS_ENTRY(stg_MSG_CLONE_STACK); +RTS_ENTRY(stg_MSG_SET_TSO_FLAG); +RTS_ENTRY(stg_MSG_UNSET_TSO_FLAG); RTS_ENTRY(stg_MSG_NULL); RTS_ENTRY(stg_MVAR_TSO_QUEUE); RTS_ENTRY(stg_catch); ===================================== testsuite/tests/rts/T27131.hs ===================================== @@ -0,0 +1,81 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} + +module Main where + +import Control.Concurrent +import Control.Monad +import Foreign.C.Types +import GHC.Conc.Sync (ThreadId(..), forkOn, myThreadId, setNumCapabilities) +import GHC.Exts (ThreadId#) + +foreign import ccall unsafe "rts_enableStopNextBreakpoint" + rts_enableStopNextBreakpoint :: ThreadId# -> IO () + +foreign import ccall unsafe "rts_disableStopNextBreakpoint" + rts_disableStopNextBreakpoint :: ThreadId# -> IO () + +foreign import ccall unsafe "rts_enableStopAfterReturn" + rts_enableStopAfterReturn :: ThreadId# -> IO () + +foreign import ccall unsafe "rts_disableStopAfterReturn" + rts_disableStopAfterReturn :: ThreadId# -> IO () + +foreign import ccall unsafe "has_local_stop_next_breakpoint" + c_hasLocalStopNextBreakpoint :: IO CInt + +foreign import ccall unsafe "has_local_stop_after_return" + c_hasLocalStopAfterReturn :: IO CInt + +main :: IO () +main = do + setNumCapabilities 2 + checkFlag + "TSO_STOP_NEXT_BREAKPOINT" + rts_enableStopNextBreakpoint + rts_disableStopNextBreakpoint + c_hasLocalStopNextBreakpoint + checkFlag + "TSO_STOP_AFTER_RETURN" + rts_enableStopAfterReturn + rts_disableStopAfterReturn + c_hasLocalStopAfterReturn + +checkFlag + :: String + -> (ThreadId# -> IO ()) + -> (ThreadId# -> IO ()) + -> IO CInt + -> IO () +checkFlag label enable disable isMyThreadFlagSet = do + -- Print the main thread's capability (should be 0) + print =<< threadCapability =<< myThreadId + + -- Target thread will write its own flag value here + targetCheckVar <- newEmptyMVar + + -- Run the new TSO runs on capability 1 + ThreadId tid# <- forkOn 1 $ do + replicateM_ 2 $ do + replyVar <- takeMVar targetCheckVar + isSet <- (/= 0) <$> isMyThreadFlagSet + putMVar replyVar isSet + + -- Enable the other TSO's flag + enable tid# + -- It will check whether it is set and reply here + renderCheck label "set" =<< checkTarget targetCheckVar + + -- Ditto. + disable tid# + renderCheck label "unset" . not =<< checkTarget targetCheckVar + +checkTarget :: MVar (MVar Bool) -> IO Bool +checkTarget targetCheckVar = do + replyVar <- newEmptyMVar + putMVar targetCheckVar replyVar + takeMVar replyVar + +renderCheck :: String -> String -> Bool -> IO () +renderCheck label state ok = putStrLn $ + label ++ " " ++ state ++ ": " ++ if ok then "ok" else "failed" ===================================== testsuite/tests/rts/T27131.stdout ===================================== @@ -0,0 +1,6 @@ +(0,False) +TSO_STOP_NEXT_BREAKPOINT set: ok +TSO_STOP_NEXT_BREAKPOINT unset: ok +(0,False) +TSO_STOP_AFTER_RETURN set: ok +TSO_STOP_AFTER_RETURN unset: ok ===================================== testsuite/tests/rts/T27131_c.c ===================================== @@ -0,0 +1,15 @@ +#include "Rts.h" + +int has_local_stop_next_breakpoint(void) +{ + CapabilityPublic *cap = (CapabilityPublic *) rts_unsafeGetMyCapability(); + StgTSO *tso = cap->r.rCurrentTSO; + return (tso->flags & TSO_STOP_NEXT_BREAKPOINT) != 0; +} + +int has_local_stop_after_return(void) +{ + CapabilityPublic *cap = (CapabilityPublic *) rts_unsafeGetMyCapability(); + StgTSO *tso = cap->r.rCurrentTSO; + return (tso->flags & TSO_STOP_AFTER_RETURN) != 0; +} ===================================== testsuite/tests/rts/all.T ===================================== @@ -623,6 +623,13 @@ test('T20201b', [js_skip, exit_code(1)], compile_and_run, ['-with-rtsopts -A64z' test('T22012', [js_skip, extra_ways(['ghci'])], compile_and_run, ['T22012_c.c']) +test('T27131', + [ only_ways(['threaded1', 'threaded2']) + , req_ghc_with_threaded_rts + , req_target_smp + ], + compile_and_run, ['T27131_c.c']) + # Skip for JS platform as the JS RTS is always single threaded test('T22795a', [only_ways(['normal']), js_skip, req_ghc_with_threaded_rts], compile_and_run, ['-threaded']) test('T22795b', [only_ways(['normal']), js_skip], compile_and_run, ['-single-threaded']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d59b7c7109e4d8ef9035ec4b9d9f16… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d59b7c7109e4d8ef9035ec4b9d9f16… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Move code that uses `GHC.Internal.Text.Read` into `base`
by Marge Bot (＠marge-bot) 30 Apr '26

30 Apr '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: d59b7c71 by Wolfgang Jeltsch at 2026-04-30T04:53:25-04:00 Move code that uses `GHC.Internal.Text.Read` into `base` This contribution serves to remove all dependencies on `GHC.Internal.Text.Read` from within `ghc-internal`, so that the implementation of `Text.Read` and ultimately more reading-related code can be moved to `base` as well. The following things are moved from `ghc-internal` to `base`: * I/O-related `Read` instances * Most of the `Numeric` implementation * The instance `Read ByteOrder` * The `parseVersion` operation * The `readConstr` operation Metric Increase: LinkableUsage01 T9198 T12425 T13035 T13820 T18140 - - - - - 21 changed files: - libraries/base/src/Data/Data.hs - libraries/base/src/Data/Version.hs - libraries/base/src/GHC/ByteOrder.hs - libraries/base/src/Numeric.hs - libraries/base/src/System/IO.hs - libraries/base/src/Text/Printf.hs - libraries/ghc-internal/src/GHC/Internal/Data/Data.hs - libraries/ghc-internal/src/GHC/Internal/Data/Version.hs - libraries/ghc-internal/src/GHC/Internal/IO/Device.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Types.hs - libraries/ghc-internal/src/GHC/Internal/IO/IOMode.hs - libraries/ghc-internal/src/GHC/Internal/Numeric.hs - libraries/ghc-internal/src/GHC/Internal/Read.hs - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/plugins/plugins09.stdout - testsuite/tests/plugins/plugins10.stdout - testsuite/tests/plugins/plugins11.stdout - testsuite/tests/plugins/static-plugins.stdout Changes: ===================================== libraries/base/src/Data/Data.hs ===================================== @@ -99,3 +99,38 @@ module Data.Data ( import GHC.Internal.Data.Data import Data.Typeable + +import GHC.Real (toRational) +import GHC.Float (Double) +import Data.Eq ((==)) +import Data.Function ((.)) +import Data.Maybe (Maybe (Nothing, Just)) +import Data.List (filter) +import Data.String (String) +import Text.Read (Read, reads) + +-- | Lookup a constructor via a string +readConstr :: DataType -> String -> Maybe Constr +readConstr dt str = + case dataTypeRep dt of + AlgRep cons -> idx cons + IntRep -> mkReadCon (\i -> (mkPrimCon dt str (IntConstr i))) + FloatRep -> mkReadCon ffloat + CharRep -> mkReadCon (\c -> (mkPrimCon dt str (CharConstr c))) + NoRep -> Nothing + where + + -- Read a value and build a constructor + mkReadCon :: Read t => (t -> Constr) -> Maybe Constr + mkReadCon f = case (reads str) of + [(t,"")] -> Just (f t) + _ -> Nothing + + -- Traverse list of algebraic datatype constructors + idx :: [Constr] -> Maybe Constr + idx cons = case filter ((==) str . showConstr) cons of + [] -> Nothing + hd : _ -> Just hd + + ffloat :: Double -> Constr + ffloat = mkPrimCon dt str . FloatConstr . toRational ===================================== libraries/base/src/Data/Version.hs ===================================== @@ -1,5 +1,9 @@ {-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + -- | -- Module : Data.Version -- Copyright : (c) The University of Glasgow 2004 @@ -33,3 +37,25 @@ module Data.Version ( ) where import GHC.Internal.Data.Version + +import Control.Applicative (pure, (*>)) +import Data.Functor (fmap) +import Data.Char (isDigit, isAlphaNum) +import Text.ParserCombinators.ReadP (ReadP, char, munch1, sepBy1, many) +import Text.Read (Read, read) + +{-NOTE: + The following instance is technically an orphan, but practically it is not, + since ordinary users should not use @ghc-internal@ directly and thus get + 'Version' only through this module. +-} + +-- | @since base-2.01 +deriving instance Read Version + +-- | A parser for versions in the format produced by 'showVersion'. +-- +parseVersion :: ReadP Version +parseVersion = do branch <- sepBy1 (fmap read (munch1 isDigit)) (char '.') + tags <- many (char '-' *> munch1 isAlphaNum) + pure (Version branch tags) ===================================== libraries/base/src/GHC/ByteOrder.hs ===================================== @@ -1,5 +1,9 @@ {-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + -- | -- -- Module : GHC.ByteOrder @@ -19,4 +23,15 @@ module GHC.ByteOrder targetByteOrder ) where -import GHC.Internal.ByteOrder \ No newline at end of file +import GHC.Internal.ByteOrder + +import Text.Read + +{-NOTE: + The following instance is technically an orphan, but practically it is not, + since ordinary users should not use @ghc-internal@ directly and thus get + 'ByteOrder' only through this module. +-} + +-- | @since base-4.11.0.0 +deriving instance Read ByteOrder ===================================== libraries/base/src/Numeric.hs ===================================== @@ -1,4 +1,6 @@ -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ImportQualifiedPost #-} -- | -- @@ -48,3 +50,279 @@ module Numeric ) where import GHC.Internal.Numeric + +import GHC.Types (Char (C#)) +import GHC.Err (error, errorWithoutStackTrace) +import GHC.Base (unsafeChr) +import GHC.Num (Num, (+), (-), (*)) +import GHC.Real + ( + Integral, + Real, + RealFrac, + fromIntegral, + fromRational, + quotRem, + showSigned + ) +import GHC.Float + ( + Floating (..), + RealFloat, + Float, + Double, + isNegativeZero, + isInfinite, + isNaN, + fromRat, + floatToDigits, + FFFormat (FFExponent, FFFixed, FFGeneric), + formatRealFloat, + formatRealFloatAlt, + showFloat + ) +import GHC.Read (lexDigits) +import Control.Monad (return) +import Data.Eq (Eq, (==)) +import Data.Ord ((<)) +import Data.Function (($), (.)) +import Data.Bool (Bool (False, True), otherwise, (||), (&&)) +import Data.Maybe (Maybe) +import Data.List ((++)) +import Data.Char (ord, intToDigit) +import Data.Int (Int) +import Text.ParserCombinators.ReadP (ReadP, pfail, readP_to_S) +import Text.Read (ReadS, readParen, lex) +import Text.Read.Lex qualified as L + ( + Lexeme (Number), + lex, + numberToRational, + readIntP, + readBinP, + readOctP, + readDecP, + readHexP + ) +import Text.Show (ShowS, show, showString) + +-- $setup +-- >>> import Prelude + +-- ----------------------------------------------------------------------------- +-- Reading + +-- | Reads an /unsigned/ integral value in an arbitrary base. +readInt :: Num a + => a -- ^ the base + -> (Char -> Bool) -- ^ a predicate distinguishing valid digits in this base + -> (Char -> Int) -- ^ a function converting a valid digit character to an 'Int' + -> ReadS a +readInt base isDigit valDigit = readP_to_S (L.readIntP base isDigit valDigit) + +-- | Read an unsigned number in binary notation. +-- +-- >>> readBin "10011" +-- [(19,"")] +readBin :: (Eq a, Num a) => ReadS a +readBin = readP_to_S L.readBinP + +-- | Read an unsigned number in octal notation. +-- +-- >>> readOct "0644" +-- [(420,"")] +readOct :: (Eq a, Num a) => ReadS a +readOct = readP_to_S L.readOctP + +-- | Read an unsigned number in decimal notation. +-- +-- >>> readDec "0644" +-- [(644,"")] +readDec :: (Eq a, Num a) => ReadS a +readDec = readP_to_S L.readDecP + +-- | Read an unsigned number in hexadecimal notation. +-- Both upper or lower case letters are allowed. +-- +-- >>> readHex "deadbeef" +-- [(3735928559,"")] +readHex :: (Eq a, Num a) => ReadS a +readHex = readP_to_S L.readHexP + +-- | Reads an /unsigned/ 'RealFrac' value, +-- expressed in decimal scientific notation. +-- +-- Note that this function takes time linear in the magnitude of its input +-- which can scale exponentially with input size (e.g. @"1e100000000"@ is a +-- very large number while having a very small textual form). +-- For this reason, users should take care to avoid using this function on +-- untrusted input. Users needing to parse floating point values +-- (e.g. 'Float') are encouraged to instead use 'read', which does +-- not suffer from this issue. +readFloat :: RealFrac a => ReadS a +readFloat = readP_to_S readFloatP + +readFloatP :: RealFrac a => ReadP a +readFloatP = + do tok <- L.lex + case tok of + L.Number n -> return $ fromRational $ L.numberToRational n + _ -> pfail + +-- It's turgid to have readSigned work using list comprehensions, +-- but it's specified as a ReadS to ReadS transformer +-- With a bit of luck no one will use it. + +-- | Reads a /signed/ 'Real' value, given a reader for an unsigned value. +readSigned :: (Real a) => ReadS a -> ReadS a +readSigned readPos = readParen False read' + where read' r = read'' r ++ + (do + ("-",s) <- lex r + (x,t) <- read'' s + return (-x,t)) + read'' r = do + (str,s) <- lex r + (n,"") <- readPos str + return (n,s) + +-- ----------------------------------------------------------------------------- +-- Showing + +-- | Show /non-negative/ 'Integral' numbers in base 10. +showInt :: Integral a => a -> ShowS +showInt n0 cs0 + | n0 < 0 = errorWithoutStackTrace "GHC.Internal.Numeric.showInt: can't show negative numbers" + | otherwise = go n0 cs0 + where + go n cs + | n < 10 = case unsafeChr (ord '0' + fromIntegral n) of + c@(C# _) -> c:cs + | otherwise = case unsafeChr (ord '0' + fromIntegral r) of + c@(C# _) -> go q (c:cs) + where + (q,r) = n `quotRem` 10 + +-- Controlling the format and precision of floats. The code that +-- implements the formatting itself is in @PrelNum@ to avoid +-- mutual module deps. + +{-# SPECIALIZE showEFloat :: + Maybe Int -> Float -> ShowS #-} +{-# SPECIALIZE showEFloat :: + Maybe Int -> Double -> ShowS #-} +{-# SPECIALIZE showFFloat :: + Maybe Int -> Float -> ShowS #-} +{-# SPECIALIZE showFFloat :: + Maybe Int -> Double -> ShowS #-} +{-# SPECIALIZE showGFloat :: + Maybe Int -> Float -> ShowS #-} +{-# SPECIALIZE showGFloat :: + Maybe Int -> Double -> ShowS #-} + +-- | Show a signed 'RealFloat' value +-- using scientific (exponential) notation (e.g. @2.45e2@, @1.5e-3@). +-- +-- In the call @'showEFloat' digs val@, if @digs@ is 'Nothing', +-- the value is shown to full precision; if @digs@ is @'Just' d@, +-- then at most @d@ digits after the decimal point are shown. +showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS + +-- | Show a signed 'RealFloat' value +-- using standard decimal notation (e.g. @245000@, @0.0015@). +-- +-- In the call @'showFFloat' digs val@, if @digs@ is 'Nothing', +-- the value is shown to full precision; if @digs@ is @'Just' d@, +-- then at most @d@ digits after the decimal point are shown. +showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS + +-- | Show a signed 'RealFloat' value +-- using standard decimal notation for arguments whose absolute value lies +-- between @0.1@ and @9,999,999@, and scientific notation otherwise. +-- +-- In the call @'showGFloat' digs val@, if @digs@ is 'Nothing', +-- the value is shown to full precision; if @digs@ is @'Just' d@, +-- then at most @d@ digits after the decimal point are shown. +showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS + +showEFloat d x = showString (formatRealFloat FFExponent d x) +showFFloat d x = showString (formatRealFloat FFFixed d x) +showGFloat d x = showString (formatRealFloat FFGeneric d x) + +-- | Show a signed 'RealFloat' value +-- using standard decimal notation (e.g. @245000@, @0.0015@). +-- +-- This behaves as 'showFFloat', except that a decimal point +-- is always guaranteed, even if not needed. +-- +-- @since base-4.7.0.0 +showFFloatAlt :: (RealFloat a) => Maybe Int -> a -> ShowS + +-- | Show a signed 'RealFloat' value +-- using standard decimal notation for arguments whose absolute value lies +-- between @0.1@ and @9,999,999@, and scientific notation otherwise. +-- +-- This behaves as 'showFFloat', except that a decimal point +-- is always guaranteed, even if not needed. +-- +-- @since base-4.7.0.0 +showGFloatAlt :: (RealFloat a) => Maybe Int -> a -> ShowS + +showFFloatAlt d x = showString (formatRealFloatAlt FFFixed d True x) +showGFloatAlt d x = showString (formatRealFloatAlt FFGeneric d True x) + +{- | Show a floating-point value in the hexadecimal format, +similar to the @%a@ specifier in C's printf. + + >>> showHFloat (212.21 :: Double) "" + "0x1.a86b851eb851fp7" + >>> showHFloat (-12.76 :: Float) "" + "-0x1.9851ecp3" + >>> showHFloat (-0 :: Double) "" + "-0x0p+0" + +@since base-4.11.0.0 +-} +showHFloat :: RealFloat a => a -> ShowS +showHFloat = showString . fmt + where + fmt x + | isNaN x = "NaN" + | isInfinite x = (if x < 0 then "-" else "") ++ "Infinity" + | x < 0 || isNegativeZero x = '-' : cvt (-x) + | otherwise = cvt x + + cvt x + | x == 0 = "0x0p+0" + | otherwise = + case floatToDigits 2 x of + r@([], _) -> error $ "Impossible happened: showHFloat: " ++ show r + (d:ds, e) -> "0x" ++ show d ++ frac ds ++ "p" ++ show (e-1) + + -- Given binary digits, convert them to hex in blocks of 4 + -- Special case: If all 0's, just drop it. + frac digits + | allZ digits = "" + | otherwise = "." ++ hex digits + where + hex ds = + case ds of + [] -> "" + [a] -> hexDigit a 0 0 0 "" + [a,b] -> hexDigit a b 0 0 "" + [a,b,c] -> hexDigit a b c 0 "" + a : b : c : d : r -> hexDigit a b c d (hex r) + + hexDigit a b c d = showHex (8*a + 4*b + 2*c + d) + + allZ xs = case xs of + x : more -> x == 0 && allZ more + [] -> True + +-- | Show /non-negative/ 'Integral' numbers in base 8. +showOct :: Integral a => a -> ShowS +showOct = showIntAtBase 8 intToDigit + +-- | Show /non-negative/ 'Integral' numbers in base 2. +showBin :: Integral a => a -> ShowS +showBin = showIntAtBase 2 intToDigit ===================================== libraries/base/src/System/IO.hs ===================================== @@ -1,5 +1,8 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE StandaloneDeriving #-} + +{-# OPTIONS_GHC -Wno-orphans #-} -- | -- @@ -895,3 +898,24 @@ rw_flags = output_flags .|. o_RDWR -- output -- > input^D -- output + +{-NOTE: + The following instances are technically orphans, but practically they are + not, since ordinary users should not use @ghc-internal@ directly and thus + get the instantiated types only through this module. +-} + +-- | @since base-4.2.0.0 +deriving instance Read IOMode + +-- | @since base-4.2.0.0 +deriving instance Read BufferMode + +-- | @since base-4.2.0.0 +deriving instance Read SeekMode + +-- | @since base-4.3.0.0 +deriving instance Read Newline + +-- | @since base-4.3.0.0 +deriving instance Read NewlineMode ===================================== libraries/base/src/Text/Printf.hs ===================================== @@ -97,8 +97,8 @@ import Data.Char import GHC.Internal.Int import GHC.Internal.Data.List (stripPrefix) import GHC.Internal.Word -import GHC.Internal.Numeric import GHC.Internal.Numeric.Natural +import Numeric import System.IO -- $setup ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Data.hs ===================================== @@ -61,6 +61,7 @@ module GHC.Internal.Data.Data ( mkIntType, mkFloatType, mkCharType, + mkPrimCon, mkNoRepType, -- ** Observers dataTypeName, @@ -94,7 +95,6 @@ module GHC.Internal.Data.Data ( constrIndex, -- ** From strings to constructors and vice versa: all data types showConstr, - readConstr, -- * Convenience functions: take type constructors apart tyconUQname, @@ -126,10 +126,8 @@ import GHC.Internal.Base ( import GHC.Internal.Err (errorWithoutStackTrace) import GHC.Internal.List import GHC.Internal.Num -import GHC.Internal.Read import GHC.Internal.Show import GHC.Internal.Tuple (Solo (..)) -import GHC.Internal.Text.Read( reads ) import GHC.Internal.Types ( Bool(..), Char, Coercible, Float, Double, Type, type (~), type (~~), ) @@ -688,32 +686,6 @@ showConstr :: Constr -> String showConstr = constring --- | Lookup a constructor via a string -readConstr :: DataType -> String -> Maybe Constr -readConstr dt str = - case dataTypeRep dt of - AlgRep cons -> idx cons - IntRep -> mkReadCon (\i -> (mkPrimCon dt str (IntConstr i))) - FloatRep -> mkReadCon ffloat - CharRep -> mkReadCon (\c -> (mkPrimCon dt str (CharConstr c))) - NoRep -> Nothing - where - - -- Read a value and build a constructor - mkReadCon :: Read t => (t -> Constr) -> Maybe Constr - mkReadCon f = case (reads str) of - [(t,"")] -> Just (f t) - _ -> Nothing - - -- Traverse list of algebraic datatype constructors - idx :: [Constr] -> Maybe Constr - idx cons = case filter ((==) str . showConstr) cons of - [] -> Nothing - hd : _ -> Just hd - - ffloat :: Double -> Constr - ffloat = mkPrimCon dt str . FloatConstr . toRational - ------------------------------------------------------------------------------ -- -- Convenience functions: algebraic data types ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Version.hs ===================================== @@ -10,7 +10,7 @@ -- -- Maintainer : libraries(a)haskell.org -- Stability : stable --- Portability : non-portable (local universal quantification in ReadP) +-- Portability : non-portable -- -- A general library for representation and manipulation of versions. -- @@ -31,23 +31,17 @@ module GHC.Internal.Data.Version ( -- * The @Version@ type Version(..), -- * A concrete representation of @Version@ - showVersion, parseVersion, + showVersion, -- * Constructor function makeVersion ) where -import GHC.Internal.Classes ( Eq(..), (&&) ) -import GHC.Internal.Data.Functor ( Functor(..) ) +import GHC.Internal.Classes ( Eq ((==)), (&&) ) import GHC.Internal.Int ( Int ) import GHC.Internal.Data.List ( map, sort, concat, concatMap, intersperse, (++) ) import GHC.Internal.Data.Ord import GHC.Internal.Data.String ( String ) -import GHC.Internal.Base ( Applicative(..) ) -import GHC.Internal.Unicode ( isDigit, isAlphaNum ) -import GHC.Internal.Read import GHC.Internal.Show -import GHC.Internal.Text.ParserCombinators.ReadP -import GHC.Internal.Text.Read ( read ) {- | A 'Version' represents the version of a software entity. @@ -69,8 +63,8 @@ operations are the right thing for every 'Version'. Similarly, concrete representations of versions may differ. One possible concrete representation is provided (see 'showVersion' and -'parseVersion'), but depending on the application a different concrete -representation may be more appropriate. +'Data.Version.parseVersion'), but depending on the application a +different concrete representation may be more appropriate. -} data Version = Version { versionBranch :: [Int], @@ -92,8 +86,7 @@ data Version = -- The interpretation of the list of tags is entirely dependent -- on the entity that this version applies to. } - deriving ( Read -- ^ @since base-2.01 - , Show -- ^ @since base-2.01 + deriving ( Show -- ^ @since base-2.01 ) {-# DEPRECATED versionTags "See GHC ticket #2496" #-} -- TODO. Remove all references to versionTags in GHC 8.0 release. @@ -120,13 +113,6 @@ showVersion (Version branch tags) = concat (intersperse "." (map show branch)) ++ concatMap ('-':) tags --- | A parser for versions in the format produced by 'showVersion'. --- -parseVersion :: ReadP Version -parseVersion = do branch <- sepBy1 (fmap read (munch1 isDigit)) (char '.') - tags <- many (char '-' *> munch1 isAlphaNum) - pure Version{versionBranch=branch, versionTags=tags} - -- | Construct tag-less 'Version' -- -- @since base-4.8.0.0 ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Device.hs ===================================== @@ -34,7 +34,6 @@ import GHC.Internal.Types ( Bool(..), Int ) import GHC.Internal.Word import GHC.Internal.Arr import GHC.Internal.Enum -import GHC.Internal.Read import GHC.Internal.Show import GHC.Internal.Ptr import GHC.Internal.Num @@ -182,7 +181,6 @@ data SeekMode , Ord -- ^ @since base-4.2.0.0 , Ix -- ^ @since base-4.2.0.0 , Enum -- ^ @since base-4.2.0.0 - , Read -- ^ @since base-4.2.0.0 , Show -- ^ @since base-4.2.0.0 ) ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Handle/Types.hs ===================================== @@ -50,7 +50,6 @@ import GHC.Internal.IO.BufferedIO import GHC.Internal.IO.Encoding.Types import GHC.Internal.IORef import GHC.Internal.Show -import GHC.Internal.Read import GHC.Internal.Types (Bool(..), Int) import GHC.Internal.Word import GHC.Internal.IO.Device @@ -273,7 +272,6 @@ data BufferMode -- is 'Just' @n@ and is otherwise implementation-dependent. deriving ( Eq -- ^ @since base-4.2.0.0 , Ord -- ^ @since base-4.2.0.0 - , Read -- ^ @since base-4.2.0.0 , Show -- ^ @since base-4.2.0.0 ) @@ -379,7 +377,6 @@ data Newline = LF -- ^ @\'\\n\'@ | CRLF -- ^ @\'\\r\\n\'@ deriving ( Eq -- ^ @since base-4.2.0.0 , Ord -- ^ @since base-4.3.0.0 - , Read -- ^ @since base-4.3.0.0 , Show -- ^ @since base-4.3.0.0 ) @@ -396,7 +393,6 @@ data NewlineMode } deriving ( Eq -- ^ @since base-4.2.0.0 , Ord -- ^ @since base-4.3.0.0 - , Read -- ^ @since base-4.3.0.0 , Show -- ^ @since base-4.3.0.0 ) ===================================== libraries/ghc-internal/src/GHC/Internal/IO/IOMode.hs ===================================== @@ -20,7 +20,6 @@ module GHC.Internal.IO.IOMode (IOMode(..)) where import GHC.Internal.Classes (Eq, Ord) import GHC.Internal.Show -import GHC.Internal.Read import GHC.Internal.Arr import GHC.Internal.Enum @@ -30,7 +29,6 @@ data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode , Ord -- ^ @since base-4.2.0.0 , Ix -- ^ @since base-4.2.0.0 , Enum -- ^ @since base-4.2.0.0 - , Read -- ^ @since base-4.2.0.0 , Show -- ^ @since base-4.2.0.0 ) ===================================== libraries/ghc-internal/src/GHC/Internal/Numeric.hs ===================================== @@ -1,5 +1,4 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE NoImplicitPrelude, MagicHash #-} ----------------------------------------------------------------------------- -- | @@ -16,279 +15,16 @@ -- ----------------------------------------------------------------------------- -module GHC.Internal.Numeric ( +module GHC.Internal.Numeric (showIntAtBase, showHex) where - -- * Showing - - showSigned, - - showIntAtBase, - showInt, - showBin, - showHex, - showOct, - - showEFloat, - showFFloat, - showGFloat, - showFFloatAlt, - showGFloatAlt, - showFloat, - showHFloat, - - floatToDigits, - - -- * Reading - - -- | /NB:/ 'readInt' is the \'dual\' of 'showIntAtBase', - -- and 'readDec' is the \`dual\' of 'showInt'. - -- The inconsistent naming is a historical accident. - - readSigned, - - readInt, - readBin, - readDec, - readOct, - readHex, - - readFloat, - - lexDigits, - - -- * Miscellaneous - - fromRat, - Floating(..) - - ) where - -import GHC.Internal.Base (ord, otherwise, return, unsafeChr, ($), (.), (++)) -import GHC.Internal.Classes (Eq(..), Ord(..), (&&), (||)) -import GHC.Internal.Err (error, errorWithoutStackTrace) -import GHC.Internal.Maybe (Maybe(..)) import GHC.Internal.Prim (seq) -import GHC.Internal.Read -import GHC.Internal.Real -import GHC.Internal.Float -import GHC.Internal.Num -import GHC.Internal.Show -import GHC.Internal.Text.ParserCombinators.ReadP( ReadP, readP_to_S, pfail ) -import qualified GHC.Internal.Text.Read.Lex as L -import GHC.Internal.Types (Bool(..), Char(..), Int) - --- $setup --- >>> import Prelude - --- ----------------------------------------------------------------------------- --- Reading - --- | Reads an /unsigned/ integral value in an arbitrary base. -readInt :: Num a - => a -- ^ the base - -> (Char -> Bool) -- ^ a predicate distinguishing valid digits in this base - -> (Char -> Int) -- ^ a function converting a valid digit character to an 'Int' - -> ReadS a -readInt base isDigit valDigit = readP_to_S (L.readIntP base isDigit valDigit) - --- | Read an unsigned number in binary notation. --- --- >>> readBin "10011" --- [(19,"")] -readBin :: (Eq a, Num a) => ReadS a -readBin = readP_to_S L.readBinP - --- | Read an unsigned number in octal notation. --- --- >>> readOct "0644" --- [(420,"")] -readOct :: (Eq a, Num a) => ReadS a -readOct = readP_to_S L.readOctP - --- | Read an unsigned number in decimal notation. --- --- >>> readDec "0644" --- [(644,"")] -readDec :: (Eq a, Num a) => ReadS a -readDec = readP_to_S L.readDecP - --- | Read an unsigned number in hexadecimal notation. --- Both upper or lower case letters are allowed. --- --- >>> readHex "deadbeef" --- [(3735928559,"")] -readHex :: (Eq a, Num a) => ReadS a -readHex = readP_to_S L.readHexP - --- | Reads an /unsigned/ 'RealFrac' value, --- expressed in decimal scientific notation. --- --- Note that this function takes time linear in the magnitude of its input --- which can scale exponentially with input size (e.g. @"1e100000000"@ is a --- very large number while having a very small textual form). --- For this reason, users should take care to avoid using this function on --- untrusted input. Users needing to parse floating point values --- (e.g. 'Float') are encouraged to instead use 'read', which does --- not suffer from this issue. -readFloat :: RealFrac a => ReadS a -readFloat = readP_to_S readFloatP - -readFloatP :: RealFrac a => ReadP a -readFloatP = - do tok <- L.lex - case tok of - L.Number n -> return $ fromRational $ L.numberToRational n - _ -> pfail - --- It's turgid to have readSigned work using list comprehensions, --- but it's specified as a ReadS to ReadS transformer --- With a bit of luck no one will use it. - --- | Reads a /signed/ 'Real' value, given a reader for an unsigned value. -readSigned :: (Real a) => ReadS a -> ReadS a -readSigned readPos = readParen False read' - where read' r = read'' r ++ - (do - ("-",s) <- lex r - (x,t) <- read'' s - return (-x,t)) - read'' r = do - (str,s) <- lex r - (n,"") <- readPos str - return (n,s) - --- ----------------------------------------------------------------------------- --- Showing - --- | Show /non-negative/ 'Integral' numbers in base 10. -showInt :: Integral a => a -> ShowS -showInt n0 cs0 - | n0 < 0 = errorWithoutStackTrace "GHC.Internal.Numeric.showInt: can't show negative numbers" - | otherwise = go n0 cs0 - where - go n cs - | n < 10 = case unsafeChr (ord '0' + fromIntegral n) of - c@(C# _) -> c:cs - | otherwise = case unsafeChr (ord '0' + fromIntegral r) of - c@(C# _) -> go q (c:cs) - where - (q,r) = n `quotRem` 10 - --- Controlling the format and precision of floats. The code that --- implements the formatting itself is in @PrelNum@ to avoid --- mutual module deps. - -{-# SPECIALIZE showEFloat :: - Maybe Int -> Float -> ShowS #-} -{-# SPECIALIZE showEFloat :: - Maybe Int -> Double -> ShowS #-} -{-# SPECIALIZE showFFloat :: - Maybe Int -> Float -> ShowS #-} -{-# SPECIALIZE showFFloat :: - Maybe Int -> Double -> ShowS #-} -{-# SPECIALIZE showGFloat :: - Maybe Int -> Float -> ShowS #-} -{-# SPECIALIZE showGFloat :: - Maybe Int -> Double -> ShowS #-} - --- | Show a signed 'RealFloat' value --- using scientific (exponential) notation (e.g. @2.45e2@, @1.5e-3@). --- --- In the call @'showEFloat' digs val@, if @digs@ is 'Nothing', --- the value is shown to full precision; if @digs@ is @'Just' d@, --- then at most @d@ digits after the decimal point are shown. -showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS - --- | Show a signed 'RealFloat' value --- using standard decimal notation (e.g. @245000@, @0.0015@). --- --- In the call @'showFFloat' digs val@, if @digs@ is 'Nothing', --- the value is shown to full precision; if @digs@ is @'Just' d@, --- then at most @d@ digits after the decimal point are shown. -showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS - --- | Show a signed 'RealFloat' value --- using standard decimal notation for arguments whose absolute value lies --- between @0.1@ and @9,999,999@, and scientific notation otherwise. --- --- In the call @'showGFloat' digs val@, if @digs@ is 'Nothing', --- the value is shown to full precision; if @digs@ is @'Just' d@, --- then at most @d@ digits after the decimal point are shown. -showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS - -showEFloat d x = showString (formatRealFloat FFExponent d x) -showFFloat d x = showString (formatRealFloat FFFixed d x) -showGFloat d x = showString (formatRealFloat FFGeneric d x) - --- | Show a signed 'RealFloat' value --- using standard decimal notation (e.g. @245000@, @0.0015@). --- --- This behaves as 'showFFloat', except that a decimal point --- is always guaranteed, even if not needed. --- --- @since base-4.7.0.0 -showFFloatAlt :: (RealFloat a) => Maybe Int -> a -> ShowS - --- | Show a signed 'RealFloat' value --- using standard decimal notation for arguments whose absolute value lies --- between @0.1@ and @9,999,999@, and scientific notation otherwise. --- --- This behaves as 'showFFloat', except that a decimal point --- is always guaranteed, even if not needed. --- --- @since base-4.7.0.0 -showGFloatAlt :: (RealFloat a) => Maybe Int -> a -> ShowS - -showFFloatAlt d x = showString (formatRealFloatAlt FFFixed d True x) -showGFloatAlt d x = showString (formatRealFloatAlt FFGeneric d True x) - -{- | Show a floating-point value in the hexadecimal format, -similar to the @%a@ specifier in C's printf. - - >>> showHFloat (212.21 :: Double) "" - "0x1.a86b851eb851fp7" - >>> showHFloat (-12.76 :: Float) "" - "-0x1.9851ecp3" - >>> showHFloat (-0 :: Double) "" - "-0x0p+0" - -@since base-4.11.0.0 --} -showHFloat :: RealFloat a => a -> ShowS -showHFloat = showString . fmt - where - fmt x - | isNaN x = "NaN" - | isInfinite x = (if x < 0 then "-" else "") ++ "Infinity" - | x < 0 || isNegativeZero x = '-' : cvt (-x) - | otherwise = cvt x - - cvt x - | x == 0 = "0x0p+0" - | otherwise = - case floatToDigits 2 x of - r@([], _) -> error $ "Impossible happened: showHFloat: " ++ show r - (d:ds, e) -> "0x" ++ show d ++ frac ds ++ "p" ++ show (e-1) - - -- Given binary digits, convert them to hex in blocks of 4 - -- Special case: If all 0's, just drop it. - frac digits - | allZ digits = "" - | otherwise = "." ++ hex digits - where - hex ds = - case ds of - [] -> "" - [a] -> hexDigit a 0 0 0 "" - [a,b] -> hexDigit a b 0 0 "" - [a,b,c] -> hexDigit a b c 0 "" - a : b : c : d : r -> hexDigit a b c d (hex r) - - hexDigit a b c d = showHex (8*a + 4*b + 2*c + d) - - allZ xs = case xs of - x : more -> x == 0 && allZ more - [] -> True +import GHC.Internal.Types (Char, Int) +import GHC.Internal.Classes ((<), (<=)) +import GHC.Internal.Err (errorWithoutStackTrace) +import GHC.Internal.Base (($), otherwise) +import GHC.Internal.List ((++)) +import GHC.Internal.Real (Integral, toInteger, fromIntegral, quotRem) +import GHC.Internal.Show (ShowS, show, intToDigit) -- --------------------------------------------------------------------------- -- Integer printing functions @@ -312,11 +48,3 @@ showIntAtBase base toChr n0 r0 -- | Show /non-negative/ 'Integral' numbers in base 16. showHex :: Integral a => a -> ShowS showHex = showIntAtBase 16 intToDigit - --- | Show /non-negative/ 'Integral' numbers in base 8. -showOct :: Integral a => a -> ShowS -showOct = showIntAtBase 8 intToDigit - --- | Show /non-negative/ 'Integral' numbers in base 2. -showBin :: Integral a => a -> ShowS -showBin = showIntAtBase 2 intToDigit ===================================== libraries/ghc-internal/src/GHC/Internal/Read.hs ===================================== @@ -80,7 +80,6 @@ import GHC.Internal.Types (Bool(..), Char, Int, Ordering(..)) import GHC.Internal.Word import GHC.Internal.List (filter) import GHC.Internal.Tuple (Solo (..)) -import GHC.Internal.ByteOrder -- | @'readParen' 'True' p@ parses what @p@ parses, but surrounded with @@ -840,6 +839,3 @@ instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h, ; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) }) readListPrec = readListPrecDefault readList = readListDefault - --- | @since base-4.11.0.0 -deriving instance Read ByteOrder ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -9455,7 +9455,7 @@ module GHC.Word where uncheckedShiftRL64# :: GHC.Internal.Prim.Word64# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Word64# module Numeric where - -- Safety: Safe + -- Safety: Trustworthy type Floating :: * -> Constraint class GHC.Internal.Real.Fractional a => Floating a where pi :: a @@ -12432,7 +12432,6 @@ instance forall a. GHC.Internal.Read.Read a => GHC.Internal.Read.Read (GHC.Inter instance forall a. GHC.Internal.Read.Read a => GHC.Internal.Read.Read (GHC.Internal.Data.Bits.Xor a) -- Defined in ‘GHC.Internal.Data.Bits’ instance forall a b. (GHC.Internal.Ix.Ix a, GHC.Internal.Read.Read a, GHC.Internal.Read.Read b) => GHC.Internal.Read.Read (GHC.Internal.Arr.Array a b) -- Defined in ‘GHC.Internal.Read’ instance GHC.Internal.Read.Read GHC.Internal.Types.Bool -- Defined in ‘GHC.Internal.Read’ -instance GHC.Internal.Read.Read GHC.Internal.ByteOrder.ByteOrder -- Defined in ‘GHC.Internal.Read’ instance GHC.Internal.Read.Read GHC.Internal.Types.Char -- Defined in ‘GHC.Internal.Read’ instance GHC.Internal.Read.Read GHC.Internal.Types.Double -- Defined in ‘GHC.Internal.Read’ instance GHC.Internal.Read.Read GHC.Internal.Types.Float -- Defined in ‘GHC.Internal.Read’ @@ -12499,7 +12498,7 @@ instance forall a. GHC.Internal.Read.Read a => GHC.Internal.Read.Read (Data.Semi instance forall a. GHC.Internal.Read.Read a => GHC.Internal.Read.Read (Data.Semigroup.Min a) -- Defined in ‘Data.Semigroup’ instance forall m. GHC.Internal.Read.Read m => GHC.Internal.Read.Read (Data.Semigroup.WrappedMonoid m) -- Defined in ‘Data.Semigroup’ instance forall k (a :: k) (b :: k). Coercible a b => GHC.Internal.Read.Read (GHC.Internal.Data.Type.Coercion.Coercion a b) -- Defined in ‘GHC.Internal.Data.Type.Coercion’ -instance GHC.Internal.Read.Read GHC.Internal.Data.Version.Version -- Defined in ‘GHC.Internal.Data.Version’ +instance [safe] GHC.Internal.Read.Read GHC.Internal.Data.Version.Version -- Defined in ‘Data.Version’ instance GHC.Internal.Read.Read GHC.Internal.Foreign.Ptr.IntPtr -- Defined in ‘GHC.Internal.Foreign.Ptr’ instance GHC.Internal.Read.Read GHC.Internal.Foreign.Ptr.WordPtr -- Defined in ‘GHC.Internal.Foreign.Ptr’ instance GHC.Internal.Read.Read GHC.Internal.Foreign.C.Types.CBool -- Defined in ‘GHC.Internal.Foreign.C.Types’ @@ -12528,6 +12527,7 @@ instance GHC.Internal.Read.Read GHC.Internal.Foreign.C.Types.CULong -- Defined i instance GHC.Internal.Read.Read GHC.Internal.Foreign.C.Types.CUSeconds -- Defined in ‘GHC.Internal.Foreign.C.Types’ instance GHC.Internal.Read.Read GHC.Internal.Foreign.C.Types.CUShort -- Defined in ‘GHC.Internal.Foreign.C.Types’ instance GHC.Internal.Read.Read GHC.Internal.Foreign.C.Types.CWchar -- Defined in ‘GHC.Internal.Foreign.C.Types’ +instance [safe] GHC.Internal.Read.Read GHC.Internal.ByteOrder.ByteOrder -- Defined in ‘GHC.ByteOrder’ instance forall k (f :: k -> *) (g :: k -> *) (p :: k). (GHC.Internal.Read.Read (f p), GHC.Internal.Read.Read (g p)) => GHC.Internal.Read.Read ((GHC.Internal.Generics.:*:) f g p) -- Defined in ‘GHC.Internal.Generics’ instance forall k (f :: k -> *) (g :: k -> *) (p :: k). (GHC.Internal.Read.Read (f p), GHC.Internal.Read.Read (g p)) => GHC.Internal.Read.Read ((GHC.Internal.Generics.:+:) f g p) -- Defined in ‘GHC.Internal.Generics’ instance forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1). GHC.Internal.Read.Read (f (g p)) => GHC.Internal.Read.Read ((GHC.Internal.Generics.:.:) f g p) -- Defined in ‘GHC.Internal.Generics’ @@ -12542,16 +12542,16 @@ instance GHC.Internal.Read.Read GHC.Internal.Generics.SourceStrictness -- Define instance GHC.Internal.Read.Read GHC.Internal.Generics.SourceUnpackedness -- Defined in ‘GHC.Internal.Generics’ instance forall k (p :: k). GHC.Internal.Read.Read (GHC.Internal.Generics.U1 p) -- Defined in ‘GHC.Internal.Generics’ instance forall k (p :: k). GHC.Internal.Read.Read (GHC.Internal.Generics.V1 p) -- Defined in ‘GHC.Internal.Generics’ -instance GHC.Internal.Read.Read GHC.Internal.IO.Device.SeekMode -- Defined in ‘GHC.Internal.IO.Device’ -instance GHC.Internal.Read.Read GHC.Internal.IO.Handle.Types.BufferMode -- Defined in ‘GHC.Internal.IO.Handle.Types’ -instance GHC.Internal.Read.Read GHC.Internal.IO.Handle.Types.Newline -- Defined in ‘GHC.Internal.IO.Handle.Types’ -instance GHC.Internal.Read.Read GHC.Internal.IO.Handle.Types.NewlineMode -- Defined in ‘GHC.Internal.IO.Handle.Types’ -instance GHC.Internal.Read.Read GHC.Internal.IO.IOMode.IOMode -- Defined in ‘GHC.Internal.IO.IOMode’ instance [safe] GHC.Internal.Read.Read GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’ instance [safe] GHC.Internal.Read.Read GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’ instance GHC.Internal.Read.Read GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’ instance GHC.Internal.Read.Read GHC.Internal.TypeLits.SomeChar -- Defined in ‘GHC.Internal.TypeLits’ instance GHC.Internal.Read.Read GHC.Internal.TypeLits.SomeSymbol -- Defined in ‘GHC.Internal.TypeLits’ +instance GHC.Internal.Read.Read GHC.Internal.IO.Handle.Types.BufferMode -- Defined in ‘System.IO’ +instance GHC.Internal.Read.Read GHC.Internal.IO.IOMode.IOMode -- Defined in ‘System.IO’ +instance GHC.Internal.Read.Read GHC.Internal.IO.Handle.Types.Newline -- Defined in ‘System.IO’ +instance GHC.Internal.Read.Read GHC.Internal.IO.Handle.Types.NewlineMode -- Defined in ‘System.IO’ +instance GHC.Internal.Read.Read GHC.Internal.IO.Device.SeekMode -- Defined in ‘System.IO’ instance forall k a (b :: k). GHC.Internal.Real.Fractional a => GHC.Internal.Real.Fractional (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.Functor.Const’ instance forall a. GHC.Internal.Float.RealFloat a => GHC.Internal.Real.Fractional (Data.Complex.Complex a) -- Defined in ‘Data.Complex’ instance forall k (a :: k). Data.Fixed.HasResolution a => GHC.Internal.Real.Fractional (Data.Fixed.Fixed a) -- Defined in ‘Data.Fixed’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -9493,7 +9493,7 @@ module GHC.Word where uncheckedShiftRL64# :: GHC.Internal.Prim.Word64# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Word64# module Numeric where - -- Safety: Safe + -- Safety: Trustworthy type Floating :: * -> Constraint class GHC.Internal.Real.Fractional a => Floating a where pi :: a @@ -12461,7 +12461,6 @@ instance forall a. GHC.Internal.Read.Read a => GHC.Internal.Read.Read (GHC.Inter instance forall a. GHC.Internal.Read.Read a => GHC.Internal.Read.Read (GHC.Internal.Data.Bits.Xor a) -- Defined in ‘GHC.Internal.Data.Bits’ instance forall a b. (GHC.Internal.Ix.Ix a, GHC.Internal.Read.Read a, GHC.Internal.Read.Read b) => GHC.Internal.Read.Read (GHC.Internal.Arr.Array a b) -- Defined in ‘GHC.Internal.Read’ instance GHC.Internal.Read.Read GHC.Internal.Types.Bool -- Defined in ‘GHC.Internal.Read’ -instance GHC.Internal.Read.Read GHC.Internal.ByteOrder.ByteOrder -- Defined in ‘GHC.Internal.Read’ instance GHC.Internal.Read.Read GHC.Internal.Types.Char -- Defined in ‘GHC.Internal.Read’ instance GHC.Internal.Read.Read GHC.Internal.Types.Double -- Defined in ‘GHC.Internal.Read’ instance GHC.Internal.Read.Read GHC.Internal.Types.Float -- Defined in ‘GHC.Internal.Read’ @@ -12528,7 +12527,7 @@ instance forall a. GHC.Internal.Read.Read a => GHC.Internal.Read.Read (Data.Semi instance forall a. GHC.Internal.Read.Read a => GHC.Internal.Read.Read (Data.Semigroup.Min a) -- Defined in ‘Data.Semigroup’ instance forall m. GHC.Internal.Read.Read m => GHC.Internal.Read.Read (Data.Semigroup.WrappedMonoid m) -- Defined in ‘Data.Semigroup’ instance forall k (a :: k) (b :: k). Coercible a b => GHC.Internal.Read.Read (GHC.Internal.Data.Type.Coercion.Coercion a b) -- Defined in ‘GHC.Internal.Data.Type.Coercion’ -instance GHC.Internal.Read.Read GHC.Internal.Data.Version.Version -- Defined in ‘GHC.Internal.Data.Version’ +instance [safe] GHC.Internal.Read.Read GHC.Internal.Data.Version.Version -- Defined in ‘Data.Version’ instance GHC.Internal.Read.Read GHC.Internal.Foreign.Ptr.IntPtr -- Defined in ‘GHC.Internal.Foreign.Ptr’ instance GHC.Internal.Read.Read GHC.Internal.Foreign.Ptr.WordPtr -- Defined in ‘GHC.Internal.Foreign.Ptr’ instance GHC.Internal.Read.Read GHC.Internal.Foreign.C.Types.CBool -- Defined in ‘GHC.Internal.Foreign.C.Types’ @@ -12557,6 +12556,7 @@ instance GHC.Internal.Read.Read GHC.Internal.Foreign.C.Types.CULong -- Defined i instance GHC.Internal.Read.Read GHC.Internal.Foreign.C.Types.CUSeconds -- Defined in ‘GHC.Internal.Foreign.C.Types’ instance GHC.Internal.Read.Read GHC.Internal.Foreign.C.Types.CUShort -- Defined in ‘GHC.Internal.Foreign.C.Types’ instance GHC.Internal.Read.Read GHC.Internal.Foreign.C.Types.CWchar -- Defined in ‘GHC.Internal.Foreign.C.Types’ +instance [safe] GHC.Internal.Read.Read GHC.Internal.ByteOrder.ByteOrder -- Defined in ‘GHC.ByteOrder’ instance forall k (f :: k -> *) (g :: k -> *) (p :: k). (GHC.Internal.Read.Read (f p), GHC.Internal.Read.Read (g p)) => GHC.Internal.Read.Read ((GHC.Internal.Generics.:*:) f g p) -- Defined in ‘GHC.Internal.Generics’ instance forall k (f :: k -> *) (g :: k -> *) (p :: k). (GHC.Internal.Read.Read (f p), GHC.Internal.Read.Read (g p)) => GHC.Internal.Read.Read ((GHC.Internal.Generics.:+:) f g p) -- Defined in ‘GHC.Internal.Generics’ instance forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1). GHC.Internal.Read.Read (f (g p)) => GHC.Internal.Read.Read ((GHC.Internal.Generics.:.:) f g p) -- Defined in ‘GHC.Internal.Generics’ @@ -12571,16 +12571,16 @@ instance GHC.Internal.Read.Read GHC.Internal.Generics.SourceStrictness -- Define instance GHC.Internal.Read.Read GHC.Internal.Generics.SourceUnpackedness -- Defined in ‘GHC.Internal.Generics’ instance forall k (p :: k). GHC.Internal.Read.Read (GHC.Internal.Generics.U1 p) -- Defined in ‘GHC.Internal.Generics’ instance forall k (p :: k). GHC.Internal.Read.Read (GHC.Internal.Generics.V1 p) -- Defined in ‘GHC.Internal.Generics’ -instance GHC.Internal.Read.Read GHC.Internal.IO.Device.SeekMode -- Defined in ‘GHC.Internal.IO.Device’ -instance GHC.Internal.Read.Read GHC.Internal.IO.Handle.Types.BufferMode -- Defined in ‘GHC.Internal.IO.Handle.Types’ -instance GHC.Internal.Read.Read GHC.Internal.IO.Handle.Types.Newline -- Defined in ‘GHC.Internal.IO.Handle.Types’ -instance GHC.Internal.Read.Read GHC.Internal.IO.Handle.Types.NewlineMode -- Defined in ‘GHC.Internal.IO.Handle.Types’ -instance GHC.Internal.Read.Read GHC.Internal.IO.IOMode.IOMode -- Defined in ‘GHC.Internal.IO.IOMode’ instance [safe] GHC.Internal.Read.Read GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’ instance [safe] GHC.Internal.Read.Read GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’ instance GHC.Internal.Read.Read GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’ instance GHC.Internal.Read.Read GHC.Internal.TypeLits.SomeChar -- Defined in ‘GHC.Internal.TypeLits’ instance GHC.Internal.Read.Read GHC.Internal.TypeLits.SomeSymbol -- Defined in ‘GHC.Internal.TypeLits’ +instance GHC.Internal.Read.Read GHC.Internal.IO.Handle.Types.BufferMode -- Defined in ‘System.IO’ +instance GHC.Internal.Read.Read GHC.Internal.IO.IOMode.IOMode -- Defined in ‘System.IO’ +instance GHC.Internal.Read.Read GHC.Internal.IO.Handle.Types.Newline -- Defined in ‘System.IO’ +instance GHC.Internal.Read.Read GHC.Internal.IO.Handle.Types.NewlineMode -- Defined in ‘System.IO’ +instance GHC.Internal.Read.Read GHC.Internal.IO.Device.SeekMode -- Defined in ‘System.IO’ instance forall k a (b :: k). GHC.Internal.Real.Fractional a => GHC.Internal.Real.Fractional (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.Functor.Const’ instance forall a. GHC.Internal.Float.RealFloat a => GHC.Internal.Real.Fractional (Data.Complex.Complex a) -- Defined in ‘Data.Complex’ instance forall k (a :: k). Data.Fixed.HasResolution a => GHC.Internal.Real.Fractional (Data.Fixed.Fixed a) -- Defined in ‘Data.Fixed’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -9735,7 +9735,7 @@ module GHC.Word where uncheckedShiftRL64# :: GHC.Internal.Prim.Word64# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Word64# module Numeric where - -- Safety: Safe + -- Safety: Trustworthy type Floating :: * -> Constraint class GHC.Internal.Real.Fractional a => Floating a where pi :: a @@ -12703,7 +12703,6 @@ instance forall a. GHC.Internal.Read.Read a => GHC.Internal.Read.Read (GHC.Inter instance forall a. GHC.Internal.Read.Read a => GHC.Internal.Read.Read (GHC.Internal.Data.Bits.Xor a) -- Defined in ‘GHC.Internal.Data.Bits’ instance forall a b. (GHC.Internal.Ix.Ix a, GHC.Internal.Read.Read a, GHC.Internal.Read.Read b) => GHC.Internal.Read.Read (GHC.Internal.Arr.Array a b) -- Defined in ‘GHC.Internal.Read’ instance GHC.Internal.Read.Read GHC.Internal.Types.Bool -- Defined in ‘GHC.Internal.Read’ -instance GHC.Internal.Read.Read GHC.Internal.ByteOrder.ByteOrder -- Defined in ‘GHC.Internal.Read’ instance GHC.Internal.Read.Read GHC.Internal.Types.Char -- Defined in ‘GHC.Internal.Read’ instance GHC.Internal.Read.Read GHC.Internal.Types.Double -- Defined in ‘GHC.Internal.Read’ instance GHC.Internal.Read.Read GHC.Internal.Types.Float -- Defined in ‘GHC.Internal.Read’ @@ -12770,7 +12769,7 @@ instance forall a. GHC.Internal.Read.Read a => GHC.Internal.Read.Read (Data.Semi instance forall a. GHC.Internal.Read.Read a => GHC.Internal.Read.Read (Data.Semigroup.Min a) -- Defined in ‘Data.Semigroup’ instance forall m. GHC.Internal.Read.Read m => GHC.Internal.Read.Read (Data.Semigroup.WrappedMonoid m) -- Defined in ‘Data.Semigroup’ instance forall k (a :: k) (b :: k). Coercible a b => GHC.Internal.Read.Read (GHC.Internal.Data.Type.Coercion.Coercion a b) -- Defined in ‘GHC.Internal.Data.Type.Coercion’ -instance GHC.Internal.Read.Read GHC.Internal.Data.Version.Version -- Defined in ‘GHC.Internal.Data.Version’ +instance [safe] GHC.Internal.Read.Read GHC.Internal.Data.Version.Version -- Defined in ‘Data.Version’ instance GHC.Internal.Read.Read GHC.Internal.Foreign.Ptr.IntPtr -- Defined in ‘GHC.Internal.Foreign.Ptr’ instance GHC.Internal.Read.Read GHC.Internal.Foreign.Ptr.WordPtr -- Defined in ‘GHC.Internal.Foreign.Ptr’ instance GHC.Internal.Read.Read GHC.Internal.Foreign.C.Types.CBool -- Defined in ‘GHC.Internal.Foreign.C.Types’ @@ -12799,6 +12798,7 @@ instance GHC.Internal.Read.Read GHC.Internal.Foreign.C.Types.CULong -- Defined i instance GHC.Internal.Read.Read GHC.Internal.Foreign.C.Types.CUSeconds -- Defined in ‘GHC.Internal.Foreign.C.Types’ instance GHC.Internal.Read.Read GHC.Internal.Foreign.C.Types.CUShort -- Defined in ‘GHC.Internal.Foreign.C.Types’ instance GHC.Internal.Read.Read GHC.Internal.Foreign.C.Types.CWchar -- Defined in ‘GHC.Internal.Foreign.C.Types’ +instance [safe] GHC.Internal.Read.Read GHC.Internal.ByteOrder.ByteOrder -- Defined in ‘GHC.ByteOrder’ instance GHC.Internal.Read.Read GHC.Internal.Event.Windows.ConsoleEvent.ConsoleEvent -- Defined in ‘GHC.Internal.Event.Windows.ConsoleEvent’ instance forall k (f :: k -> *) (g :: k -> *) (p :: k). (GHC.Internal.Read.Read (f p), GHC.Internal.Read.Read (g p)) => GHC.Internal.Read.Read ((GHC.Internal.Generics.:*:) f g p) -- Defined in ‘GHC.Internal.Generics’ instance forall k (f :: k -> *) (g :: k -> *) (p :: k). (GHC.Internal.Read.Read (f p), GHC.Internal.Read.Read (g p)) => GHC.Internal.Read.Read ((GHC.Internal.Generics.:+:) f g p) -- Defined in ‘GHC.Internal.Generics’ @@ -12814,16 +12814,16 @@ instance GHC.Internal.Read.Read GHC.Internal.Generics.SourceStrictness -- Define instance GHC.Internal.Read.Read GHC.Internal.Generics.SourceUnpackedness -- Defined in ‘GHC.Internal.Generics’ instance forall k (p :: k). GHC.Internal.Read.Read (GHC.Internal.Generics.U1 p) -- Defined in ‘GHC.Internal.Generics’ instance forall k (p :: k). GHC.Internal.Read.Read (GHC.Internal.Generics.V1 p) -- Defined in ‘GHC.Internal.Generics’ -instance GHC.Internal.Read.Read GHC.Internal.IO.Device.SeekMode -- Defined in ‘GHC.Internal.IO.Device’ -instance GHC.Internal.Read.Read GHC.Internal.IO.Handle.Types.BufferMode -- Defined in ‘GHC.Internal.IO.Handle.Types’ -instance GHC.Internal.Read.Read GHC.Internal.IO.Handle.Types.Newline -- Defined in ‘GHC.Internal.IO.Handle.Types’ -instance GHC.Internal.Read.Read GHC.Internal.IO.Handle.Types.NewlineMode -- Defined in ‘GHC.Internal.IO.Handle.Types’ -instance GHC.Internal.Read.Read GHC.Internal.IO.IOMode.IOMode -- Defined in ‘GHC.Internal.IO.IOMode’ instance [safe] GHC.Internal.Read.Read GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’ instance [safe] GHC.Internal.Read.Read GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’ instance GHC.Internal.Read.Read GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’ instance GHC.Internal.Read.Read GHC.Internal.TypeLits.SomeChar -- Defined in ‘GHC.Internal.TypeLits’ instance GHC.Internal.Read.Read GHC.Internal.TypeLits.SomeSymbol -- Defined in ‘GHC.Internal.TypeLits’ +instance GHC.Internal.Read.Read GHC.Internal.IO.Handle.Types.BufferMode -- Defined in ‘System.IO’ +instance GHC.Internal.Read.Read GHC.Internal.IO.IOMode.IOMode -- Defined in ‘System.IO’ +instance GHC.Internal.Read.Read GHC.Internal.IO.Handle.Types.Newline -- Defined in ‘System.IO’ +instance GHC.Internal.Read.Read GHC.Internal.IO.Handle.Types.NewlineMode -- Defined in ‘System.IO’ +instance GHC.Internal.Read.Read GHC.Internal.IO.Device.SeekMode -- Defined in ‘System.IO’ instance forall k a (b :: k). GHC.Internal.Real.Fractional a => GHC.Internal.Real.Fractional (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.Functor.Const’ instance forall a. GHC.Internal.Float.RealFloat a => GHC.Internal.Real.Fractional (Data.Complex.Complex a) -- Defined in ‘Data.Complex’ instance forall k (a :: k). Data.Fixed.HasResolution a => GHC.Internal.Real.Fractional (Data.Fixed.Fixed a) -- Defined in ‘Data.Fixed’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -9455,7 +9455,7 @@ module GHC.Word where uncheckedShiftRL64# :: GHC.Internal.Prim.Word64# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Word64# module Numeric where - -- Safety: Safe + -- Safety: Trustworthy type Floating :: * -> Constraint class GHC.Internal.Real.Fractional a => Floating a where pi :: a @@ -12432,7 +12432,6 @@ instance forall a. GHC.Internal.Read.Read a => GHC.Internal.Read.Read (GHC.Inter instance forall a. GHC.Internal.Read.Read a => GHC.Internal.Read.Read (GHC.Internal.Data.Bits.Xor a) -- Defined in ‘GHC.Internal.Data.Bits’ instance forall a b. (GHC.Internal.Ix.Ix a, GHC.Internal.Read.Read a, GHC.Internal.Read.Read b) => GHC.Internal.Read.Read (GHC.Internal.Arr.Array a b) -- Defined in ‘GHC.Internal.Read’ instance GHC.Internal.Read.Read GHC.Internal.Types.Bool -- Defined in ‘GHC.Internal.Read’ -instance GHC.Internal.Read.Read GHC.Internal.ByteOrder.ByteOrder -- Defined in ‘GHC.Internal.Read’ instance GHC.Internal.Read.Read GHC.Internal.Types.Char -- Defined in ‘GHC.Internal.Read’ instance GHC.Internal.Read.Read GHC.Internal.Types.Double -- Defined in ‘GHC.Internal.Read’ instance GHC.Internal.Read.Read GHC.Internal.Types.Float -- Defined in ‘GHC.Internal.Read’ @@ -12499,7 +12498,7 @@ instance forall a. GHC.Internal.Read.Read a => GHC.Internal.Read.Read (Data.Semi instance forall a. GHC.Internal.Read.Read a => GHC.Internal.Read.Read (Data.Semigroup.Min a) -- Defined in ‘Data.Semigroup’ instance forall m. GHC.Internal.Read.Read m => GHC.Internal.Read.Read (Data.Semigroup.WrappedMonoid m) -- Defined in ‘Data.Semigroup’ instance forall k (a :: k) (b :: k). Coercible a b => GHC.Internal.Read.Read (GHC.Internal.Data.Type.Coercion.Coercion a b) -- Defined in ‘GHC.Internal.Data.Type.Coercion’ -instance GHC.Internal.Read.Read GHC.Internal.Data.Version.Version -- Defined in ‘GHC.Internal.Data.Version’ +instance [safe] GHC.Internal.Read.Read GHC.Internal.Data.Version.Version -- Defined in ‘Data.Version’ instance GHC.Internal.Read.Read GHC.Internal.Foreign.Ptr.IntPtr -- Defined in ‘GHC.Internal.Foreign.Ptr’ instance GHC.Internal.Read.Read GHC.Internal.Foreign.Ptr.WordPtr -- Defined in ‘GHC.Internal.Foreign.Ptr’ instance GHC.Internal.Read.Read GHC.Internal.Foreign.C.Types.CBool -- Defined in ‘GHC.Internal.Foreign.C.Types’ @@ -12528,6 +12527,7 @@ instance GHC.Internal.Read.Read GHC.Internal.Foreign.C.Types.CULong -- Defined i instance GHC.Internal.Read.Read GHC.Internal.Foreign.C.Types.CUSeconds -- Defined in ‘GHC.Internal.Foreign.C.Types’ instance GHC.Internal.Read.Read GHC.Internal.Foreign.C.Types.CUShort -- Defined in ‘GHC.Internal.Foreign.C.Types’ instance GHC.Internal.Read.Read GHC.Internal.Foreign.C.Types.CWchar -- Defined in ‘GHC.Internal.Foreign.C.Types’ +instance [safe] GHC.Internal.Read.Read GHC.Internal.ByteOrder.ByteOrder -- Defined in ‘GHC.ByteOrder’ instance forall k (f :: k -> *) (g :: k -> *) (p :: k). (GHC.Internal.Read.Read (f p), GHC.Internal.Read.Read (g p)) => GHC.Internal.Read.Read ((GHC.Internal.Generics.:*:) f g p) -- Defined in ‘GHC.Internal.Generics’ instance forall k (f :: k -> *) (g :: k -> *) (p :: k). (GHC.Internal.Read.Read (f p), GHC.Internal.Read.Read (g p)) => GHC.Internal.Read.Read ((GHC.Internal.Generics.:+:) f g p) -- Defined in ‘GHC.Internal.Generics’ instance forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1). GHC.Internal.Read.Read (f (g p)) => GHC.Internal.Read.Read ((GHC.Internal.Generics.:.:) f g p) -- Defined in ‘GHC.Internal.Generics’ @@ -12542,16 +12542,16 @@ instance GHC.Internal.Read.Read GHC.Internal.Generics.SourceStrictness -- Define instance GHC.Internal.Read.Read GHC.Internal.Generics.SourceUnpackedness -- Defined in ‘GHC.Internal.Generics’ instance forall k (p :: k). GHC.Internal.Read.Read (GHC.Internal.Generics.U1 p) -- Defined in ‘GHC.Internal.Generics’ instance forall k (p :: k). GHC.Internal.Read.Read (GHC.Internal.Generics.V1 p) -- Defined in ‘GHC.Internal.Generics’ -instance GHC.Internal.Read.Read GHC.Internal.IO.Device.SeekMode -- Defined in ‘GHC.Internal.IO.Device’ -instance GHC.Internal.Read.Read GHC.Internal.IO.Handle.Types.BufferMode -- Defined in ‘GHC.Internal.IO.Handle.Types’ -instance GHC.Internal.Read.Read GHC.Internal.IO.Handle.Types.Newline -- Defined in ‘GHC.Internal.IO.Handle.Types’ -instance GHC.Internal.Read.Read GHC.Internal.IO.Handle.Types.NewlineMode -- Defined in ‘GHC.Internal.IO.Handle.Types’ -instance GHC.Internal.Read.Read GHC.Internal.IO.IOMode.IOMode -- Defined in ‘GHC.Internal.IO.IOMode’ instance [safe] GHC.Internal.Read.Read GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’ instance [safe] GHC.Internal.Read.Read GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’ instance GHC.Internal.Read.Read GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’ instance GHC.Internal.Read.Read GHC.Internal.TypeLits.SomeChar -- Defined in ‘GHC.Internal.TypeLits’ instance GHC.Internal.Read.Read GHC.Internal.TypeLits.SomeSymbol -- Defined in ‘GHC.Internal.TypeLits’ +instance GHC.Internal.Read.Read GHC.Internal.IO.Handle.Types.BufferMode -- Defined in ‘System.IO’ +instance GHC.Internal.Read.Read GHC.Internal.IO.IOMode.IOMode -- Defined in ‘System.IO’ +instance GHC.Internal.Read.Read GHC.Internal.IO.Handle.Types.Newline -- Defined in ‘System.IO’ +instance GHC.Internal.Read.Read GHC.Internal.IO.Handle.Types.NewlineMode -- Defined in ‘System.IO’ +instance GHC.Internal.Read.Read GHC.Internal.IO.Device.SeekMode -- Defined in ‘System.IO’ instance forall k a (b :: k). GHC.Internal.Real.Fractional a => GHC.Internal.Real.Fractional (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.Functor.Const’ instance forall a. GHC.Internal.Float.RealFloat a => GHC.Internal.Real.Fractional (Data.Complex.Complex a) -- Defined in ‘Data.Complex’ instance forall k (a :: k). Data.Fixed.HasResolution a => GHC.Internal.Real.Fractional (Data.Fixed.Fixed a) -- Defined in ‘Data.Fixed’ ===================================== testsuite/tests/plugins/plugins09.stdout ===================================== @@ -1,5 +1,6 @@ parsePlugin(a,b) interfacePlugin: Prelude +interfacePlugin: System.IO interfacePlugin: GHC.Internal.Base interfacePlugin: GHC.Internal.Data.NonEmpty interfacePlugin: GHC.Internal.Float ===================================== testsuite/tests/plugins/plugins10.stdout ===================================== @@ -2,6 +2,8 @@ parsePlugin() interfacePlugin: Prelude interfacePlugin: Language.Haskell.TH interfacePlugin: Language.Haskell.TH.Quote +interfacePlugin: Data.Version +interfacePlugin: System.IO interfacePlugin: GHC.Internal.Base interfacePlugin: GHC.Internal.Data.NonEmpty interfacePlugin: GHC.Internal.Float ===================================== testsuite/tests/plugins/plugins11.stdout ===================================== @@ -1,5 +1,6 @@ parsePlugin() interfacePlugin: Prelude +interfacePlugin: System.IO interfacePlugin: GHC.Internal.Base interfacePlugin: GHC.Internal.Data.NonEmpty interfacePlugin: GHC.Internal.Float ===================================== testsuite/tests/plugins/static-plugins.stdout ===================================== @@ -1,6 +1,7 @@ ==pure.0 parsePlugin() interfacePlugin: Prelude +interfacePlugin: System.IO interfacePlugin: GHC.Internal.Base interfacePlugin: GHC.Internal.Data.NonEmpty interfacePlugin: GHC.Internal.Float View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d59b7c7109e4d8ef9035ec4b9d9f164… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d59b7c7109e4d8ef9035ec4b9d9f164… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 7 commits: Make cmm 'import "package" name;' syntax use consistent label types
by Marge Bot (＠marge-bot) 30 Apr '26

30 Apr '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 9f85f034 by Duncan Coutts at 2026-04-30T04:52:42-04:00 Make cmm 'import "package" name;' syntax use consistent label types There is a little-used syntactic form in cmm imports: import "package" foo; Which means to import foo from the given package (unit id, specified as a string). This syntax is somewhat reminiscent of GHC's package import extension. This syntax form is not used in the rts cmm code, nor any of the boot libraries. It may not be used at all. Unclear. Change the kind of CLabel this syntax generates to be consistent with the others. The other cmm imports use ForeignLabel with ForeignLabelInExternalPackage. For some reason this form was using CmmLabel. Change that to also be ForeignLabel but with ForeignLabelInPackage. This specifies a specific package, rather than an unnamed external package. - - - - - a811f68f by Duncan Coutts at 2026-04-30T04:52:42-04:00 Change default cmm import statements to be internal Previously a cmm statement like: import foo; meant to expect the symbol from a different shared library than the current one. Now it means to expect the symbol from the same shared library as the current one. We'll add explicit syntax to indicate that it's a foreign import. Most existing uses are in fact intenal (rts to rts), so few imports will need to be annotated foreign. Examples would include cmm code in libraries (other than the rts) that need to access RTS APIs. In practice, this makes no difference whatsoever at the moment on any platform other than windows (where building Haskell libs as shared libs does not fully work yet), since the 'labelDynamic' treats all such labels as foreign, irrespective of the foreign label source. - - - - - 17fe5d1d by Duncan Coutts at 2026-04-30T04:52:42-04:00 Add cmm import syntax 'import DATA foo;' as better name for CLOSURE The existing syntax is: import CLOSURE foo; The new syntax is import DATA foo; This means to interpret the symbol foo as refering to data (i.e. a global constant or variable) rather than to code (a function). The historical syntax for this uses CLOSURE, which is rather misleading. Presumably this was done to avoid introducing new reserved words. Be less squemish about new reserved words and add DATA and use that. Keep the existing CLOSURE syntax as an alias for compatibility. - - - - - 3a530d68 by Duncan Coutts at 2026-04-30T04:52:42-04:00 Add cmm 'import extern name;' syntax Since the default for cmm imports is now for symbols within the same shared object, we need a way to indicate we want a symbol from an external shared object: import extern foo; -- for a function import extern DATA foo; -- for data This adds a new reserved word 'extern'. We don't expect to have to use this much. Most cmm imports are intra-DSO. This makes no difference currently on ELF and MachO platforms, but does make a difference to the linking conventions on PE (Windows). In future it's plausible we could take make distinctions on ELF or MachO, so it's worth trying to get it right. Windows can be the guinea pig. - - - - - 2b8e44c7 by Duncan Coutts at 2026-04-30T04:52:42-04:00 Add cmm syntax 'import "package" DATA foo;' for completeness We already have: import DATA foo; -- for data imports import "package" foo; -- for imports from a given unitid There's no reason not to have both at once: import "package" DATA foo; So add that. - - - - - ee05e5cc by Duncan Coutts at 2026-04-30T04:52:42-04:00 Improve the commentary for the cmm import grammar. AFAIK, this is the only place where GHC-style Cmm syntax is documented. - - - - - b35946ad by Duncan Coutts at 2026-04-30T04:52:42-04:00 Add a changelog.d entry for the .cmm import syntax changes - - - - - 3 changed files: - + changelog.d/cmm-import-syntax-changes - compiler/GHC/Cmm/Lexer.x - compiler/GHC/Cmm/Parser.y Changes: ===================================== changelog.d/cmm-import-syntax-changes ===================================== @@ -0,0 +1,34 @@ +section: cmm +synopsis: Changes to Cmm hand-written syntax for symbol imports. +issues: #27162 +mrs: !15135 + +description: { + In hand-written Cmm, there is syntax to declare symbol names from outside of + the current .cmm file (e.g. .c or .cmm files). + + The existing syntax is + + > import foo; -- for a function + > import CLOSURE foo; -- for data + + and this implicitly meant that the symbol (`foo`) could be found in an + external shared library, not the current one. There was no syntax to specify + that the symbol should be found in the current shared library, i.e. in a + .cmm file (or .hs file) in the current Haskell package. + + The new syntax assumes local by default and allows specifying external: + + > import foo; -- for a function in the current lib + > import DATA foo; -- for data in the current lib + > import extern foo; -- for a function in an external lib + > import extern DATA foo; -- for data in an external lib + > import "unitid" foo; -- for a function in the Haskell unit "unitid" + > import "unitid" DATA foo; -- for data in the Haskell unit "unitid" + + In practice, the only platform where this can be expected to make a + difference is on Windows, and only when compiling each Haskell package as a + separate .dll dynamic library. +} + + ===================================== compiler/GHC/Cmm/Lexer.x ===================================== @@ -174,6 +174,8 @@ data CmmToken | CmmT_return | CmmT_returns | CmmT_import + | CmmT_extern + | CmmT_DATA | CmmT_switch | CmmT_case | CmmT_default @@ -273,6 +275,8 @@ reservedWordsFM = listToUFM $ ( "return", CmmT_return ), ( "returns", CmmT_returns ), ( "import", CmmT_import ), + ( "extern", CmmT_extern ), + ( "DATA", CmmT_DATA ), ( "switch", CmmT_switch ), ( "case", CmmT_case ), ( "default", CmmT_default ), ===================================== compiler/GHC/Cmm/Parser.y ===================================== @@ -372,6 +372,8 @@ import qualified Data.ByteString.Char8 as BS8 'return' { L _ (CmmT_return) } 'returns' { L _ (CmmT_returns) } 'import' { L _ (CmmT_import) } + 'extern' { L _ (CmmT_extern) } + 'DATA' { L _ (CmmT_DATA) } 'switch' { L _ (CmmT_switch) } 'case' { L _ (CmmT_case) } 'default' { L _ (CmmT_default) } @@ -643,18 +645,42 @@ importNames importName :: { (FastString, CLabel) } - -- A label imported without an explicit packageId. - -- These are taken to come from some foreign, unnamed package. + -- A code label imported from within the same shared library. : NAME - { ($1, mkForeignLabel $1 ForeignLabelInExternalPackage IsFunction) } + { ($1, mkForeignLabel $1 ForeignLabelInThisPackage IsFunction) } - -- as previous 'NAME', but 'IsData' - | 'CLOSURE' NAME - { ($2, mkForeignLabel $2 ForeignLabelInExternalPackage IsData) } + -- A data label imported from within the same shared library. + | 'DATA' NAME + { ($2, mkForeignLabel $2 ForeignLabelInThisPackage IsData) } - -- A label imported with an explicit UnitId. + -- CLOSURE is a historical alias for DATA in this context. + | 'CLOSURE' NAME + { ($2, mkForeignLabel $2 ForeignLabelInThisPackage IsData) } + + -- A code label imported from another unamed shared library. These may + -- come from a foreign shared library, or from the shared library for + -- an unnamed Haskell package. This corresponds on Windows/PE to + -- __declspec(dllimport) in C. + | 'extern' NAME + { ($2, mkForeignLabel $2 ForeignLabelInExternalPackage IsFunction) } + + -- A data label imported from another unamed shared library. + -- This corresponds on Windows/PE to __declspec(dllimport) in C (but + -- cmm doesn't know about data vs function symbols so we have to say). + | 'extern' 'DATA' NAME + { ($3, mkForeignLabel $3 ForeignLabelInExternalPackage IsData) } + + -- A code label imported from the shared library for a Haskell package + -- with the given UnitId. Such labels behave as local when used within + -- the specified unit, or as extern otherwise. | STRING NAME - { ($2, mkCmmCodeLabel (UnitId (mkFastString $1)) $2) } + { ($2, mkForeignLabel $2 (ForeignLabelInPackage (UnitId (mkFastString $1))) IsFunction) } + + -- A data label imported from the shared library for a Haskell package + -- with the given UnitId. Such labels behave as local when used within + -- the specified unit, or as extern otherwise. + | STRING 'DATA' NAME + { ($3, mkForeignLabel $3 (ForeignLabelInPackage (UnitId (mkFastString $1))) IsData) } names :: { [FastString] } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9797052b974b3356c34b457558ffda… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9797052b974b3356c34b457558ffda… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/T27202] 3 commits: Introduce a cache of home module name providers
by Hannes Siebenhandl (＠fendor) 30 Apr '26

30 Apr '26

Hannes Siebenhandl pushed to branch wip/fendor/T27202 at Glasgow Haskell Compiler / GHC Commits: bc36279c by Wolfgang Jeltsch at 2026-04-30T09:38:31+02:00 Introduce a cache of home module name providers This contribution introduces to the module graph a cache that maps home module names to sets of units providing them and changes the finder to use that cache. This is a performance optimization, especially for multi-home-unit builds. The particular changes are as follows: * In `GHC.Unit.Module.Graph`, `ModuleGraph` is extended with a new field `mg_home_module_name_providers_map`, exposed as `mgHomeModuleNameProvidersMap`. This is a cache that assigns to each home module name the set of IDs of home units that define it. Operations that construct module graphs are updated such that this cache stays synchronized. * In `GHC.Unit.Finder`, `findImportedModule` is changed to pull `mgHomeModuleNameProvidersMap` from `hsc_mod_graph` and pass it to `findImportedModuleNoHsc`, which now does not search home units in arbitrary order but prioritizes those units that the cache mentions as potential providers of the requested module. Resolves #27055. Co-authored-by: Wolfgang Jeltsch <wolfgang(a)well-typed.com> - - - - - d948b139 by fendor at 2026-04-30T09:38:31+02:00 Add regression tests for T27202 - - - - - 18a78435 by fendor at 2026-04-30T09:39:04+02:00 Dont clean the importDirs from interactive-session - - - - - 41 changed files: - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Module/Graph.hs - ghc/GHCi/UI.hs - ghc/Main.hs - testsuite/tests/driver/fat-iface/fat014.stdout - testsuite/tests/ghci/prog018/prog018.stdout - testsuite/tests/ghci/prog020/Makefile - testsuite/tests/ghci/prog020/all.T - testsuite/tests/ghci/prog020/ghci.prog020.script → testsuite/tests/ghci/prog020/ghci.prog020a.script - testsuite/tests/ghci/prog020/ghci.prog020.stderr → testsuite/tests/ghci/prog020/ghci.prog020a.stderr - testsuite/tests/ghci/prog020/ghci.prog020.stdout → testsuite/tests/ghci/prog020/ghci.prog020a.stdout - + testsuite/tests/ghci/prog020/ghci.prog020b.script - + testsuite/tests/ghci/prog020/ghci.prog020b.stderr - + testsuite/tests/ghci/prog020/ghci.prog020b.stdout - + testsuite/tests/ghci/prog023/Makefile - + testsuite/tests/ghci/prog023/all.T - + testsuite/tests/ghci/prog023/prog023a.script - + testsuite/tests/ghci/prog023/prog023a.stdout - + testsuite/tests/ghci/prog023/prog023b.script - + testsuite/tests/ghci/prog023/prog023b.stdout - + testsuite/tests/ghci/prog023/src/A.hs - + testsuite/tests/ghci/prog024/Makefile - + testsuite/tests/ghci/prog024/all.T - + testsuite/tests/ghci/prog024/prog024a.script - + testsuite/tests/ghci/prog024/prog024a.stdout - + testsuite/tests/ghci/prog024/prog024b.script - + testsuite/tests/ghci/prog024/prog024b.stdout - + testsuite/tests/ghci/prog024/prog024c.script - + testsuite/tests/ghci/prog024/prog024c.stderr - + testsuite/tests/ghci/prog024/prog024c.stdout - + testsuite/tests/ghci/prog024/prog024d.script - + testsuite/tests/ghci/prog024/prog024d.stderr - + testsuite/tests/ghci/prog024/prog024d.stdout - + testsuite/tests/ghci/prog024/src/A.hs - + testsuite/tests/ghci/prog024/src/B.hs - testsuite/tests/ghci/scripts/T13997.stdout - testsuite/tests/ghci/scripts/T1914.stdout - testsuite/tests/ghci/scripts/T20217.stdout - testsuite/tests/ghci/scripts/T8042.stdout - testsuite/tests/ghci/scripts/T8042recomp.stdout - testsuite/tests/ghci/should_run/T10920.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ba7c336f957e08a2540dbd092e2750… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ba7c336f957e08a2540dbd092e2750… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/process-357] Bump process submodule
by Zubin (＠wz1000) 30 Apr '26

30 Apr '26

Zubin pushed to branch wip/process-357 at Glasgow Haskell Compiler / GHC Commits: c6e27ce8 by Zubin Duggal at 2026-04-30T09:50:46+05:30 Bump process submodule - - - - - 1 changed file: - libraries/process Changes: ===================================== libraries/process ===================================== @@ -1 +1 @@ -Subproject commit 72e5b7c75a17f543262674259b2ebf4a3bda390c +Subproject commit 633d5d6ce2ad5eeb2d4b274efafd3451adc5cb9e View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c6e27ce8986f240ef4fffe656402d17… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c6e27ce8986f240ef4fffe656402d17… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 15 commits: Make cmm 'import "package" name;' syntax use consistent label types
by Marge Bot (＠marge-bot) 30 Apr '26

30 Apr '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 10aec92b by Duncan Coutts at 2026-04-29T22:12:02-04:00 Make cmm 'import "package" name;' syntax use consistent label types There is a little-used syntactic form in cmm imports: import "package" foo; Which means to import foo from the given package (unit id, specified as a string). This syntax is somewhat reminiscent of GHC's package import extension. This syntax form is not used in the rts cmm code, nor any of the boot libraries. It may not be used at all. Unclear. Change the kind of CLabel this syntax generates to be consistent with the others. The other cmm imports use ForeignLabel with ForeignLabelInExternalPackage. For some reason this form was using CmmLabel. Change that to also be ForeignLabel but with ForeignLabelInPackage. This specifies a specific package, rather than an unnamed external package. - - - - - ffd884d5 by Duncan Coutts at 2026-04-29T22:12:02-04:00 Change default cmm import statements to be internal Previously a cmm statement like: import foo; meant to expect the symbol from a different shared library than the current one. Now it means to expect the symbol from the same shared library as the current one. We'll add explicit syntax to indicate that it's a foreign import. Most existing uses are in fact intenal (rts to rts), so few imports will need to be annotated foreign. Examples would include cmm code in libraries (other than the rts) that need to access RTS APIs. In practice, this makes no difference whatsoever at the moment on any platform other than windows (where building Haskell libs as shared libs does not fully work yet), since the 'labelDynamic' treats all such labels as foreign, irrespective of the foreign label source. - - - - - e37a298a by Duncan Coutts at 2026-04-29T22:12:02-04:00 Add cmm import syntax 'import DATA foo;' as better name for CLOSURE The existing syntax is: import CLOSURE foo; The new syntax is import DATA foo; This means to interpret the symbol foo as refering to data (i.e. a global constant or variable) rather than to code (a function). The historical syntax for this uses CLOSURE, which is rather misleading. Presumably this was done to avoid introducing new reserved words. Be less squemish about new reserved words and add DATA and use that. Keep the existing CLOSURE syntax as an alias for compatibility. - - - - - 9d6ee0c5 by Duncan Coutts at 2026-04-29T22:12:03-04:00 Add cmm 'import extern name;' syntax Since the default for cmm imports is now for symbols within the same shared object, we need a way to indicate we want a symbol from an external shared object: import extern foo; -- for a function import extern DATA foo; -- for data This adds a new reserved word 'extern'. We don't expect to have to use this much. Most cmm imports are intra-DSO. This makes no difference currently on ELF and MachO platforms, but does make a difference to the linking conventions on PE (Windows). In future it's plausible we could take make distinctions on ELF or MachO, so it's worth trying to get it right. Windows can be the guinea pig. - - - - - 59fcd3b3 by Duncan Coutts at 2026-04-29T22:12:03-04:00 Add cmm syntax 'import "package" DATA foo;' for completeness We already have: import DATA foo; -- for data imports import "package" foo; -- for imports from a given unitid There's no reason not to have both at once: import "package" DATA foo; So add that. - - - - - ffadb3cf by Duncan Coutts at 2026-04-29T22:12:03-04:00 Improve the commentary for the cmm import grammar. AFAIK, this is the only place where GHC-style Cmm syntax is documented. - - - - - 13fb0d83 by Duncan Coutts at 2026-04-29T22:12:03-04:00 Add a changelog.d entry for the .cmm import syntax changes - - - - - f5cd8c81 by Wolfgang Jeltsch at 2026-04-29T22:12:04-04:00 Move code that uses `GHC.Internal.Text.Read` into `base` This contribution serves to remove all dependencies on `GHC.Internal.Text.Read` from within `ghc-internal`, so that the implementation of `Text.Read` and ultimately more reading-related code can be moved to `base` as well. The following things are moved from `ghc-internal` to `base`: * I/O-related `Read` instances * Most of the `Numeric` implementation * The instance `Read ByteOrder` * The `parseVersion` operation * The `readConstr` operation Metric Increase: LinkableUsage01 T9198 T12425 T13035 T13820 T18140 - - - - - 7add6b79 by Rodrigo Mesquita at 2026-04-29T22:12:05-04:00 New rts Message to {set,unset} TSO flags This commit introduces stg_MSG_SET_TSO_FLAG_info and stg_MSG_UNSET_TSO_FLAG_info, which allows setting flags of a TSO other than yourself. This is especially useful/necessary to set breakpoints and toggle breakpoints of different threads, which is needed to safely implement features like pausing, toggling step-out, toggling step-in per thread, etc. Fixes #27131 ------------------------- Metric Decrease: T3294 ------------------------- - - - - - 4a75215f by Rodrigo Mesquita at 2026-04-29T22:12:05-04:00 test: Add test setting another TSO's flags Introduces a test that runs on two capabilities. The main thread running on Capability 0 sets the flags on a TSO running on Capability 1. The TSO from Capability 1 itself checks whether its flags were set and reports that back. This validates that the RTS messages for setting TSO flags work, even if it doesn't test a harsher scenario with race conditions to exercise why the message passing is necessary for safely setting another TSO's flags. Part of #27131 - - - - - 1d57d019 by David Eichmann at 2026-04-29T22:12:07-04:00 Hadrian: withResponseFile outputs response file when verbodity is Verbose At the Verbose verbosity, shake will display full commandlines. With the use of response files, the full command is hidden. That makes it hard to run the command manually. This commit outputs the contents of the response file so that that full command can be recreated and also hints at the use of the --keep-response-files hadrian flag. - - - - - 38eed317 by Duncan Coutts at 2026-04-29T22:12:07-04:00 Use response files for hadrian linking with ghc (support long command lines) In future support for windows dynamic linking, we expect long command lines for linking dll files with ghc. Experiments with dynamic linking the ghc-internal library yielded a link command well over 32kb. We did not encounter this before for static libs, since we already use ar's @file feature (if available, which it is for the llvm toolchain). Co-authored-by: David Eichmann <davide(a)well-typed.com> - - - - - 663e193b by Andreas Klebinger at 2026-04-29T22:12:07-04:00 Split GHC.Driver.Main.hs up into multiple components. This commit splits GHC.Driver.Main into four components: * GHC.Driver.Main.Compile * GHC.Driver.Main.Hsc * GHC.Driver.Main.Interactive * GHC.Driver.Main.Passes We might improve that separation further in the future but this should hopefully make it easier to reason about and work with this part of the code. - - - - - 96fbcb5d by Cheng Shao at 2026-04-29T22:12:09-04:00 compiler: avoid unique OccNames for internal Names in bytecode objects This patch improves bytecode object serialization logic by avoiding the construction of unique `OccName`s when serializing/deserializing internal `Name`s. Closes #27213. ------------------------- Metric Decrease: LinkableUsage01 ------------------------- - - - - - 6753e3d8 by Vladislav Zavialov at 2026-04-29T22:12:10-04:00 Replace GHC 9.16 references with GHC 10.0 - - - - - 66 changed files: - + changelog.d/T27131 - + changelog.d/cmm-import-syntax-changes - compiler/GHC/ByteCode/Binary.hs - compiler/GHC/Cmm/Lexer.x - compiler/GHC/Cmm/Parser.y - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Main.hs - + compiler/GHC/Driver/Main/Compile.hs - compiler/GHC/Driver/Main.hs-boot → compiler/GHC/Driver/Main/Compile.hs-boot - + compiler/GHC/Driver/Main/Hsc.hs - + compiler/GHC/Driver/Main/Interactive.hs - + compiler/GHC/Driver/Main/Passes.hs - + compiler/GHC/Driver/Main/Passes.hs-boot - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Types/Error.hs-boot - compiler/ghc.cabal.in - docs/users_guide/debug-info.rst - docs/users_guide/exts/explicit_namespaces.rst - docs/users_guide/exts/linear_types.rst - docs/users_guide/exts/modifiers.rst - docs/users_guide/exts/qualified_strings.rst - docs/users_guide/exts/required_type_arguments.rst - docs/users_guide/using-warnings.rst - docs/users_guide/using.rst - hadrian/src/Builder.hs - hadrian/src/Hadrian/Builder.hs - hadrian/src/Hadrian/Utilities.hs - hadrian/src/Settings/Builders/Ghc.hs - libraries/base/src/Data/Data.hs - libraries/base/src/Data/Version.hs - libraries/base/src/GHC/ByteOrder.hs - libraries/base/src/Numeric.hs - libraries/base/src/System/IO.hs - libraries/base/src/Text/Printf.hs - libraries/ghc-internal/src/GHC/Internal/Data/Data.hs - libraries/ghc-internal/src/GHC/Internal/Data/Version.hs - libraries/ghc-internal/src/GHC/Internal/IO/Device.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Types.hs - libraries/ghc-internal/src/GHC/Internal/IO/IOMode.hs - libraries/ghc-internal/src/GHC/Internal/Numeric.hs - libraries/ghc-internal/src/GHC/Internal/Read.hs - rts/Interpreter.c - rts/Messages.c - rts/StgMiscClosures.cmm - rts/Threads.c - rts/Threads.h - rts/include/rts/storage/Closures.h - rts/include/stg/MiscClosures.h - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/linters/notes.stdout - testsuite/tests/plugins/plugins09.stdout - testsuite/tests/plugins/plugins10.stdout - testsuite/tests/plugins/plugins11.stdout - testsuite/tests/plugins/static-plugins.stdout - + testsuite/tests/rts/T27131.hs - + testsuite/tests/rts/T27131.stdout - + testsuite/tests/rts/T27131_c.c - testsuite/tests/rts/all.T - testsuite/tests/typecheck/should_fail/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5722839696f8c9728c2beefc675cf3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5722839696f8c9728c2beefc675cf3… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26989] Use the same float-binds type in lookupRule and exprIsConApp_maybe
by Simon Peyton Jones (＠simonpj) 29 Apr '26

29 Apr '26

Simon Peyton Jones pushed to branch wip/T26989 at Glasgow Haskell Compiler / GHC Commits: d0a00801 by Simon Peyton Jones at 2026-04-30T00:38:23+01:00 Use the same float-binds type in lookupRule and exprIsConApp_maybe ...refactor only - - - - - 8 changed files: - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/FloatOut.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/HsToCore/Pmc/Solver.hs Changes: ===================================== compiler/GHC/Core/Make.hs ===================================== @@ -19,7 +19,9 @@ module GHC.Core.Make ( MkStringIds (..), getMkStringIds, -- * Floats - FloatBind(..), wrapFloat, wrapFloats, floatBindings, + FloatBind(..), FloatBinds, + wrapFloat, wrapFloats, floatBindings, + emptyFloatBinds, isEmptyFloatBinds, -- * Constructing small tuples mkCoreVarTupTy, mkCoreTup, mkCoreUnboxedTuple, mkCoreUnboxedSum, @@ -61,10 +63,11 @@ import GHC.Types.Basic( TypeOrConstraint(..) ) import GHC.Types.Demand import GHC.Types.Name hiding ( varName ) import GHC.Types.Literal +import GHC.Types.Tickish import GHC.Types.Unique.Supply import GHC.Core -import GHC.Core.Utils ( exprType, mkSingleAltCase, bindNonRec, mkCast ) +import GHC.Core.Utils ( exprType, mkSingleAltCase, bindNonRec, mkCast, mkTick ) import GHC.Core.Type import GHC.Core.Predicate ( scopedSort, isEqPred ) import GHC.Core.TyCo.Compare ( eqType ) @@ -82,6 +85,7 @@ import GHC.Utils.Panic import GHC.Settings.Constants( mAX_TUPLE_SIZE ) import GHC.Data.FastString +import GHC.Data.OrdList import GHC.Data.Maybe ( expectJust ) import Data.List ( partition ) @@ -744,33 +748,45 @@ mkSmallTupleCase vars body scrut_var scrut ************************************************************************ -} +type FloatBinds = OrdList FloatBind + +emptyFloatBinds :: FloatBinds +emptyFloatBinds = nilOL + +isEmptyFloatBinds :: FloatBinds -> Bool +isEmptyFloatBinds = isNilOL + data FloatBind = FloatLet CoreBind | FloatCase CoreExpr Id AltCon [Var] -- case e of y { C ys -> ... } -- See Note [Floating single-alternative cases] in GHC.Core.Opt.SetLevels + | FloatTick CoreTickish instance Outputable FloatBind where - ppr (FloatLet b) = text "LET" <+> ppr b + ppr (FloatTick t) = text "TICK" <+> ppr t + ppr (FloatLet b) = text "LET" <+> ppr b ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> text "of" <+> ppr b) 2 (ppr c <+> ppr bs) wrapFloat :: FloatBind -> CoreExpr -> CoreExpr +wrapFloat (FloatTick t) body = mkTick t body wrapFloat (FloatLet defns) body = Let defns body wrapFloat (FloatCase e b con bs) body = mkSingleAltCase e b con bs body -- | Applies the floats from right to left. That is @wrapFloats [b1, b2, …, bn] -- u = let b1 in let b2 in … in let bn in u@ -wrapFloats :: [FloatBind] -> CoreExpr -> CoreExpr -wrapFloats floats expr = foldr wrapFloat expr floats +wrapFloats :: FloatBinds -> CoreExpr -> CoreExpr +wrapFloats floats expr = foldrOL wrapFloat expr floats bindBindings :: CoreBind -> [Var] bindBindings (NonRec b _) = [b] bindBindings (Rec bnds) = map fst bnds floatBindings :: FloatBind -> [Var] -floatBindings (FloatLet bnd) = bindBindings bnd +floatBindings (FloatLet bnd) = bindBindings bnd floatBindings (FloatCase _ b _ bs) = b:bs +floatBindings (FloatTick {}) = [] {- ************************************************************************ ===================================== compiler/GHC/Core/Opt/FloatIn.hs ===================================== @@ -861,7 +861,9 @@ floatIsDupable :: Platform -> FloatBind -> Bool floatIsDupable platform (FloatCase scrut _ _ _) = exprIsDupable platform scrut floatIsDupable platform (FloatLet (Rec prs)) = all (exprIsDupable platform . snd) prs floatIsDupable platform (FloatLet (NonRec _ r)) = exprIsDupable platform r +floatIsDupable _ (FloatTick {}) = True floatIsCase :: FloatBind -> Bool floatIsCase (FloatCase {}) = True floatIsCase (FloatLet {}) = False +floatIsCase (FloatTick {}) = False ===================================== compiler/GHC/Core/Opt/FloatOut.hs ===================================== @@ -162,7 +162,7 @@ floatTopBind bind ************************************************************************ -} -floatBind :: LevelledBind -> (FloatStats, FloatBinds, [CoreBind]) +floatBind :: LevelledBind -> (FloatStats, FloatLets, [CoreBind]) -- Returns a list with either -- * A single non-recursive binding (value or join point), or -- * The following, in order: @@ -190,7 +190,7 @@ floatBind (Rec pairs) (fs, rhs_floats, new_non_rec_binds ++ new_rec_binds) } where do_pair :: (LevelledBndr, LevelledExpr) - -> (FloatStats, FloatBinds, + -> (FloatStats, FloatLets, ([(Id,CoreExpr)], -- Non-recursive unlifted value bindings [(Id,CoreExpr)])) -- Join points and lifted value bindings do_pair (TB name spec, rhs) @@ -239,7 +239,7 @@ installUnderLambdas floats e go e = install floats e --------------- -floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b]) +floatList :: (a -> (FloatStats, FloatLets, b)) -> [a] -> (FloatStats, FloatLets, [b]) floatList _ [] = (zeroStats, emptyFloats, []) floatList f (a:as) = case f a of { (fs_a, binds_a, b) -> case floatList f as of { (fs_as, binds_as, bs) -> @@ -312,7 +312,7 @@ but this case works just as well. floatBody :: Level -> LevelledExpr - -> (FloatStats, FloatBinds, CoreExpr) + -> (FloatStats, FloatLets, CoreExpr) floatBody lvl arg -- Used rec rhss, and case-alternative rhss = case (floatExpr arg) of { (fsa, floats, arg') -> @@ -342,7 +342,7 @@ expression is entered since the tick still scopes over the RHS. -} floatExpr :: LevelledExpr - -> (FloatStats, FloatBinds, CoreExpr) + -> (FloatStats, FloatLets, CoreExpr) floatExpr (Var v) = (zeroStats, emptyFloats, Var v) floatExpr (Type ty) = (zeroStats, emptyFloats, Type ty) floatExpr (Coercion co) = (zeroStats, emptyFloats, Coercion co) @@ -472,7 +472,7 @@ floatExpr (Case scrut (TB case_bndr case_spec) ty alts) floatRhs :: CoreBndr -> LevelledExpr - -> (FloatStats, FloatBinds, CoreExpr) + -> (FloatStats, FloatLets, CoreExpr) floatRhs bndr rhs | JoinPoint join_arity <- idJoinPointHood bndr , Just (bndrs, body) <- try_collect join_arity rhs [] @@ -557,7 +557,7 @@ add_stats :: FloatStats -> FloatStats -> FloatStats add_stats (FlS a1 b1 c1) (FlS a2 b2 c2) = FlS (a1 + a2) (b1 + b2) (c1 + c2) -add_to_stats :: FloatStats -> FloatBinds -> FloatStats +add_to_stats :: FloatStats -> FloatLets -> FloatStats add_to_stats (FlS a b c) (FB tops others) = FlS (a + lengthBag tops) (b + lengthBag (flattenMajor others)) @@ -570,9 +570,9 @@ add_to_stats (FlS a b c) (FB tops others) * * ************************************************************************ -Note [Representation of FloatBinds] +Note [Representation of FloatLets] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The FloatBinds types is somewhat important. We can get very large numbers +The FloatLets types is somewhat important. We can get very large numbers of floating bindings, often all destined for the top level. A typical example is x = [4,2,5,2,5, .... ] Then we get lots of small expressions like (fromInteger 4), which all get @@ -594,17 +594,17 @@ type FloatLet = CoreBind -- INVARIANT: a FloatLet is always lifted type MajorEnv = M.IntMap MinorEnv -- Keyed by major level type MinorEnv = M.IntMap (Bag FloatBind) -- Keyed by minor level -data FloatBinds = FB !(Bag FloatLet) -- Destined for top level +data FloatLets = FB !(Bag FloatLet) -- Destined for top level !MajorEnv -- Other levels - -- See Note [Representation of FloatBinds] + -- See Note [Representation of FloatLets] -instance Outputable FloatBinds where +instance Outputable FloatLets where ppr (FB fbs defs) = text "FB" <+> (braces $ vcat [ text "tops =" <+> ppr fbs , text "non-tops =" <+> ppr defs ]) -flattenTopFloats :: FloatBinds -> Bag CoreBind +flattenTopFloats :: FloatLets -> Bag CoreBind flattenTopFloats (FB tops defs) = assertPpr (isEmptyBag (flattenMajor defs)) (ppr defs) $ tops @@ -622,23 +622,23 @@ flattenMajor = M.foldr (unionBags . flattenMinor) emptyBag flattenMinor :: MinorEnv -> Bag FloatBind flattenMinor = M.foldr unionBags emptyBag -emptyFloats :: FloatBinds +emptyFloats :: FloatLets emptyFloats = FB emptyBag M.empty -unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatBinds +unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatLets unitCaseFloat (Level major minor) e b con bs = FB emptyBag (M.singleton major (M.singleton minor floats)) where floats = unitBag (FloatCase e b con bs) -unitLetFloat :: Level -> FloatLet -> FloatBinds +unitLetFloat :: Level -> FloatLet -> FloatLets unitLetFloat lvl@(Level major minor) b | isTopLvl lvl = FB (unitBag b) M.empty | otherwise = FB emptyBag (M.singleton major (M.singleton minor floats)) where floats = unitBag (FloatLet b) -plusFloats :: FloatBinds -> FloatBinds -> FloatBinds +plusFloats :: FloatLets -> FloatLets -> FloatLets plusFloats (FB t1 l1) (FB t2 l2) = FB (t1 `unionBags` t2) (l1 `plusMajor` l2) @@ -654,8 +654,8 @@ install defn_groups expr partitionByLevel :: Level -- Partitioning level - -> FloatBinds -- Defns to be divided into 2 piles... - -> (FloatBinds, -- Defns with level strictly < partition level, + -> FloatLets -- Defns to be divided into 2 piles... + -> (FloatLets, -- Defns with level strictly < partition level, Bag FloatBind) -- The rest {- @@ -692,7 +692,7 @@ partitionByLevel (Level major minor) (FB tops defns) Just min_defns -> M.splitLookup minor min_defns here_min = mb_here_min `orElse` emptyBag -wrapTick :: CoreTickish -> FloatBinds -> FloatBinds +wrapTick :: CoreTickish -> FloatLets -> FloatLets wrapTick t (FB tops defns) = assert (not $ tickishCounts t) $ FB (mapBag wrap_bind tops) @@ -705,6 +705,7 @@ wrapTick t (FB tops defns) wrap_one (FloatLet bind) = FloatLet (wrap_bind bind) wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs + wrap_one (FloatTick t) = FloatTick t -- Doesn't happen in this pass maybe_tick -- We don't need to wrap an SCC tick around HNFs that we floated out of ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -22,7 +22,7 @@ import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Inline import GHC.Core.Opt.Simplify.Utils import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs ) -import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr ) +import GHC.Core.Make hiding( wrapFloats ) import qualified GHC.Core.Make import GHC.Core.Coercion hiding ( substCo, substCoVar ) import qualified GHC.Core.Coercion as Coercion @@ -42,8 +42,7 @@ import GHC.Core.Opt.Arity ( ArityType, exprArity, arityTypeBotSigs_maybe , typeArity, arityTypeArity, etaExpandAT ) import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) import GHC.Core.FVs ( mkRuleInfo {- exprsFreeIds -} ) -import GHC.Core.Rules ( RuleMatch(..), applyBindWrapper, isEmptyBindWrapper - , lookupRule, getRules ) +import GHC.Core.Rules ( RuleMatch(..), lookupRule, getRules ) import GHC.Core.Multiplicity import GHC.Hs.Extension @@ -2491,7 +2490,7 @@ simplOutId env fun cont -> simplExprF env rhs' $ dropContArgs (ruleArity rule) cont where - rhs' = applyBindWrapper wrap $ + rhs' = GHC.Core.Make.wrapFloats wrap $ mkApps rhs rhs_args ; Nothing -> @@ -2772,9 +2771,9 @@ fireRuleAFTER env rule_match arg_specs cont pushOutArgs (exprType rhs) rhs_args $ pushArgSpecs (drop (ruleArity rule) arg_specs) cont ; return $ - if isEmptyBindWrapper wrap -- Not very pretty + if isEmptyFloatBinds wrap -- Not very pretty then (floats, e') - else (emptyFloats env', applyBindWrapper wrap $ + else (emptyFloats env', GHC.Core.Make.wrapFloats wrap $ wrapFloats floats e') } @@ -3880,17 +3879,17 @@ let binders, so we could float them). But the need for the extra complication is not clear. -} -wrapDataConFloats :: SimplEnv -> [FloatBind] -> InId -> SimplCont +wrapDataConFloats :: SimplEnv -> FloatBinds -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr) -> SimplM (SimplFloats, OutExpr) -- See Note [FloatBinds from constructor wrappers] wrapDataConFloats env wfloats case_bndr cont thing_inside - | null wfloats + | isEmptyFloatBinds wfloats = thing_inside | otherwise = do { (floats, expr) <- thing_inside ; return ( emptyFloats env - , GHC.Core.Make.wrapFloats (map scale_float wfloats) $ + , GHC.Core.Make.wrapFloats (fmap scale_float wfloats) $ wrapFloats floats expr ) } where -- scale_float scales case-floats by the multiplicity of the continuation hole @@ -3898,8 +3897,8 @@ wrapDataConFloats env wfloats case_bndr cont thing_inside -- Let floats are _not_ scaled, because they are aliases anyway. scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars) = GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars) - scale_float flt(a)(GHC.Core.Make.FloatLet {}) - = flt + scale_float flt(a)(GHC.Core.Make.FloatLet {}) = flt + scale_float flt(a)(GHC.Core.Make.FloatTick {}) = flt scale_id id = scaleVarBy holeScaling id ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -24,7 +24,7 @@ import GHC.Core.DataCon (dataConTyCon) import qualified GHC.Core.Subst as Core import GHC.Core.Unfold.Make import GHC.Core -import GHC.Core.Make ( mkLitRubbish ) +import GHC.Core.Make ( mkLitRubbish, wrapFloats ) import GHC.Core.Unify ( tcMatchTy ) import GHC.Core.Rules import GHC.Core.Subst (substTickish) @@ -1824,7 +1824,7 @@ specLookupRule env fn args is_active rules = case lookupRule ropts in_scope_env is_active fn args rules of Just (RM { rm_rule = rule, rm_rhs = rule_rhs , rm_binds = wrap, rm_args = rule_args }) - -> Just (rule, applyBindWrapper wrap (mkApps rule_rhs rule_args)) + -> Just (rule, wrapFloats wrap (mkApps rule_rhs rule_args)) Nothing -> Nothing where dflags = se_dflags env ===================================== compiler/GHC/Core/Rules.hs ===================================== @@ -10,7 +10,6 @@ module GHC.Core.Rules ( -- ** Looking up rules RuleMatch(..), lookupRule, matchExprs, ruleLhsIsMoreSpecific, - BindWrapper, isEmptyBindWrapper, applyBindWrapper, -- ** RuleBase, RuleEnv RuleBase, RuleEnv(..), mkRuleEnv, emptyRuleEnv, @@ -51,8 +50,7 @@ import GHC.Core.Subst import GHC.Core.SimpleOpt ( exprIsLambda_maybe ) import GHC.Core.FVs ( exprFreeVars, bindFreeVars , rulesFreeVarsDSet, orphNamesOfExprs ) -import GHC.Core.Utils ( exprType, mkTick, mkTicks - , stripTicksTopT, stripTicksTopE +import GHC.Core.Utils ( exprType, stripTicksTopT, stripTicksTopE , isJoinBind, mkCastMCo ) import GHC.Core.Ppr ( pprRules ) import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) @@ -64,7 +62,7 @@ import GHC.Core.Coercion as Coercion import GHC.Core.Tidy ( tidyRules ) import GHC.Core.Map.Expr ( eqCoreExpr ) import GHC.Core.Opt.Arity( etaExpandToJoinPointRule ) -import GHC.Core.Make ( mkCoreLams ) +import GHC.Core.Make import GHC.Core.Opt.OccurAnal( occurAnalyseBndrsAndExpr ) import GHC.Core.Rules.Config (roBuiltinRules) @@ -549,7 +547,7 @@ data RuleMatch = RM { rm_rule :: CoreRule , rm_rhs :: CoreExpr , rm_args :: [CoreExpr] - , rm_binds :: BindWrapper -- Floated let-bindings + , rm_binds :: FloatBinds -- Floated let-bindings -- See Note [Matching lets] , rm_bndrs :: [Var] -- Binders of rm_binds } @@ -594,7 +592,7 @@ lookupRule opts rule_env@(ISE in_scope _) is_active fn args rules go ms [] = ms go ms (r:rs) | Just rm <- matchRule opts rule_env is_active fn args' rough_args r - = go (rm { rm_binds = mkTicks ticks `consOL` rm_binds rm } : ms) rs + = go (rm { rm_binds = toOL (map FloatTick ticks) `appOL` rm_binds rm } : ms) rs | otherwise = -- pprTrace "match failed" (ppr r $$ ppr args $$ -- ppr [ (arg_id, maybeUnfoldingTemplate unf) @@ -749,7 +747,7 @@ matchRule opts rule_env _is_active fn args _rough_args ; return (RM { rm_rule = rule , rm_rhs = rhs , rm_args = [] - , rm_binds = emptyBindWrapper + , rm_binds = emptyFloatBinds , rm_bndrs = [] }) } matchRule _opts rule_env is_active _fn target_es rough_args @@ -772,7 +770,7 @@ matchRule _opts rule_env is_active _fn target_es rough_args matchExprs :: HasDebugCallStack => InScopeEnv -> [Var] -> [CoreExpr] -> [CoreExpr] -> Maybe ( [CoreExpr] -- 1-1 with the incoming [Var] - , BindWrapper, [Var]) -- Floated binds + , FloatBinds, [Var]) -- Floated binds matchExprs (ISE in_scope id_unf) tmpl_vars tmpl_es target_es = do { rule_subst <- match_exprs init_menv emptyRuleSubst tmpl_es target_es ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst) @@ -967,27 +965,15 @@ data RuleSubst = RS { -- Substitution; applied only to the template, not the tar , rs_id_subst :: IdSubstEnv -- Floated bindings - , rs_binds :: BindWrapper -- Floated bindings - , rs_bndrs :: [Var] -- Variables bound by floated lets + -- See Notes [Matching lets] and [Matching cases] + , rs_binds :: FloatBinds -- Floated bindings + , rs_bndrs :: [Var] -- Variables bound by floated bindings } -type BindWrapper = OrdList (CoreExpr -> CoreExpr) - -- See Notes [Matching lets] and [Matching cases] - -- we represent the floated bindings as a core-to-core function - -- WE use an OrdList so that we can tell the common case of an empty wrapper - -emptyBindWrapper :: BindWrapper -emptyBindWrapper = nilOL - -isEmptyBindWrapper :: BindWrapper -> Bool -isEmptyBindWrapper = isNilOL - -applyBindWrapper :: BindWrapper -> CoreExpr -> CoreExpr -applyBindWrapper bw e = foldrOL ($) e bw emptyRuleSubst :: RuleSubst emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv - , rs_binds = nilOL, rs_bndrs = [] } + , rs_binds = emptyFloatBinds, rs_bndrs = [] } {- Note [Casts in the target] @@ -1123,7 +1109,7 @@ match renv subst e1 (Tick t e2) mco | otherwise = Nothing where - subst' = subst { rs_binds = rs_binds subst `snocOL` mkTick t } + subst' = subst { rs_binds = rs_binds subst `snocOL` FloatTick t } match renv subst e@(Tick t e1) e2 mco | tickishFloatable t -- Ignore floatable ticks in rule template. @@ -1357,7 +1343,7 @@ match renv subst e1 (Let bind e2) mco -- We are floating the let-binding out, as if it had enclosed -- the entire target from Day 1. So we must add its binders to -- the in-scope set (#20200) - (subst { rs_binds = rs_binds subst `snocOL` Let bind' + (subst { rs_binds = rs_binds subst `snocOL` FloatLet bind' , rs_bndrs = new_bndrs ++ rs_bndrs subst }) e1 e2 mco | otherwise @@ -1383,7 +1369,7 @@ match renv subst (Lam x1 e1) e2 mco , Just (x2, e2', ts) <- exprIsLambda_maybe in_scope_env casted_e2 -- See Note [Lambdas in the template] = let renv' = rnMatchBndr2 renv x1 x2 - subst' = subst { rs_binds = rs_binds subst `snocOL` flip (foldr mkTick) ts } + subst' = subst { rs_binds = rs_binds subst `appOL` toOL (map FloatTick ts) } in match renv' subst' e1 e2' MRefl match renv subst e1 e2@(Lam {}) mco @@ -1448,11 +1434,11 @@ match _ _ _e1 _e2 _mco = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ ( eta_reduce :: RuleMatchEnv -> CoreExpr -> Maybe (RuleMatchEnv, CoreExpr) -- See Note [Eta reduction in the target] eta_reduce renv e@(Lam {}) - = go renv emptyBindWrapper [] e + = go renv emptyFloatBinds [] e where - go :: RuleMatchEnv -> BindWrapper -> [Var] -> CoreExpr + go :: RuleMatchEnv -> FloatBinds -> [Var] -> CoreExpr -> Maybe (RuleMatchEnv, CoreExpr) - go renv bw vs (Let b e) = go renv (bw `snocOL` Let b) vs e + go renv bw vs (Let b e) = go renv (bw `snocOL` FloatLet b) vs e go renv bw vs (Lam v e) = go renv' bw (v':vs) e where @@ -1467,7 +1453,7 @@ eta_reduce renv e@(Lam {}) , v == rnOccR (rv_lcl renv) tv = go renv bw vs f - go renv bw [] e = Just (renv, applyBindWrapper bw e) + go renv bw [] e = Just (renv, wrapFloats bw e) go _ _ (_:_) _ = Nothing eta_reduce _ _ = Nothing ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -27,7 +27,7 @@ import GHC.Core.Utils import GHC.Core.FVs import GHC.Core.Unfold import GHC.Core.Unfold.Make -import GHC.Core.Make ( FloatBind(..), mkWildValBinder ) +import GHC.Core.Make import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm, zapLambdaBndrs ) import GHC.Core.DataCon import GHC.Core.Coercion.Opt ( optCoercion, OptCoercionOpts (..) ) @@ -57,6 +57,7 @@ import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Data.Maybe ( orElse ) +import GHC.Data.OrdList import GHC.Data.Graph.UnVar import Data.List (mapAccumL) import qualified Data.ByteString as BS @@ -297,7 +298,8 @@ simple_opt_expr env expr = go expr go (Case e b ty as) | isDeadBinder b - , Just (_, [], con, _tys, es) <- exprIsConApp_maybe in_scope_env e' + , Just (_, floats, con, _tys, es) <- exprIsConApp_maybe in_scope_env e' + , isEmptyFloatBinds floats -- We don't need to be concerned about floats when looking for coerce. , Just (Alt altcon bs rhs) <- findAlt (DataAlt con) as = case altcon of @@ -1346,7 +1348,7 @@ Note [Don't float join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ exprIsConApp_maybe should succeed on let v = e in Just v -returning [x=e] as one of the [FloatBind]. But it must +returning [x=e] as one of the FloatBinds. But it must NOT succeed on join j x = rhs in Just v because join-points can't be gaily floated. Consider @@ -1439,21 +1441,21 @@ data ConCont = CC [CoreExpr] MCoercion -- in "GHC.Types.Id.Make". -- -- We also return the incoming InScopeSet, augmented with --- the binders from any [FloatBind] that we return +-- the binders from any FloatBinds that we return exprIsConApp_maybe :: HasDebugCallStack => InScopeEnv -> CoreExpr - -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) + -> Maybe (InScopeSet, FloatBinds, DataCon, [Type], [CoreExpr]) exprIsConApp_maybe ise@(ISE in_scope id_unf) expr - = go (Left in_scope) [] expr (CC [] MRefl) + = go (Left in_scope) emptyFloatBinds expr (CC [] MRefl) where go :: Either InScopeSet Subst -- Left in-scope means "empty substitution" -- Right subst means "apply this substitution to the CoreExpr" -- NB: in the call (go subst floats expr cont) -- the substitution applies to 'expr', but /not/ to 'floats' or 'cont' - -> [FloatBind] -> CoreExpr -> ConCont + -> FloatBinds -> CoreExpr -> ConCont -- Notice that the floats here are in reverse order - -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) + -> Maybe (InScopeSet, FloatBinds, DataCon, [Type], [CoreExpr]) go subst floats (Tick t expr) cont | not (tickishIsCode t) = go subst floats expr cont @@ -1482,7 +1484,7 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr -- Good: returning (Mk#, [x]) with a float of case exp of x { DEFAULT -> [] } -- simplifier produces case exp of a { DEFAULT -> exp[x/a] } , (subst', float, bndr) <- case_bind subst arg arg_type - = go subst' (float:floats) fun (CC (Var bndr : args) mco) + = go subst' (floats `snocOL` float) fun (CC (Var bndr : args) mco) | otherwise = go subst floats fun (CC (subst_expr subst arg : args) mco) @@ -1492,7 +1494,7 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr | otherwise = let (subst', bndr') = subst_bndr subst bndr float = FloatLet (NonRec bndr' arg) - in go subst' (float:floats) body (CC args mco) + in go subst' (floats `snocOL` float) body (CC args mco) go subst floats (Let (NonRec bndr rhs) expr) cont | not (isJoinId bndr) @@ -1500,7 +1502,7 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr = let rhs' = subst_expr subst rhs (subst', bndr') = subst_bndr subst bndr float = FloatLet (NonRec bndr' rhs') - in go subst' (float:floats) expr cont + in go subst' (floats `snocOL` float) expr cont go subst floats (Case scrut b _ [Alt con vars expr]) cont | do_case_elim scrut' b vars -- See Note [Case elim in exprIsConApp_maybe] @@ -1511,7 +1513,7 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr (subst'', vars') = subst_bndrs subst' vars float = FloatCase scrut' b' con vars' in - go subst'' (float:floats) expr cont + go subst'' (floats `snocOL` float) expr cont where scrut' = subst_expr subst scrut @@ -1527,7 +1529,7 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr , count isValArg args == idArity fun , (in_scope', seq_floats, args') <- mkFieldSeqFloats in_scope con args -- mkFieldSeqFloats: See (SFC2) in Note [Strict fields in Core] - = succeedWith in_scope' (seq_floats ++ floats) $ + = succeedWith in_scope' (floats `appOL` seq_floats) $ pushCoDataCon con args' mco -- Look through data constructor wrappers: they inline late (See Note @@ -1576,12 +1578,11 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr go _ _ _ _ = Nothing - succeedWith :: InScopeSet -> [FloatBind] + succeedWith :: InScopeSet -> FloatBinds -> Maybe (DataCon, [Type], [CoreExpr]) - -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) - succeedWith in_scope rev_floats x + -> Maybe (InScopeSet, FloatBinds, DataCon, [Type], [CoreExpr]) + succeedWith in_scope floats x = do { (con, tys, args) <- x - ; let floats = reverse rev_floats ; return (in_scope, floats, con, tys, args) } ---------------------------- @@ -1613,7 +1614,8 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e) extend (Right s) v e = Right (extendSubst s v e) - case_bind :: Either InScopeSet Subst -> CoreExpr -> Type -> (Either InScopeSet Subst, FloatBind, Id) + case_bind :: Either InScopeSet Subst -> CoreExpr -> Type + -> (Either InScopeSet Subst, FloatBind, Id) case_bind subst expr expr_ty = (subst', float, bndr) where bndr = setCaseBndrEvald MarkedStrict $ @@ -1623,22 +1625,23 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr expr' = subst_expr subst expr float = FloatCase expr' bndr DEFAULT [] - mkFieldSeqFloats :: InScopeSet -> DataCon -> [CoreExpr] -> (InScopeSet, [FloatBind], [CoreExpr]) + mkFieldSeqFloats :: InScopeSet -> DataCon -> [CoreExpr] -> (InScopeSet, FloatBinds, [CoreExpr]) -- See Note [Strict fields in Core] for what a field seq is and (SFC2) for -- why we insert them mkFieldSeqFloats in_scope dc args | isLazyDataConRep dc - = (in_scope, [], args) + = (in_scope, nilOL, args) | otherwise = (in_scope', floats', ty_args ++ val_args') where (ty_args, val_args) = splitAtList (dataConUnivAndExTyCoVars dc) args - (in_scope', floats', val_args') = foldr do_one (in_scope, [], []) $ zipEqual str_marks val_args + (in_scope', floats', val_args') = foldr do_one (in_scope, nilOL, []) $ + zipEqual str_marks val_args str_marks = dataConRepStrictness dc do_one (str, arg) (in_scope,floats,args) | NotMarkedStrict <- str = no_seq | exprIsHNF arg = no_seq - | otherwise = (in_scope', float:floats, Var bndr:args) + | otherwise = (in_scope', float `consOL` floats, Var bndr:args) where no_seq = (in_scope, floats, arg:args) (in_scope', float, bndr) = ===================================== compiler/GHC/HsToCore/Pmc/Solver.hs ===================================== @@ -65,7 +65,7 @@ import GHC.Core.Map.Expr import GHC.Core.Predicate (typeDeterminesValue, mkNomEqPred) import GHC.Core.SimpleOpt (simpleOptExpr, exprIsConApp_maybe) import GHC.Core.Utils (exprType) -import GHC.Core.Make (mkListExpr, mkCharExpr, mkImpossibleExpr) +import GHC.Core.Make (mkListExpr, mkCharExpr, mkImpossibleExpr, isEmptyFloatBinds) import GHC.Data.FastString import GHC.Types.SrcLoc @@ -871,8 +871,9 @@ addCoreCt nabla x e = do s' -> core_expr x (mkListExpr charTy (map mkCharExpr s')) | Just lit <- coreExprAsPmLit e = pm_lit x lit - | Just (in_scope, _empty_floats@[], dc, _arg_tys, args) + | Just (in_scope, empty_floats, dc, _arg_tys, args) <- exprIsConApp_maybe in_scope_env e + , isEmptyFloatBinds empty_floats = data_con_app x in_scope dc args -- See Note [Detecting pattern synonym applications in expressions] | Var y <- e, Nothing <- isDataConId_maybe x View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d0a0080193fe161e911b379370cc66f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d0a0080193fe161e911b379370cc66f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 12 commits: Make cmm 'import "package" name;' syntax use consistent label types
by Marge Bot (＠marge-bot) 29 Apr '26

29 Apr '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 32d25516 by Duncan Coutts at 2026-04-29T15:50:25-04:00 Make cmm 'import "package" name;' syntax use consistent label types There is a little-used syntactic form in cmm imports: import "package" foo; Which means to import foo from the given package (unit id, specified as a string). This syntax is somewhat reminiscent of GHC's package import extension. This syntax form is not used in the rts cmm code, nor any of the boot libraries. It may not be used at all. Unclear. Change the kind of CLabel this syntax generates to be consistent with the others. The other cmm imports use ForeignLabel with ForeignLabelInExternalPackage. For some reason this form was using CmmLabel. Change that to also be ForeignLabel but with ForeignLabelInPackage. This specifies a specific package, rather than an unnamed external package. - - - - - 8f849ab9 by Duncan Coutts at 2026-04-29T15:50:25-04:00 Change default cmm import statements to be internal Previously a cmm statement like: import foo; meant to expect the symbol from a different shared library than the current one. Now it means to expect the symbol from the same shared library as the current one. We'll add explicit syntax to indicate that it's a foreign import. Most existing uses are in fact intenal (rts to rts), so few imports will need to be annotated foreign. Examples would include cmm code in libraries (other than the rts) that need to access RTS APIs. In practice, this makes no difference whatsoever at the moment on any platform other than windows (where building Haskell libs as shared libs does not fully work yet), since the 'labelDynamic' treats all such labels as foreign, irrespective of the foreign label source. - - - - - 3927dff2 by Duncan Coutts at 2026-04-29T15:50:25-04:00 Add cmm import syntax 'import DATA foo;' as better name for CLOSURE The existing syntax is: import CLOSURE foo; The new syntax is import DATA foo; This means to interpret the symbol foo as refering to data (i.e. a global constant or variable) rather than to code (a function). The historical syntax for this uses CLOSURE, which is rather misleading. Presumably this was done to avoid introducing new reserved words. Be less squemish about new reserved words and add DATA and use that. Keep the existing CLOSURE syntax as an alias for compatibility. - - - - - cad4d44c by Duncan Coutts at 2026-04-29T15:50:25-04:00 Add cmm 'import extern name;' syntax Since the default for cmm imports is now for symbols within the same shared object, we need a way to indicate we want a symbol from an external shared object: import extern foo; -- for a function import extern DATA foo; -- for data This adds a new reserved word 'extern'. We don't expect to have to use this much. Most cmm imports are intra-DSO. This makes no difference currently on ELF and MachO platforms, but does make a difference to the linking conventions on PE (Windows). In future it's plausible we could take make distinctions on ELF or MachO, so it's worth trying to get it right. Windows can be the guinea pig. - - - - - 9bdca0ee by Duncan Coutts at 2026-04-29T15:50:25-04:00 Add cmm syntax 'import "package" DATA foo;' for completeness We already have: import DATA foo; -- for data imports import "package" foo; -- for imports from a given unitid There's no reason not to have both at once: import "package" DATA foo; So add that. - - - - - 9c4c5aaf by Duncan Coutts at 2026-04-29T15:50:25-04:00 Improve the commentary for the cmm import grammar. AFAIK, this is the only place where GHC-style Cmm syntax is documented. - - - - - 03452444 by Duncan Coutts at 2026-04-29T15:50:26-04:00 Add a changelog.d entry for the .cmm import syntax changes - - - - - 814d12f9 by David Eichmann at 2026-04-29T15:50:26-04:00 Hadrian: withResponseFile outputs response file when verbodity is Verbose At the Verbose verbosity, shake will display full commandlines. With the use of response files, the full command is hidden. That makes it hard to run the command manually. This commit outputs the contents of the response file so that that full command can be recreated and also hints at the use of the --keep-response-files hadrian flag. - - - - - 42548fbb by Duncan Coutts at 2026-04-29T15:50:26-04:00 Use response files for hadrian linking with ghc (support long command lines) In future support for windows dynamic linking, we expect long command lines for linking dll files with ghc. Experiments with dynamic linking the ghc-internal library yielded a link command well over 32kb. We did not encounter this before for static libs, since we already use ar's @file feature (if available, which it is for the llvm toolchain). Co-authored-by: David Eichmann <davide(a)well-typed.com> - - - - - 0a9a9e74 by Andreas Klebinger at 2026-04-29T15:50:27-04:00 Split GHC.Driver.Main.hs up into multiple components. This commit splits GHC.Driver.Main into four components: * GHC.Driver.Main.Compile * GHC.Driver.Main.Hsc * GHC.Driver.Main.Interactive * GHC.Driver.Main.Passes We might improve that separation further in the future but this should hopefully make it easier to reason about and work with this part of the code. - - - - - eb2d4eb9 by Cheng Shao at 2026-04-29T15:50:28-04:00 compiler: avoid unique OccNames for internal Names in bytecode objects This patch improves bytecode object serialization logic by avoiding the construction of unique `OccName`s when serializing/deserializing internal `Name`s. Closes #27213. ------------------------- Metric Decrease: LinkableUsage01 ------------------------- - - - - - 57228396 by Vladislav Zavialov at 2026-04-29T15:50:29-04:00 Replace GHC 9.16 references with GHC 10.0 - - - - - 33 changed files: - + changelog.d/cmm-import-syntax-changes - compiler/GHC/ByteCode/Binary.hs - compiler/GHC/Cmm/Lexer.x - compiler/GHC/Cmm/Parser.y - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Main.hs - + compiler/GHC/Driver/Main/Compile.hs - compiler/GHC/Driver/Main.hs-boot → compiler/GHC/Driver/Main/Compile.hs-boot - + compiler/GHC/Driver/Main/Hsc.hs - + compiler/GHC/Driver/Main/Interactive.hs - + compiler/GHC/Driver/Main/Passes.hs - + compiler/GHC/Driver/Main/Passes.hs-boot - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Types/Error.hs-boot - compiler/ghc.cabal.in - docs/users_guide/debug-info.rst - docs/users_guide/exts/explicit_namespaces.rst - docs/users_guide/exts/linear_types.rst - docs/users_guide/exts/modifiers.rst - docs/users_guide/exts/qualified_strings.rst - docs/users_guide/exts/required_type_arguments.rst - docs/users_guide/using-warnings.rst - docs/users_guide/using.rst - hadrian/src/Builder.hs - hadrian/src/Hadrian/Builder.hs - hadrian/src/Hadrian/Utilities.hs - hadrian/src/Settings/Builders/Ghc.hs - testsuite/tests/linters/notes.stdout - testsuite/tests/typecheck/should_fail/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cf62a0165b3510724d54213be879a4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cf62a0165b3510724d54213be879a4… You're receiving this email because of your account on gitlab.haskell.org.

1 0