- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Add operations for obtaining operating-system handles
by Marge Bot (＠marge-bot) 27 Jan '26

27 Jan '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 1fc0bd6a by Wolfgang Jeltsch at 2026-01-27T00:30:20-05:00 Add operations for obtaining operating-system handles This contribution implements CLC proposal #369. It adds operations for obtaining POSIX file descriptors and Windows handles that underlie Haskell handles. Those operating system handles can also be obtained without such additional operations, but this is more involved and, more importantly, requires using internals. - - - - - bce2a8fa by Greg Steuck at 2026-01-27T00:30:29-05:00 Move flags to precede patterns for grep and read files directly This makes the tests pass with non-GNU (i.e. POSIX-complicant) tools. There's no reason to use cat and pipe where direct file argument works. - - - - - 25 changed files: - libraries/base/base.cabal.in - libraries/base/changelog.md - + libraries/base/src/System/IO/OS.hs - libraries/base/tests/IO/all.T - + libraries/base/tests/IO/osHandles001FileDescriptors.hs - + libraries/base/tests/IO/osHandles001FileDescriptors.stdout - + libraries/base/tests/IO/osHandles001WindowsHandles.hs - + libraries/base/tests/IO/osHandles001WindowsHandles.stdout - + libraries/base/tests/IO/osHandles002FileDescriptors.hs - + libraries/base/tests/IO/osHandles002FileDescriptors.stderr - + libraries/base/tests/IO/osHandles002FileDescriptors.stdin - + libraries/base/tests/IO/osHandles002FileDescriptors.stdout - + libraries/base/tests/IO/osHandles002WindowsHandles.hs - + libraries/base/tests/IO/osHandles002WindowsHandles.stderr - + libraries/base/tests/IO/osHandles002WindowsHandles.stdin - + libraries/base/tests/IO/osHandles002WindowsHandles.stdout - libraries/base/tests/perf/Makefile - libraries/ghc-internal/ghc-internal.cabal.in - + libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs - testsuite/tests/driver/T16318/Makefile - testsuite/tests/driver/T18125/Makefile - 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 Changes: ===================================== libraries/base/base.cabal.in ===================================== @@ -255,6 +255,7 @@ Library , System.Exit , System.IO , System.IO.Error + , System.IO.OS , System.Mem , System.Mem.StableName , System.Posix.Internals ===================================== libraries/base/changelog.md ===================================== @@ -23,6 +23,7 @@ * `GHC.Conc.catchSTM` and `GHC.Conc.Sync.catchSTM` now attach `WhileHandling` annotation to exceptions thrown from the handler. ([GHC #25365](https://gitlab.haskell.org/ghc/ghc/-/issues/25365)) * Remove `GHC.JS.Prim.Internal.Build`, as per [CLC #329](https://github.com/haskell/core-libraries-committee/issues/329) * Export `labelThread` from `Control.Concurrent`.([CLC proposal #376](https://github.com/haskell/core-libraries-committee/issues/376)) + * Add a new module `System.IO.OS` with operations for obtaining operating-system handles (file descriptors, Windows handles). ([CLC proposal #369](https://github.com/haskell/core-libraries-committee/issues/369)) ## 4.22.0.0 *TBA* * Shipped with GHC 9.14.1 ===================================== libraries/base/src/System/IO/OS.hs ===================================== @@ -0,0 +1,62 @@ +{-# LANGUAGE Safe #-} + +{-| + This module bridges between Haskell handles and underlying operating-system + features. +-} +module System.IO.OS +( + -- * Obtaining file descriptors and Windows handles + withFileDescriptorReadingBiased, + withFileDescriptorWritingBiased, + withWindowsHandleReadingBiased, + withWindowsHandleWritingBiased, + withFileDescriptorReadingBiasedRaw, + withFileDescriptorWritingBiasedRaw, + withWindowsHandleReadingBiasedRaw, + withWindowsHandleWritingBiasedRaw + + -- ** Caveats + -- $with-ref-caveats +) +where + +import GHC.Internal.System.IO.OS + ( + withFileDescriptorReadingBiased, + withFileDescriptorWritingBiased, + withWindowsHandleReadingBiased, + withWindowsHandleWritingBiased, + withFileDescriptorReadingBiasedRaw, + withFileDescriptorWritingBiasedRaw, + withWindowsHandleReadingBiasedRaw, + withWindowsHandleWritingBiasedRaw + ) + +-- ** Caveats + +{-$with-ref-caveats + #with-ref-caveats#There are the following caveats regarding the above + operations: + + * Flushing of buffers can fail if the given handle is readable but not + seekable. + + * If one of these operations is performed as part of an action executed by + 'System.IO.Unsafe.unsafePerformIO', + 'System.IO.Unsafe.unsafeInterleaveIO', or one of their “dupable” + variants and the user-provided action receives an asychnchronous + exception and does not catch it, then the following happens: + + - Before the overall computation is suspended, the blocking of handle + operations is removed. + + - When the computation is later resumed due to another evaluation + attempt, the blocking of handle operations is reinstantiated, the + Haskell-managed buffers are flushed again, and the user-provided + action is run from the beginning. + + Repeating the previously executed part of the user-provided action + cannot be avoided apparently. See the @[async]@ note in the source code + of "GHC.Internal.IO.Handle.Internals" for further explanation. +-} ===================================== libraries/base/tests/IO/all.T ===================================== @@ -186,3 +186,15 @@ test('T17912', [only_ways(['threaded1']), when(opsys('mingw32'),expect_broken(1) test('T18832', only_ways(['threaded1']), compile_and_run, ['']) test('mkdirExists', [exit_code(1), when(opsys('mingw32'), ignore_stderr)], compile_and_run, ['']) + +test('osHandles001FileDescriptors', omit_ways(['winio', 'winio_threaded']), compile_and_run, ['']) +test('osHandles001WindowsHandles', only_ways(['winio', 'winio_threaded']), compile_and_run, ['']) +test('osHandles002FileDescriptors', [when(opsys('mingw32'), skip), when(arch('javascript'), skip)], compile_and_run, ['']) +test('osHandles002WindowsHandles', only_ways(['winio', 'winio_threaded']), compile_and_run, ['']) +# It would be good to let `osHandles002FileDescriptors` run also on +# Windows with the file-descriptor-based I/O manager. However, this +# test, as it is currently implemented, requires the `unix` package. +# That said, `UCRT.DLL`, which is used by GHC-generated Windows +# executables, emulates part of POSIX, enough for this test. As a +# result, this test could be generalized to also supporting Windows, but +# this would likely involve creating bindings to C code. ===================================== libraries/base/tests/IO/osHandles001FileDescriptors.hs ===================================== @@ -0,0 +1,23 @@ +{-# LANGUAGE TypeApplications #-} + +import Control.Monad (mapM_) +import Control.Exception (SomeException, try) +import System.IO (stdin, stdout, stderr) +import System.IO.OS + ( + withFileDescriptorReadingBiasedRaw, + withFileDescriptorWritingBiasedRaw, + withWindowsHandleReadingBiasedRaw, + withWindowsHandleWritingBiasedRaw + ) + +main :: IO () +main = mapM_ ((>>= print) . try @SomeException) $ + [ + withFileDescriptorReadingBiasedRaw stdin (return . show), + withFileDescriptorWritingBiasedRaw stdout (return . show), + withFileDescriptorWritingBiasedRaw stderr (return . show), + withWindowsHandleReadingBiasedRaw stdin (return . const "_"), + withWindowsHandleWritingBiasedRaw stdout (return . const "_"), + withWindowsHandleWritingBiasedRaw stderr (return . const "_") + ] ===================================== libraries/base/tests/IO/osHandles001FileDescriptors.stdout ===================================== @@ -0,0 +1,6 @@ +Right "0" +Right "1" +Right "2" +Left <stdin>: withWindowsHandleReadingBiasedRaw: inappropriate type (handle does not use Windows handles) +Left <stdout>: withWindowsHandleWritingBiasedRaw: inappropriate type (handle does not use Windows handles) +Left <stderr>: withWindowsHandleWritingBiasedRaw: inappropriate type (handle does not use Windows handles) ===================================== libraries/base/tests/IO/osHandles001WindowsHandles.hs ===================================== @@ -0,0 +1,23 @@ +{-# LANGUAGE TypeApplications #-} + +import Control.Monad (mapM_) +import Control.Exception (SomeException, try) +import System.IO (stdin, stdout, stderr) +import System.IO.OS + ( + withFileDescriptorReadingBiasedRaw, + withFileDescriptorWritingBiasedRaw, + withWindowsHandleReadingBiasedRaw, + withWindowsHandleWritingBiasedRaw + ) + +main :: IO () +main = mapM_ ((>>= print) . try @SomeException) $ + [ + withFileDescriptorReadingBiasedRaw stdin (return . show), + withFileDescriptorWritingBiasedRaw stdout (return . show), + withFileDescriptorWritingBiasedRaw stderr (return . show), + withWindowsHandleReadingBiasedRaw stdin (return . const "_"), + withWindowsHandleWritingBiasedRaw stdout (return . const "_"), + withWindowsHandleWritingBiasedRaw stderr (return . const "_") + ] ===================================== libraries/base/tests/IO/osHandles001WindowsHandles.stdout ===================================== @@ -0,0 +1,6 @@ +Left <stdin>: withFileDescriptorReadingBiasedRaw: inappropriate type (handle does not use file descriptors) +Left <stdout>: withFileDescriptorWritingBiasedRaw: inappropriate type (handle does not use file descriptors) +Left <stderr>: withFileDescriptorWritingBiasedRaw: inappropriate type (handle does not use file descriptors) +Right "_" +Right "_" +Right "_" ===================================== libraries/base/tests/IO/osHandles002FileDescriptors.hs ===================================== @@ -0,0 +1,28 @@ +import Data.Functor (void) +import Data.ByteString.Char8 (pack) +import System.Posix.Types (Fd (Fd), ByteCount) +import System.Posix.IO.ByteString (fdRead, fdWrite) +import System.IO (stdin, stdout, stderr) +import System.IO.OS + ( + withFileDescriptorReadingBiased, + withFileDescriptorWritingBiased + ) + +main :: IO () +main = withFileDescriptorReadingBiased stdin $ \ stdinFD -> + withFileDescriptorWritingBiased stdout $ \ stdoutFD -> + withFileDescriptorWritingBiased stderr $ \ stderrFD -> + do + regularMsg <- fdRead (Fd stdinFD) inputSizeApproximation + void $ fdWrite (Fd stdoutFD) regularMsg + void $ fdWrite (Fd stderrFD) (pack errorMsg) + where + + inputSizeApproximation :: ByteCount + inputSizeApproximation = 100 + + errorMsg :: String + errorMsg = "And every single door\n\ + \That I've walked through\n\ + \Brings me back, back here again\n" ===================================== libraries/base/tests/IO/osHandles002FileDescriptors.stderr ===================================== @@ -0,0 +1,3 @@ +And every single door +That I've walked through +Brings me back, back here again ===================================== libraries/base/tests/IO/osHandles002FileDescriptors.stdin ===================================== @@ -0,0 +1 @@ +We've got to get in to get out ===================================== libraries/base/tests/IO/osHandles002FileDescriptors.stdout ===================================== @@ -0,0 +1 @@ +We've got to get in to get out ===================================== libraries/base/tests/IO/osHandles002WindowsHandles.hs ===================================== @@ -0,0 +1,49 @@ +import Control.Monad (zipWithM_) +import Data.Functor (void) +import Data.Char (ord) +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Storable (pokeElemOff) +import System.IO (stdin, stdout, stderr) +import System.IO.OS + ( + withWindowsHandleReadingBiased, + withWindowsHandleWritingBiased + ) + +main :: IO () +main = withWindowsHandleReadingBiased stdin $ \ windowsStdin -> + withWindowsHandleWritingBiased stdout $ \ windowsStdout -> + withWindowsHandleWritingBiased stderr $ \ windowsStderr -> + do + withBuffer inputSizeApproximation $ \ bufferPtr -> do + inputSize <- win32_ReadFile windowsStdin + bufferPtr + inputSizeApproximation + Nothing + void $ win32_WriteFile windowsStdout + bufferPtr + inputSize + Nothing + withBuffer errorMsgSize $ \ bufferPtr -> do + zipWithM_ (pokeElemOff bufferPtr) + [0 ..] + (map (fromIntegral . ord) errorMsg) + void $ win32_WriteFile windowsStderr + bufferPtr + errorMsgSize + Nothing + where + + withBuffer :: DWORD -> (Ptr Word8 -> IO a) -> IO a + withBuffer = allocaBytes . fromIntegral + + inputSizeApproximation :: DWORD + inputSizeApproximation = 100 + + errorMsg :: String + errorMsg = "And every single door\n\ + \That I've walked through\n\ + \Brings me back, back here again\n" + + errorMsgSize :: DWORD + errorMsgSize = fromIntegral (length errorMsg) ===================================== libraries/base/tests/IO/osHandles002WindowsHandles.stderr ===================================== @@ -0,0 +1,3 @@ +And every single door +That I've walked through +Brings me back, back here again ===================================== libraries/base/tests/IO/osHandles002WindowsHandles.stdin ===================================== @@ -0,0 +1 @@ +We've got to get in to get out ===================================== libraries/base/tests/IO/osHandles002WindowsHandles.stdout ===================================== @@ -0,0 +1 @@ +We've got to get in to get out ===================================== libraries/base/tests/perf/Makefile ===================================== @@ -12,4 +12,4 @@ T17752: # All occurrences of elem should be optimized away. # For strings these should result in loops after inlining foldCString. # For lists it should result in a case expression. - echo $$(cat T17752.dump-simpl | grep "elem" -A4 ) + echo $$(grep -A4 "elem" T17752.dump-simpl) ===================================== libraries/ghc-internal/ghc-internal.cabal.in ===================================== @@ -328,6 +328,7 @@ Library GHC.Internal.System.Exit GHC.Internal.System.IO GHC.Internal.System.IO.Error + GHC.Internal.System.IO.OS GHC.Internal.System.Mem GHC.Internal.System.Mem.StableName GHC.Internal.System.Posix.Internals ===================================== libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs ===================================== @@ -0,0 +1,323 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} + +{-| + This module bridges between Haskell handles and underlying operating-system + features. +-} +module GHC.Internal.System.IO.OS +( + -- * Obtaining file descriptors and Windows handles + withFileDescriptorReadingBiased, + withFileDescriptorWritingBiased, + withWindowsHandleReadingBiased, + withWindowsHandleWritingBiased, + withFileDescriptorReadingBiasedRaw, + withFileDescriptorWritingBiasedRaw, + withWindowsHandleReadingBiasedRaw, + withWindowsHandleWritingBiasedRaw + + -- ** Caveats + -- $with-ref-caveats +) +where + +import GHC.Internal.Control.Monad (return) +import GHC.Internal.Control.Concurrent.MVar (MVar) +import GHC.Internal.Control.Exception (mask) +import GHC.Internal.Data.Function (const, (.), ($)) +import GHC.Internal.Data.Functor (fmap) +#if defined(mingw32_HOST_OS) +import GHC.Internal.Data.Bool (otherwise) +#endif +import GHC.Internal.Data.Maybe (Maybe (Nothing), maybe) +#if defined(mingw32_HOST_OS) +import GHC.Internal.Data.Maybe (Maybe (Just)) +#endif +import GHC.Internal.Data.List ((++)) +import GHC.Internal.Data.String (String) +import GHC.Internal.Data.Typeable (Typeable, cast) +import GHC.Internal.System.IO (IO) +import GHC.Internal.IO.FD (fdFD) +#if defined(mingw32_HOST_OS) +import GHC.Internal.IO.Windows.Handle + ( + NativeHandle, + ConsoleHandle, + IoHandle, + toHANDLE + ) +#endif +import GHC.Internal.IO.Handle.Types + ( + Handle (FileHandle, DuplexHandle), + Handle__ (Handle__, haDevice) + ) +import GHC.Internal.IO.Handle.Internals (withHandle_', flushBuffer) +import GHC.Internal.IO.Exception + ( + IOErrorType (InappropriateType), + IOException (IOError), + ioException + ) +import GHC.Internal.Foreign.Ptr (Ptr) +import GHC.Internal.Foreign.C.Types (CInt) + +-- * Obtaining POSIX file descriptors and Windows handles + +{-| + Executes a user-provided action on an operating-system handle that underlies + a Haskell handle. Before the user-provided action is run, user-defined + preparation based on the handle state that contains the operating-system + handle is performed. While the user-provided action is executed, further + operations on the Haskell handle are blocked to a degree that interference + with this action is prevented. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withOSHandle :: String + -- ^ The name of the overall operation + -> (Handle -> MVar Handle__) + {-^ + Obtaining of the handle state variable that holds the + operating-system handle + -} + -> (forall d. Typeable d => d -> IO a) + -- ^ Conversion of a device into an operating-system handle + -> (Handle__ -> IO ()) + -- ^ The preparation + -> Handle + -- ^ The Haskell handle to use + -> (a -> IO r) + -- ^ The action to execute on the operating-system handle + -> IO r +withOSHandle opName handleStateVar getOSHandle prepare handle act + = mask $ \ withOriginalMaskingState -> + withHandleState $ \ handleState@Handle__ {haDevice = dev} -> do + osHandle <- getOSHandle dev + prepare handleState + withOriginalMaskingState $ act osHandle + where + + withHandleState = withHandle_' opName handle (handleStateVar handle) +{- + The 'withHandle_'' operation, which we use here, already performs masking. + Still, we have to employ 'mask', in order do obtain the operation that + restores the original masking state. The user-provided action should be + executed with this original masking state, as there is no inherent reason to + generally perform it with masking in place. The masking that 'withHandle_'' + performs is only for safely accessing handle state and thus constitutes an + implementation detail; it has nothing to do with the user-provided action. +-} +{- + The order of actions in 'withOSHandle' is such that any exception from + 'getOSHandle' is thrown before the user-defined preparation is performed. +-} + +{-| + Obtains the handle state variable that underlies a handle or specifically + the handle state variable for reading if the handle uses different state + variables for reading and writing. +-} +handleStateVarReadingBiased :: Handle -> MVar Handle__ +handleStateVarReadingBiased (FileHandle _ var) = var +handleStateVarReadingBiased (DuplexHandle _ readingVar _) = readingVar + +{-| + Obtains the handle state variable that underlies a handle or specifically + the handle state variable for writing if the handle uses different state + variables for reading and writing. +-} +handleStateVarWritingBiased :: Handle -> MVar Handle__ +handleStateVarWritingBiased (FileHandle _ var) = var +handleStateVarWritingBiased (DuplexHandle _ _ writingVar) = writingVar + +{-| + Yields the result of another operation if that operation succeeded, and + otherwise throws an exception that signals that the other operation failed + because some Haskell handle does not use an operating-system handle of a + required type. +-} +requiringOSHandleOfType :: String + -- ^ The name of the operating-system handle type + -> Maybe a + {-^ + The result of the other operation if it succeeded + -} + -> IO a +requiringOSHandleOfType osHandleTypeName + = maybe (ioException osHandleOfTypeRequired) return + where + + osHandleOfTypeRequired :: IOException + osHandleOfTypeRequired + = IOError Nothing + InappropriateType + "" + ("handle does not use " ++ osHandleTypeName ++ "s") + Nothing + Nothing + +{-| + Obtains the POSIX file descriptor of a device if the device contains one, + and throws an exception otherwise. +-} +getFileDescriptor :: Typeable d => d -> IO CInt +getFileDescriptor = requiringOSHandleOfType "POSIX file descriptor" . + fmap fdFD . cast + +{-| + Obtains the Windows handle of a device if the device contains one, and + throws an exception otherwise. +-} +getWindowsHandle :: Typeable d => d -> IO (Ptr ()) +getWindowsHandle = requiringOSHandleOfType "Windows handle" . + toMaybeWindowsHandle + where + + toMaybeWindowsHandle :: Typeable d => d -> Maybe (Ptr ()) +#if defined(mingw32_HOST_OS) + toMaybeWindowsHandle dev + | Just nativeHandle <- cast dev :: Maybe (IoHandle NativeHandle) + = Just (toHANDLE nativeHandle) + | Just consoleHandle <- cast dev :: Maybe (IoHandle ConsoleHandle) + = Just (toHANDLE consoleHandle) + | otherwise + = Nothing + {- + This is inspired by the implementation of + 'System.Win32.Types.withHandleToHANDLENative'. + -} +#else + toMaybeWindowsHandle _ = Nothing +#endif + +{-| + Executes a user-provided action on the POSIX file descriptor that underlies + a handle or specifically on the POSIX file descriptor for reading if the + handle uses different file descriptors for reading and writing. The + Haskell-managed buffers related to the file descriptor are flushed before + the user-provided action is run. While this action is executed, further + operations on the handle are blocked to a degree that interference with this + action is prevented. + + If the handle does not use POSIX file descriptors, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withFileDescriptorReadingBiased :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorReadingBiased = withOSHandle "withFileDescriptorReadingBiased" + handleStateVarReadingBiased + getFileDescriptor + flushBuffer + +{-| + Executes a user-provided action on the POSIX file descriptor that underlies + a handle or specifically on the POSIX file descriptor for writing if the + handle uses different file descriptors for reading and writing. The + Haskell-managed buffers related to the file descriptor are flushed before + the user-provided action is run. While this action is executed, further + operations on the handle are blocked to a degree that interference with this + action is prevented. + + If the handle does not use POSIX file descriptors, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withFileDescriptorWritingBiased :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorWritingBiased = withOSHandle "withFileDescriptorWritingBiased" + handleStateVarWritingBiased + getFileDescriptor + flushBuffer + +{-| + Executes a user-provided action on the Windows handle that underlies a + Haskell handle or specifically on the Windows handle for reading if the + Haskell handle uses different Windows handles for reading and writing. The + Haskell-managed buffers related to the Windows handle are flushed before the + user-provided action is run. While this action is executed, further + operations on the Haskell handle are blocked to a degree that interference + with this action is prevented. + + If the Haskell handle does not use Windows handles, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withWindowsHandleReadingBiased :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleReadingBiased = withOSHandle "withWindowsHandleReadingBiased" + handleStateVarReadingBiased + getWindowsHandle + flushBuffer + +{-| + Executes a user-provided action on the Windows handle that underlies a + Haskell handle or specifically on the Windows handle for writing if the + Haskell handle uses different Windows handles for reading and writing. The + Haskell-managed buffers related to the Windows handle are flushed before the + user-provided action is run. While this action is executed, further + operations on the Haskell handle are blocked to a degree that interference + with this action is prevented. + + If the Haskell handle does not use Windows handles, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withWindowsHandleWritingBiased :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleWritingBiased = withOSHandle "withWindowsHandleWritingBiased" + handleStateVarWritingBiased + getWindowsHandle + flushBuffer + +{-| + Like 'withFileDescriptorReadingBiased' except that Haskell-managed buffers + are not flushed. +-} +withFileDescriptorReadingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorReadingBiasedRaw + = withOSHandle "withFileDescriptorReadingBiasedRaw" + handleStateVarReadingBiased + getFileDescriptor + (const $ return ()) + +{-| + Like 'withFileDescriptorWritingBiased' except that Haskell-managed buffers + are not flushed. +-} +withFileDescriptorWritingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorWritingBiasedRaw + = withOSHandle "withFileDescriptorWritingBiasedRaw" + handleStateVarWritingBiased + getFileDescriptor + (const $ return ()) + +{-| + Like 'withWindowsHandleReadingBiased' except that Haskell-managed buffers + are not flushed. +-} +withWindowsHandleReadingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleReadingBiasedRaw + = withOSHandle "withWindowsHandleReadingBiasedRaw" + handleStateVarReadingBiased + getWindowsHandle + (const $ return ()) + +{-| + Like 'withWindowsHandleWritingBiased' except that Haskell-managed buffers + are not flushed. +-} +withWindowsHandleWritingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleWritingBiasedRaw + = withOSHandle "withWindowsHandleWritingBiasedRaw" + handleStateVarWritingBiased + getWindowsHandle + (const $ return ()) + +-- ** Caveats + +{-$with-ref-caveats + #with-ref-caveats#This subsection is just a dummy, whose purpose is to serve + as the target of the hyperlinks above. The real documentation of the caveats + is in the /Caveats/ subsection in the @base@ module @System.IO.OS@, which + re-exports the above operations. +-} ===================================== testsuite/tests/driver/T16318/Makefile ===================================== @@ -7,5 +7,5 @@ test_pe = test-package-environment T16318: "$(GHC_PKG)" field base id --simple-output > $(test_pe) "$(TEST_HC)" $(TEST_HC_OPTS) -v1 -ignore-dot-ghci -package-env $(test_pe) -e "putStrLn \"Hello\"" > out 2>&1 - C=`cat out | grep "Loaded package environment" -c` ; \ + C=`grep -c "Loaded package environment" out` ; \ if [ $$C != "1" ]; then false; fi ===================================== testsuite/tests/driver/T18125/Makefile ===================================== @@ -9,5 +9,5 @@ T18125: "$(GHC_PKG)" field base id --simple-output > $(test_pe) "$(GHC_PKG)" field $(test_lib) id --simple-outpu >> $(test_pe) "$(TEST_HC)" $(TEST_HC_OPTS) -Wunused-packages -package-env $(test_pe) T18125.hs > out 2>&1 - C=`cat out | grep "$(test_lib)" -c` ; \ + C=`grep -c "$(test_lib)" out` ; \ if [ $$C != "1" ]; then false; fi ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -10048,6 +10048,17 @@ module System.IO.Error where userError :: GHC.Internal.Base.String -> IOError userErrorType :: IOErrorType +module System.IO.OS where + -- Safety: Safe + withFileDescriptorReadingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withFileDescriptorReadingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withFileDescriptorWritingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withFileDescriptorWritingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleReadingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleReadingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleWritingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleWritingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + module System.IO.Unsafe where -- Safety: Unsafe unsafeDupablePerformIO :: forall a. GHC.Internal.Types.IO a -> a ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -10086,6 +10086,17 @@ module System.IO.Error where userError :: GHC.Internal.Base.String -> IOError userErrorType :: IOErrorType +module System.IO.OS where + -- Safety: Safe + withFileDescriptorReadingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withFileDescriptorReadingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withFileDescriptorWritingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withFileDescriptorWritingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleReadingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleReadingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleWritingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleWritingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + module System.IO.Unsafe where -- Safety: Unsafe unsafeDupablePerformIO :: forall a. GHC.Internal.Types.IO a -> a ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -10328,6 +10328,17 @@ module System.IO.Error where userError :: GHC.Internal.Base.String -> IOError userErrorType :: IOErrorType +module System.IO.OS where + -- Safety: Safe + withFileDescriptorReadingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withFileDescriptorReadingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withFileDescriptorWritingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withFileDescriptorWritingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleReadingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleReadingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleWritingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleWritingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + module System.IO.Unsafe where -- Safety: Unsafe unsafeDupablePerformIO :: forall a. GHC.Internal.Types.IO a -> a ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -10048,6 +10048,17 @@ module System.IO.Error where userError :: GHC.Internal.Base.String -> IOError userErrorType :: IOErrorType +module System.IO.OS where + -- Safety: Safe + withFileDescriptorReadingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withFileDescriptorReadingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withFileDescriptorWritingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withFileDescriptorWritingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleReadingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleReadingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleWritingBiased :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + withWindowsHandleWritingBiasedRaw :: forall r. GHC.Internal.IO.Handle.Types.Handle -> (GHC.Internal.Ptr.Ptr () -> GHC.Internal.Types.IO r) -> GHC.Internal.Types.IO r + module System.IO.Unsafe where -- Safety: Unsafe unsafeDupablePerformIO :: forall a. GHC.Internal.Types.IO a -> a View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0b05ae7f3bab12fbb43cebdf18148e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0b05ae7f3bab12fbb43cebdf18148e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/26699] Refactoring after adding TTG extension
by recursion-ninja (＠recursion-ninja) 27 Jan '26

27 Jan '26

recursion-ninja pushed to branch wip/26699 at Glasgow Haskell Compiler / GHC Commits: 631825ab by Recursion Ninja at 2026-01-26T19:24:37-05:00 Refactoring after adding TTG extension - - - - - 22 changed files: - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Extension.hs - − compiler/GHC/Hs/Extension.hs-boot - compiler/GHC/Hs/Instances.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Parser.y - compiler/GHC/ThToHs.hs - compiler/GHC/Types/ImportLevel.hs - − compiler/GHC/Types/Name/RdrName.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/OverlapFlag.hs - compiler/GHC/Types/OverlapMode.hs - compiler/GHC/Types/SourceText.hs - compiler/GHC/Unit/Types.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax/Basic.hs - compiler/Language/Haskell/Syntax/Decls.hs - + compiler/Language/Haskell/Syntax/Decls/Overlap.hs - ghc/GHCi/UI.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs Changes: ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -101,6 +101,7 @@ module GHC.Hs.Decls ( import GHC.Prelude import Language.Haskell.Syntax.Decls +import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..)) import Language.Haskell.Syntax.Extension import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprUntypedSplice ) ===================================== compiler/GHC/Hs/Extension.hs ===================================== @@ -16,10 +16,11 @@ import GHC.Prelude import Data.Data hiding ( Fixity ) import Language.Haskell.Syntax.Extension import GHC.Types.Name -import GHC.Types.Name.RdrName +import GHC.Types.Name.Reader import GHC.Types.Var import GHC.Utils.Outputable hiding ((<>)) import GHC.Types.SrcLoc (GenLocated(..), unLoc) +import GHC.Utils.Panic import GHC.Parser.Annotation {- @@ -152,9 +153,9 @@ data GhcPass (c :: Pass) where -- This really should never be entered, but the data-deriving machinery -- needs the instance to exist. instance Typeable p => Data (GhcPass p) where - gunfold _ _ _ = error "instance Data GhcPass" - toConstr _ = error "instance Data GhcPass" - dataTypeOf _ = error "instance Data GhcPass" + gunfold _ _ _ = panic "instance Data GhcPass" + toConstr _ = panic "instance Data GhcPass" + dataTypeOf _ = panic "instance Data GhcPass" data Pass = Parsed | Renamed | Typechecked deriving (Data) ===================================== compiler/GHC/Hs/Extension.hs-boot deleted ===================================== @@ -1,34 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableSuperClasses #-} -- for IsPass; see Note [NoGhcTc] - -module GHC.Hs.Extension where - -import Data.Type.Equality (type (~)) - --- | Used as a data type index for the hsSyn AST; also serves --- as a singleton type for Pass -data GhcPass (c :: Pass) where - GhcPs :: GhcPass 'Parsed - GhcRn :: GhcPass 'Renamed - GhcTc :: GhcPass 'Typechecked - -data Pass = Parsed | Renamed | Typechecked - --- Type synonyms as a shorthand for tagging -type GhcPs = GhcPass 'Parsed -- Output of parser -type GhcRn = GhcPass 'Renamed -- Output of renamer -type GhcTc = GhcPass 'Typechecked -- Output of typechecker - -type family NoGhcTcPass (p :: Pass) :: Pass where - NoGhcTcPass 'Typechecked = 'Renamed - NoGhcTcPass other = other - -class ( NoGhcTcPass (NoGhcTcPass p) ~ NoGhcTcPass p - , IsPass (NoGhcTcPass p) - ) => IsPass p where - ghcPass :: GhcPass p ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -32,8 +32,8 @@ import GHC.Parser.Annotation import GHC.Types.Name.Reader (WithUserRdr(..)) import GHC.Types.InlinePragma (ActivationGhc) import GHC.Data.BooleanFormula (BooleanFormula(..)) -import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Decls +import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..)) import Language.Haskell.Syntax.Extension (Anno) import Language.Haskell.Syntax.Binds.InlinePragma (ActivationX(..), InlinePragma(..)) ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -72,6 +72,7 @@ import GHC.Types.ForeignCall import GHC.Types.Var import GHC.Types.Id import GHC.Types.InlinePragma +import GHC.Types.OverlapMode import GHC.Types.SourceText import GHC.Types.TyThing import GHC.Types.Name hiding( varName, tcName ) ===================================== compiler/GHC/Parser.y ===================================== @@ -70,6 +70,7 @@ import GHC.Types.Error ( GhcHint(..) ) import GHC.Types.Fixity import GHC.Types.ForeignCall import GHC.Types.InlinePragma +import GHC.Types.OverlapMode import GHC.Types.SourceFile import GHC.Types.SourceText import GHC.Types.PkgQual ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -39,10 +39,11 @@ import qualified GHC.Core.Coercion as Coercion ( Role(..) ) import GHC.Builtin.Types import GHC.Builtin.Types.Prim( fUNTyCon ) import GHC.Types.Basic as Hs -import GHC.Types.InlinePragma as Hs import GHC.Types.ForeignCall -import GHC.Types.Unique +import GHC.Types.InlinePragma as Hs +import GHC.Types.OverlapMode as Hs import GHC.Types.SourceText +import GHC.Types.Unique import GHC.Utils.Lexeme import GHC.Utils.Misc import GHC.Data.FastString ===================================== compiler/GHC/Types/ImportLevel.hs ===================================== @@ -1,7 +1,14 @@ {-# LANGUAGE DerivingVia #-} module GHC.Types.ImportLevel ( - ImportLevel(..), convImportLevel, convImportLevelSpec, allImportLevels, + -- * ImportLevel + -- ** Data-type + ImportLevel(..), + -- ** Enumeration + allImportLevels, + -- ** Conversion + convImportLevel, + convImportLevelSpec ) where import GHC.Prelude ===================================== compiler/GHC/Types/Name/RdrName.hs deleted ===================================== @@ -1,202 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE PatternSynonyms #-} - --- | --- Export /only/ the 'RdrName' data-type. --- --- Since 'RdrName' is an integral data-type found in many places throughout --- the compiler, importing a module which exposes 'RdrName' can cause module --- import cycles. By having a dedicated module which exports the bare minimum --- necessary to expose the data-type definition, these module import cycles --- can easily be avoided! -module GHC.Types.Name.RdrName ( - -- * The main type - RdrName(..), - WithUserRdr(..), - isExact_maybe, - rdrNameOcc, - ) where - -import GHC.Prelude - -import GHC.Types.Name -import GHC.Unit.Module -import GHC.Utils.Outputable - -import Data.Data -import qualified Data.Semigroup as S - -{- -************************************************************************ -* * -\subsection{The main data type} -* * -************************************************************************ --} - --- | Reader Name --- --- Do not use the data constructors of RdrName directly: prefer the family --- of functions that creates them, such as 'mkRdrUnqual' --- --- - Note: A Located RdrName will only have API Annotations if it is a --- compound one, --- e.g. --- --- > `bar` --- > ( ~ ) --- -data RdrName - = Unqual OccName - -- ^ Unqualified name - -- - -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. - -- Create such a 'RdrName' with 'mkRdrUnqual' - - | Qual ModuleName OccName - -- ^ Qualified name - -- - -- A qualified name written by the user in - -- /source/ code. The module isn't necessarily - -- the module where the thing is defined; - -- just the one from which it is imported. - -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. - -- Create such a 'RdrName' with 'mkRdrQual' - - | Orig Module OccName - -- ^ Original name - -- - -- An original name; the module is the /defining/ module. - -- This is used when GHC generates code that will be fed - -- into the renamer (e.g. from deriving clauses), but where - -- we want to say \"Use Prelude.map dammit\". One of these - -- can be created with 'mkOrig' - - | Exact Name - -- ^ Exact name - -- - -- We know exactly the 'Name'. This is used: - -- - -- (1) When the parser parses built-in syntax like @[]@ - -- and @(,)@, but wants a 'RdrName' from it - -- - -- (2) By Template Haskell, when TH has generated a unique name - -- - -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' - deriving Data - -{- -************************************************************************ -* * -\subsection{Instances} -* * -************************************************************************ --} - -instance Eq RdrName where - (Exact n1) == (Exact n2) = n1==n2 - -- Convert exact to orig - (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 - r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 - - (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 - (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 - (Unqual o1) == (Unqual o2) = o1==o2 - _ == _ = False - -instance HasOccName RdrName where - occName = rdrNameOcc - -instance Ord RdrName where - a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } - a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } - a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } - a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - - -- Exact < Unqual < Qual < Orig - -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig - -- before comparing so that Prelude.map == the exact Prelude.map, but - -- that meant that we reported duplicates when renaming bindings - -- generated by Template Haskell; e.g - -- do { n1 <- newName "foo"; n2 <- newName "foo"; - -- <decl involving n1,n2> } - -- I think we can do without this conversion - compare (Exact n1) (Exact n2) = n1 `compare` n2 - compare (Exact _) _ = LT - - compare (Unqual _) (Exact _) = GT - compare (Unqual o1) (Unqual o2) = o1 `compare` o2 - compare (Unqual _) _ = LT - - compare (Qual _ _) (Exact _) = GT - compare (Qual _ _) (Unqual _) = GT - compare (Qual m1 o1) (Qual m2 o2) = compare o1 o2 S.<> compare m1 m2 - compare (Qual _ _) (Orig _ _) = LT - - compare (Orig m1 o1) (Orig m2 o2) = compare o1 o2 S.<> compare m1 m2 - compare (Orig _ _) _ = GT - -instance Outputable RdrName where - ppr (Exact name) = ppr name - ppr (Unqual occ) = ppr occ - ppr (Qual mod occ) = ppr mod <> dot <> ppr occ - ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod Nothing occ <> ppr occ) - -instance OutputableBndr RdrName where - pprBndr _ n - | isTvOcc (rdrNameOcc n) = char '@' <> ppr n - | otherwise = ppr n - - pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) - pprPrefixOcc rdr - | Just name <- isExact_maybe rdr = pprPrefixName name - -- pprPrefixName has some special cases, so - -- we delegate to them rather than reproduce them - | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) - -isExact_maybe :: RdrName -> Maybe Name -isExact_maybe (Exact n) = Just n -isExact_maybe _ = Nothing - -nukeExact :: Name -> RdrName -nukeExact n - | isExternalName n = Orig (nameModule n) (nameOccName n) - | otherwise = Unqual (nameOccName n) - -rdrNameOcc :: RdrName -> OccName -rdrNameOcc (Qual _ occ) = occ -rdrNameOcc (Unqual occ) = occ -rdrNameOcc (Orig _ occ) = occ -rdrNameOcc (Exact name) = nameOccName name - -rdrQual_maybe :: RdrName -> Maybe ModuleName -rdrQual_maybe = \case - Qual q _ -> Just q - _ -> Nothing - --------------------------------------------------------------------------------- --- Preserving user-written qualification - --- | 'WithUserRdr' allows us to keep track of the original user-written --- 'RdrName', and in particular, any user-written module qualification. --- --- See Note [IdOcc] in Language.Haskell.Syntax.Extension. -data WithUserRdr a = WithUserRdr RdrName a - deriving stock (Functor, Foldable, Traversable) - -instance NamedThing a => NamedThing (WithUserRdr a) where - getName (WithUserRdr _rdr a) = getName a -instance Outputable (WithUserRdr Name) where - ppr (WithUserRdr rdr name) = - pprName_userQual (rdrQual_maybe rdr) name -instance OutputableBndr (WithUserRdr Name) where - pprBndr _ (WithUserRdr rdr name) = - pprName_userQual (rdrQual_maybe rdr) name - pprInfixOcc :: WithUserRdr Name -> SDoc - pprInfixOcc = pprInfixName - pprPrefixOcc = pprPrefixName ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -117,13 +117,12 @@ import GHC.Data.FastString import GHC.Data.Maybe import GHC.Types.Avail -import GHC.Types.Basic +import GHC.Types.Basic ( TyConFlavour(..), tyConFlavourAssoc_maybe ) import GHC.Types.FieldLabel import GHC.Types.GREInfo import GHC.Types.ImportLevel import GHC.Types.Name import GHC.Types.Name.Env -import GHC.Types.Name.RdrName import GHC.Types.Name.Set import GHC.Types.PkgQual import GHC.Types.SrcLoc as SrcLoc @@ -152,6 +151,65 @@ import qualified Data.Map.Strict as Map import qualified Data.Semigroup as S import System.IO.Unsafe ( unsafePerformIO ) +{- +************************************************************************ +* * +\subsection{The main data type} +* * +************************************************************************ +-} + +-- | Reader Name +-- +-- Do not use the data constructors of RdrName directly: prefer the family +-- of functions that creates them, such as 'mkRdrUnqual' +-- +-- - Note: A Located RdrName will only have API Annotations if it is a +-- compound one, +-- e.g. +-- +-- > `bar` +-- > ( ~ ) +-- +data RdrName + = Unqual OccName + -- ^ Unqualified name + -- + -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. + -- Create such a 'RdrName' with 'mkRdrUnqual' + + | Qual ModuleName OccName + -- ^ Qualified name + -- + -- A qualified name written by the user in + -- /source/ code. The module isn't necessarily + -- the module where the thing is defined; + -- just the one from which it is imported. + -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. + -- Create such a 'RdrName' with 'mkRdrQual' + + | Orig Module OccName + -- ^ Original name + -- + -- An original name; the module is the /defining/ module. + -- This is used when GHC generates code that will be fed + -- into the renamer (e.g. from deriving clauses), but where + -- we want to say \"Use Prelude.map dammit\". One of these + -- can be created with 'mkOrig' + + | Exact Name + -- ^ Exact name + -- + -- We know exactly the 'Name'. This is used: + -- + -- (1) When the parser parses built-in syntax like @[]@ + -- and @(,)@, but wants a 'RdrName' from it + -- + -- (2) By Template Haskell, when TH has generated a unique name + -- + -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' + deriving Data + {- ************************************************************************ * * @@ -160,6 +218,15 @@ import System.IO.Unsafe ( unsafePerformIO ) ************************************************************************ -} +instance HasOccName RdrName where + occName = rdrNameOcc + +rdrNameOcc :: RdrName -> OccName +rdrNameOcc (Qual _ occ) = occ +rdrNameOcc (Unqual occ) = occ +rdrNameOcc (Orig _ occ) = occ +rdrNameOcc (Exact name) = nameOccName name + rdrNameSpace :: RdrName -> NameSpace rdrNameSpace = occNameSpace . rdrNameOcc @@ -226,6 +293,11 @@ nameRdrName name = Exact name -- unique is still there for debug printing, particularly -- of Types (which are converted to IfaceTypes before printing) +nukeExact :: Name -> RdrName +nukeExact n + | isExternalName n = Orig (nameModule n) (nameOccName n) + | otherwise = Unqual (nameOccName n) + isRdrDataCon :: RdrName -> Bool isRdrTyVar :: RdrName -> Bool isRdrTc :: RdrName -> Bool @@ -263,6 +335,76 @@ isExact :: RdrName -> Bool isExact (Exact _) = True isExact _ = False +isExact_maybe :: RdrName -> Maybe Name +isExact_maybe (Exact n) = Just n +isExact_maybe _ = Nothing + +{- +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Outputable RdrName where + ppr (Exact name) = ppr name + ppr (Unqual occ) = ppr occ + ppr (Qual mod occ) = ppr mod <> dot <> ppr occ + ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod Nothing occ <> ppr occ) + +instance OutputableBndr RdrName where + pprBndr _ n + | isTvOcc (rdrNameOcc n) = char '@' <> ppr n + | otherwise = ppr n + + pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + pprPrefixOcc rdr + | Just name <- isExact_maybe rdr = pprPrefixName name + -- pprPrefixName has some special cases, so + -- we delegate to them rather than reproduce them + | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + +instance Eq RdrName where + (Exact n1) == (Exact n2) = n1==n2 + -- Convert exact to orig + (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 + r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 + + (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 + (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 + (Unqual o1) == (Unqual o2) = o1==o2 + _ == _ = False + +instance Ord RdrName where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + + -- Exact < Unqual < Qual < Orig + -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig + -- before comparing so that Prelude.map == the exact Prelude.map, but + -- that meant that we reported duplicates when renaming bindings + -- generated by Template Haskell; e.g + -- do { n1 <- newName "foo"; n2 <- newName "foo"; + -- <decl involving n1,n2> } + -- I think we can do without this conversion + compare (Exact n1) (Exact n2) = n1 `compare` n2 + compare (Exact _) _ = LT + + compare (Unqual _) (Exact _) = GT + compare (Unqual o1) (Unqual o2) = o1 `compare` o2 + compare (Unqual _) _ = LT + + compare (Qual _ _) (Exact _) = GT + compare (Qual _ _) (Unqual _) = GT + compare (Qual m1 o1) (Qual m2 o2) = compare o1 o2 S.<> compare m1 m2 + compare (Qual _ _) (Orig _ _) = LT + + compare (Orig m1 o1) (Orig m2 o2) = compare o1 o2 S.<> compare m1 m2 + compare (Orig _ _) _ = GT + {- ************************************************************************ * * @@ -2076,6 +2218,29 @@ pprLoc (UnhelpfulSpan {}) = empty opIsAt :: RdrName -> Bool opIsAt e = e == mkUnqual varName (fsLit "@") + +-------------------------------------------------------------------------------- +-- Preserving user-written qualification + +-- | 'WithUserRdr' allows us to keep track of the original user-written +-- 'RdrName', and in particular, any user-written module qualification. +-- +-- See Note [IdOcc] in Language.Haskell.Syntax.Extension. +data WithUserRdr a = WithUserRdr RdrName a + deriving stock (Functor, Foldable, Traversable) + +instance NamedThing a => NamedThing (WithUserRdr a) where + getName (WithUserRdr _rdr a) = getName a +instance Outputable (WithUserRdr Name) where + ppr (WithUserRdr rdr name) = + pprName_userQual (rdrQual_maybe rdr) name +instance OutputableBndr (WithUserRdr Name) where + pprBndr _ (WithUserRdr rdr name) = + pprName_userQual (rdrQual_maybe rdr) name + pprInfixOcc :: WithUserRdr Name -> SDoc + pprInfixOcc = pprInfixName + pprPrefixOcc = pprPrefixName + unLocWithUserRdr :: GenLocated l (WithUserRdr a) -> a unLocWithUserRdr (L _ (WithUserRdr _ a)) = a @@ -2084,3 +2249,10 @@ noUserRdr n = WithUserRdr (nameRdrName n) n userRdrName :: WithUserRdr Name -> RdrName userRdrName (WithUserRdr rdr _) = rdr + +rdrQual_maybe :: RdrName -> Maybe ModuleName +rdrQual_maybe = \case + Qual q _ -> Just q + _ -> Nothing + +-------------------------------------------------------------------------------- ===================================== compiler/GHC/Types/OverlapFlag.hs ===================================== @@ -41,7 +41,7 @@ import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Types.OverlapMode (changeOverlapModePass) -import Language.Haskell.Syntax.Basic (OverlapMode(..)) +import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..)) import Control.DeepSeq (NFData(..)) ===================================== compiler/GHC/Types/OverlapMode.hs ===================================== @@ -5,6 +5,13 @@ {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{- + * (type class): Binary OverlapMode + * (type family): XOverlapMode (GhcPass p) + * (type family): XXOverlapMode (GhcPass p) +-} + module GHC.Types.OverlapMode ( -- * OverlapMode -- ** Data-type @@ -21,15 +28,13 @@ module GHC.Types.OverlapMode ( import GHC.Prelude -import {-# SOURCE #-} GHC.Hs.Extension (GhcPass) - +import GHC.Hs.Extension (GhcPass) import GHC.Types.SourceText +import GHC.Utils.Binary -import Language.Haskell.Syntax.Basic (OverlapMode(..)) +import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..)) import Language.Haskell.Syntax.Extension -import Control.DeepSeq ( NFData(..) ) - type instance XOverlapMode (GhcPass _) = SourceText type instance XXOverlapMode (GhcPass _) = DataConCantHappen @@ -77,3 +82,21 @@ hasNonCanonicalFlag :: OverlapMode (GhcPass p) -> Bool hasNonCanonicalFlag = \case NonCanonical{} -> True _ -> False + +instance Binary (OverlapMode (GhcPass p)) where + put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s + put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s + put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s + put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s + put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s + put_ bh (NonCanonical s) = putByte bh 5 >> put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> (get bh) >>= \s -> return $ NoOverlap s + 1 -> (get bh) >>= \s -> return $ Overlaps s + 2 -> (get bh) >>= \s -> return $ Incoherent s + 3 -> (get bh) >>= \s -> return $ Overlapping s + 4 -> (get bh) >>= \s -> return $ Overlappable s + _ -> (get bh) >>= \s -> return $ NonCanonical s ===================================== compiler/GHC/Types/SourceText.hs ===================================== @@ -32,6 +32,7 @@ import GHC.Prelude import GHC.Data.FastString import GHC.Utils.Outputable +import GHC.Utils.Binary import GHC.Utils.Panic import Data.Function (on) @@ -112,6 +113,21 @@ instance NFData SourceText where SourceText s -> rnf s NoSourceText -> () +instance Binary SourceText where + put_ bh NoSourceText = putByte bh 0 + put_ bh (SourceText s) = do + putByte bh 1 + put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> return NoSourceText + 1 -> do + s <- get bh + return (SourceText s) + _ -> panic $ "Binary SourceText:" ++ show h + -- | Special combinator for showing string literals. pprWithSourceText :: SourceText -> SDoc -> SDoc pprWithSourceText NoSourceText d = d ===================================== compiler/GHC/Unit/Types.hs ===================================== @@ -82,6 +82,7 @@ import GHC.Prelude import GHC.Types.Unique import GHC.Types.Unique.DSet +import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Utils.Encoding @@ -135,6 +136,11 @@ mkModule = Module instance Uniquable Module where getUnique (Module p n) = getUnique (unitFS p `appendFS` moduleNameFS n) +instance Binary a => Binary (GenModule a) where + put_ bh (Module p n) = put_ bh p >> put_ bh n + -- Module has strict fields, so use $! in order not to allocate a thunk + get bh = do p <- get bh; n <- get bh; return $! Module p n + instance NFData (GenModule a) where rnf (Module unit name) = unit `seq` name `seq` () @@ -293,6 +299,23 @@ instance Eq (GenInstantiatedUnit unit) where instance Ord (GenInstantiatedUnit unit) where u1 `compare` u2 = instUnitFS u1 `lexicalCompareFS` instUnitFS u2 +instance Binary InstantiatedUnit where + put_ bh indef = do + put_ bh (instUnitInstanceOf indef) + put_ bh (instUnitInsts indef) + get bh = do + cid <- get bh + insts <- get bh + let fs = mkInstantiatedUnitHash cid insts + -- InstantiatedUnit has strict fields, so use $! in order not to allocate a thunk + return $! InstantiatedUnit { + instUnitInstanceOf = cid, + instUnitInsts = insts, + instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), + instUnitFS = fs, + instUnitKey = getUnique fs + } + instance IsUnitId u => Eq (GenUnit u) where uid1 == uid2 = unitUnique uid1 == unitUnique uid2 @@ -326,6 +349,24 @@ pprUnit HoleUnit = ftext holeFS instance Show Unit where show = unitString +-- Performance: would prefer to have a NameCache like thing +instance Binary Unit where + put_ bh (RealUnit def_uid) = do + putByte bh 0 + put_ bh def_uid + put_ bh (VirtUnit indef_uid) = do + putByte bh 1 + put_ bh indef_uid + put_ bh HoleUnit = + putByte bh 2 + get bh = do b <- getByte bh + u <- case b of + 0 -> fmap RealUnit (get bh) + 1 -> fmap VirtUnit (get bh) + _ -> pure HoleUnit + -- Unit has strict fields that need forcing; otherwise we allocate a thunk. + pure $! u + -- | Retrieve the set of free module holes of a 'Unit'. unitFreeModuleHoles :: GenUnit u -> UniqDSet ModuleName unitFreeModuleHoles (VirtUnit x) = instUnitHoles x @@ -468,6 +509,10 @@ newtype UnitId = UnitId instance NFData UnitId where rnf (UnitId fs) = rnf fs `seq` () +instance Binary UnitId where + put_ bh (UnitId fs) = put_ bh fs + get bh = do fs <- get bh; return (UnitId fs) + instance Eq UnitId where uid1 == uid2 = getUnique uid1 == getUnique uid2 @@ -503,7 +548,7 @@ stringToUnitId = UnitId . mkFastString -- | A definite unit (i.e. without any free module hole) newtype Definite unit = Definite { unDefinite :: unit } deriving (Functor) - deriving newtype (Eq, Ord, Outputable, Uniquable, IsUnitId) + deriving newtype (Eq, Ord, Outputable, Binary, Uniquable, IsUnitId) --------------------------------------------------------------------- -- WIRED-IN UNITS @@ -651,6 +696,15 @@ type ModuleNameWithIsBoot = GenWithIsBoot ModuleName type ModuleWithIsBoot = GenWithIsBoot Module +instance Binary a => Binary (GenWithIsBoot a) where + put_ bh (GWIB { gwib_mod, gwib_isBoot }) = do + put_ bh gwib_mod + put_ bh gwib_isBoot + get bh = do + gwib_mod <- get bh + gwib_isBoot <- get bh + pure $ GWIB { gwib_mod, gwib_isBoot } + instance Outputable a => Outputable (GenWithIsBoot a) where ppr (GWIB { gwib_mod, gwib_isBoot }) = hsep $ ppr gwib_mod : case gwib_isBoot of IsBoot -> [ text "{-# SOURCE #-}" ] ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -120,8 +120,8 @@ import GHC.Prelude import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Binds.InlinePragma import Language.Haskell.Syntax.Module.Name (ModuleName(..)) +import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..)) -import {-# SOURCE #-} GHC.Hs.Extension (GhcPass) import {-# SOURCE #-} GHC.Types.Name (Name) import GHC.Data.FastString import GHC.Data.TrieMap @@ -130,19 +130,14 @@ import GHC.Utils.Panic.Plain import GHC.Types.Unique.FM import GHC.Data.FastMutInt import GHC.Utils.Fingerprint -import GHC.Types.OverlapMode -import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Types.Unique -import GHC.Unit.Types import qualified GHC.Data.Strict as Strict import GHC.Utils.Outputable( JoinPointHood(..) ) import GHCi.FFI import GHCi.Message -import GHC.Types.Unique.DSet ( unionManyUniqDSets ) - -import Control.DeepSeq ( NFData(..) ) +import Control.DeepSeq import Control.Monad ( when, (<$!>), unless, forM_, void ) import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void) import Data.Array @@ -2017,85 +2012,6 @@ instance NFData a => NFData (FingerprintWithValue a) where rnf (FingerprintWithValue fp mflags) = rnf fp `seq` rnf mflags `seq` () -instance Binary SourceText where - put_ bh NoSourceText = putByte bh 0 - put_ bh (SourceText s) = do - putByte bh 1 - put_ bh s - - get bh = do - h <- getByte bh - case h of - 0 -> return NoSourceText - 1 -> do - s <- get bh - return (SourceText s) - _ -> panic $ "Binary SourceText:" ++ show h - --------------------------------------------------------------------------------- --- Instances for the GHC.Unit.Types module --------------------------------------------------------------------------------- - -instance Binary a => Binary (GenModule a) where - put_ bh (Module p n) = put_ bh p >> put_ bh n - -- Module has strict fields, so use $! in order not to allocate a thunk - get bh = do p <- get bh; n <- get bh; return $! Module p n - -instance Binary InstantiatedUnit where - put_ bh indef = do - put_ bh (instUnitInstanceOf indef) - put_ bh (instUnitInsts indef) - get bh = do - cid <- get bh - insts <- get bh - let fs = mkInstantiatedUnitHash cid insts - -- InstantiatedUnit has strict fields, so use $! in order not to allocate a t\ -hunk - return $! InstantiatedUnit { - instUnitInstanceOf = cid, - instUnitInsts = insts, - instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) ins\ -ts), - instUnitFS = fs, - instUnitKey = getUnique fs - } - --- Performance: would prefer to have a NameCache like thing -instance Binary Unit where - put_ bh (RealUnit def_uid) = do - putByte bh 0 - put_ bh def_uid - put_ bh (VirtUnit indef_uid) = do - putByte bh 1 - put_ bh indef_uid - put_ bh HoleUnit = - putByte bh 2 - get bh = do b <- getByte bh - u <- case b of - 0 -> fmap RealUnit (get bh) - 1 -> fmap VirtUnit (get bh) - _ -> pure HoleUnit - -- Unit has strict fields that need forcing; otherwise we allocate \ -a thunk. - pure $! u - -instance Binary UnitId where - put_ bh (UnitId fs) = put_ bh fs - get bh = do fs <- get bh; return (UnitId fs) - -instance Binary a => Binary (GenWithIsBoot a) where - put_ bh (GWIB { gwib_mod, gwib_isBoot }) = do - put_ bh gwib_mod - put_ bh gwib_isBoot - get bh = do - gwib_mod <- get bh - gwib_isBoot <- get bh - pure $ GWIB { gwib_mod, gwib_isBoot } - -deriving newtype instance Binary x => Binary (Definite x) - --------------------------------------------------------------------------------- - instance Binary Boxity where -- implemented via isBoxed-isomorphism to Bool put_ bh = put_ bh . isBoxed get bh = do @@ -2164,21 +2080,3 @@ instance Binary RuleMatchInfo where h <- getByte bh if h == 1 then pure ConLike else pure FunLike - -instance Binary (OverlapMode (GhcPass p)) where - put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s - put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s - put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s - put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s - put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s - put_ bh (NonCanonical s) = putByte bh 5 >> put_ bh s - - get bh = do - h <- getByte bh - case h of - 0 -> (get bh) >>= \s -> return $ NoOverlap s - 1 -> (get bh) >>= \s -> return $ Overlaps s - 2 -> (get bh) >>= \s -> return $ Incoherent s - 3 -> (get bh) >>= \s -> return $ Overlapping s - 4 -> (get bh) >>= \s -> return $ Overlappable s - _ -> (get bh) >>= \s -> return $ NonCanonical s ===================================== compiler/GHC/Utils/Outputable.hs ===================================== @@ -114,6 +114,7 @@ import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName ) import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Binds.InlinePragma +import Language.Haskell.Syntax.Decls.Overlap ( OverlapMode(..) ) import Language.Haskell.Syntax.Module.Name ( ModuleName(..) ) import GHC.Prelude.Basic ===================================== compiler/Language/Haskell/Syntax/Basic.hs ===================================== @@ -3,8 +3,11 @@ {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Eq XOverlapMode, NFData OverlapMode +-- | Data-type defintions of the Abstrast Sytntax Tree +-- which *do not* have any /Trees That Grow/ extension points. module Language.Haskell.Syntax.Basic where +import Control.DeepSeq import Data.Data (Data) import Data.Eq import Data.Ord @@ -12,8 +15,6 @@ import Data.Bool import Prelude import GHC.Data.FastString (FastString) -import Language.Haskell.Syntax.Extension -import Control.DeepSeq {- ************************************************************************ @@ -161,81 +162,3 @@ data Fixity = Fixity Int FixityDirection instance NFData Fixity where rnf (Fixity i d) = rnf i `seq` rnf d `seq` () - -data OverlapMode pass -- See Note [Rules for instance lookup] in GHC.Core.InstEnv - = NoOverlap (XOverlapMode pass) - -- See Note [Pragma source text] - -- ^ This instance must not overlap another `NoOverlap` instance. - -- However, it may be overlapped by `Overlapping` instances, - -- and it may overlap `Overlappable` instances. - - - | Overlappable (XOverlapMode pass) - -- See Note [Pragma source text] - -- ^ Silently ignore this instance if you find a - -- more specific one that matches the constraint - -- you are trying to resolve - -- - -- Example: constraint (Foo [Int]) - -- instance Foo [Int] - -- instance {-# OVERLAPPABLE #-} Foo [a] - -- - -- Since the second instance has the Overlappable flag, - -- the first instance will be chosen (otherwise - -- its ambiguous which to choose) - - | Overlapping (XOverlapMode pass) - -- See Note [Pragma source text] - -- ^ Silently ignore any more general instances that may be - -- used to solve the constraint. - -- - -- Example: constraint (Foo [Int]) - -- instance {-# OVERLAPPING #-} Foo [Int] - -- instance Foo [a] - -- - -- Since the first instance has the Overlapping flag, - -- the second---more general---instance will be ignored (otherwise - -- it is ambiguous which to choose) - - | Overlaps (XOverlapMode pass) - -- See Note [Pragma source text] - -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags. - - | Incoherent (XOverlapMode pass) - -- See Note [Pragma source text] - -- ^ Behave like Overlappable and Overlapping, and in addition pick - -- an arbitrary one if there are multiple matching candidates, and - -- don't worry about later instantiation - -- - -- Example: constraint (Foo [b]) - -- instance {-# INCOHERENT -} Foo [Int] - -- instance Foo [a] - -- Without the Incoherent flag, we'd complain that - -- instantiating 'b' would change which instance - -- was chosen. See also Note [Incoherent instances] in "GHC.Core.InstEnv" - - | NonCanonical (XOverlapMode pass) - -- ^ Behave like Incoherent, but the instance choice is observable - -- by the program behaviour. See Note [Coherence and specialisation: overview]. - -- - -- We don't have surface syntax for the distinction between - -- Incoherent and NonCanonical instances; instead, the flag - -- `-f{no-}specialise-incoherents` (on by default) controls - -- whether `INCOHERENT` instances are regarded as Incoherent or - -- NonCanonical. - - | XOverlapMode !(XXOverlapMode pass) - -- ^ The /Trees That Grow/ extension point constructor. - -deriving instance ( Eq (XOverlapMode pass) - , Eq (XXOverlapMode pass)) => Eq (OverlapMode pass) - -instance ( NFData (XOverlapMode pass) - , XXOverlapMode pass ~ DataConCantHappen) => NFData (OverlapMode pass) where - rnf = \case - NoOverlap s -> rnf s - Overlappable s -> rnf s - Overlapping s -> rnf s - Overlaps s -> rnf s - Incoherent s -> rnf s - NonCanonical s -> rnf s ===================================== compiler/Language/Haskell/Syntax/Decls.hs ===================================== @@ -88,16 +88,17 @@ module Language.Haskell.Syntax.Decls ( -- friends: import {-# SOURCE #-} Language.Haskell.Syntax.Expr - ( HsExpr, HsUntypedSplice ) + (HsExpr, HsUntypedSplice) -- Because Expr imports Decls via HsBracket -import Language.Haskell.Syntax.Basic (OverlapMode, RuleName, TopLevelFlag) +import Language.Haskell.Syntax.Basic + (LexicalFixity, Role, RuleName, TopLevelFlag) import Language.Haskell.Syntax.Binds import Language.Haskell.Syntax.Binds.InlinePragma (Activation) +import Language.Haskell.Syntax.Decls.Overlap (OverlapMode) import Language.Haskell.Syntax.Extension -import Language.Haskell.Syntax.Type -import Language.Haskell.Syntax.Basic (Role, LexicalFixity) import Language.Haskell.Syntax.Specificity (Specificity) +import Language.Haskell.Syntax.Type import GHC.Types.ForeignCall (CType, CCallConv, Safety, Header, CLabelString, CCallTarget, CExportSpec) @@ -118,7 +119,7 @@ import Prelude (Show) import Data.Foldable import Data.Traversable import Data.List.NonEmpty (NonEmpty (..)) -import GHC.Generics ( Generic ) +import GHC.Generics (Generic) {- ===================================== compiler/Language/Haskell/Syntax/Decls/Overlap.hs ===================================== @@ -0,0 +1,96 @@ +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- Eq XOverlapMode, NFData OverlapMode + +{- | +Data-type describing the state of "overlapping instances" for a type. +-} +module Language.Haskell.Syntax.Decls.Overlap where + +import Control.DeepSeq +import Data.Eq +import Prelude + +import Language.Haskell.Syntax.Extension + +-- | The status of overlapping instances /(including no overlap)/ for a type. +data OverlapMode pass -- See Note [Rules for instance lookup] in GHC.Core.InstEnv + = NoOverlap (XOverlapMode pass) + -- See Note [Pragma source text] + -- ^ This instance must not overlap another `NoOverlap` instance. + -- However, it may be overlapped by `Overlapping` instances, + -- and it may overlap `Overlappable` instances. + + + | Overlappable (XOverlapMode pass) + -- See Note [Pragma source text] + -- ^ Silently ignore this instance if you find a + -- more specific one that matches the constraint + -- you are trying to resolve + -- + -- Example: constraint (Foo [Int]) + -- instance Foo [Int] + -- instance {-# OVERLAPPABLE #-} Foo [a] + -- + -- Since the second instance has the Overlappable flag, + -- the first instance will be chosen (otherwise + -- its ambiguous which to choose) + + | Overlapping (XOverlapMode pass) + -- See Note [Pragma source text] + -- ^ Silently ignore any more general instances that may be + -- used to solve the constraint. + -- + -- Example: constraint (Foo [Int]) + -- instance {-# OVERLAPPING #-} Foo [Int] + -- instance Foo [a] + -- + -- Since the first instance has the Overlapping flag, + -- the second---more general---instance will be ignored (otherwise + -- it is ambiguous which to choose) + + | Overlaps (XOverlapMode pass) + -- See Note [Pragma source text] + -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags. + + | Incoherent (XOverlapMode pass) + -- See Note [Pragma source text] + -- ^ Behave like Overlappable and Overlapping, and in addition pick + -- an arbitrary one if there are multiple matching candidates, and + -- don't worry about later instantiation + -- + -- Example: constraint (Foo [b]) + -- instance {-# INCOHERENT -} Foo [Int] + -- instance Foo [a] + -- Without the Incoherent flag, we'd complain that + -- instantiating 'b' would change which instance + -- was chosen. See also Note [Incoherent instances] in "GHC.Core.InstEnv" + + | NonCanonical (XOverlapMode pass) + -- ^ Behave like Incoherent, but the instance choice is observable + -- by the program behaviour. See Note [Coherence and specialisation: overview]. + -- + -- We don't have surface syntax for the distinction between + -- Incoherent and NonCanonical instances; instead, the flag + -- `-f{no-}specialise-incoherents` (on by default) controls + -- whether `INCOHERENT` instances are regarded as Incoherent or + -- NonCanonical. + + | XOverlapMode !(XXOverlapMode pass) + -- ^ The /Trees That Grow/ extension point constructor. + +deriving instance ( Eq (XOverlapMode pass) + , Eq (XXOverlapMode pass) + ) => Eq (OverlapMode pass) + +instance ( NFData (XOverlapMode pass) + , XXOverlapMode pass ~ DataConCantHappen + ) => NFData (OverlapMode pass) where + rnf = \case + NoOverlap s -> rnf s + Overlappable s -> rnf s + Overlapping s -> rnf s + Overlaps s -> rnf s + Incoherent s -> rnf s + NonCanonical s -> rnf s ===================================== ghc/GHCi/UI.hs ===================================== @@ -75,6 +75,7 @@ import GHC.Core.TyCo.Ppr import GHC.Types.SafeHaskell ( getSafeMode ) import GHC.Types.SourceError ( SourceError, initSourceErrorContext ) import GHC.Types.Name +import GHC.Types.ImportLevel ( convImportLevel ) import GHC.Types.Var ( varType ) import GHC.Iface.Syntax ( showToHeader ) import GHC.Builtin.Names ===================================== utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs ===================================== @@ -40,7 +40,7 @@ import GHC.Driver.DynFlags (getDynFlags) import GHC.Types.Basic (TupleSort (..)) import GHC.Types.Name import GHC.Types.Name.Reader (RdrName (Exact)) -import GHC.Types.OverlapMode (changeOverlapModeType) +import GHC.Types.OverlapMode (OverlapMode, changeOverlapModeType) import Language.Haskell.Syntax.BooleanFormula(BooleanFormula(..)) import Haddock.Backends.Hoogle (ppExportD) ===================================== utils/haddock/haddock-api/src/Haddock/Types.hs ===================================== @@ -59,6 +59,7 @@ import GHC.Core.InstEnv (is_dfun_name) import GHC.Types.Name (stableNameCmp) import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader (RdrName (..)) +import GHC.Types.OverlapMode (OverlapMode) import GHC.Types.SrcLoc (srcSpanToRealSrcSpan) import GHC.Types.Var (Specificity) import GHC.Utils.Outputable View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/631825abd5f66565616eaa5e314f1ea… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/631825abd5f66565616eaa5e314f1ea… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Move flags to precede patterns for grep and read files directly
by Marge Bot (＠marge-bot) 26 Jan '26

26 Jan '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 4d17cac9 by Greg Steuck at 2026-01-26T18:32:42-05:00 Move flags to precede patterns for grep and read files directly This makes the tests pass with non-GNU (i.e. POSIX-complicant) tools. There's no reason to use cat and pipe where direct file argument works. - - - - - 0b05ae7f by Matthew Pickering at 2026-01-26T18:32:42-05:00 Evaluate backtraces for "error" exceptions at the moment they are thrown See Note [Capturing the backtrace in throw] and Note [Hiding precise exception signature in throw] which explain the implementation. This commit makes `error` and `throw` behave the same with regard to backtraces. Previously, exceptions raised by `error` would not contain useful IPE backtraces. I did try and implement `error` in terms of `throw` but it started to involve putting diverging functions into hs-boot files, which seemed to risky if the compiler wouldn't be able to see if applying a function would diverge. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/383 Fixes #26751 - - - - - 12 changed files: - libraries/base/changelog.md - libraries/base/tests/perf/Makefile - libraries/ghc-internal/src/GHC/Internal/Err.hs - libraries/ghc-internal/tests/stack-annotation/all.T - + libraries/ghc-internal/tests/stack-annotation/ann_frame005.hs - + libraries/ghc-internal/tests/stack-annotation/ann_frame005.stdout - testsuite/tests/driver/T16318/Makefile - testsuite/tests/driver/T18125/Makefile - testsuite/tests/ghci.debugger/scripts/T8487.stdout - testsuite/tests/ghci.debugger/scripts/break011.stdout - testsuite/tests/ghci.debugger/scripts/break017.stdout - testsuite/tests/ghci.debugger/scripts/break025.stdout Changes: ===================================== libraries/base/changelog.md ===================================== @@ -23,6 +23,7 @@ * `GHC.Conc.catchSTM` and `GHC.Conc.Sync.catchSTM` now attach `WhileHandling` annotation to exceptions thrown from the handler. ([GHC #25365](https://gitlab.haskell.org/ghc/ghc/-/issues/25365)) * Remove `GHC.JS.Prim.Internal.Build`, as per [CLC #329](https://github.com/haskell/core-libraries-committee/issues/329) * Export `labelThread` from `Control.Concurrent`.([CLC proposal #376](https://github.com/haskell/core-libraries-committee/issues/376)) + * Evaluate backtraces for "error" exceptions at the moment they are thrown. ([CLC proposal #383](https://github.com/haskell/core-libraries-committee/issues/383)) ## 4.22.0.0 *TBA* * Shipped with GHC 9.14.1 ===================================== libraries/base/tests/perf/Makefile ===================================== @@ -12,4 +12,4 @@ T17752: # All occurrences of elem should be optimized away. # For strings these should result in loops after inlining foldCString. # For lists it should result in a case expression. - echo $$(cat T17752.dump-simpl | grep "elem" -A4 ) + echo $$(grep -A4 "elem" T17752.dump-simpl) ===================================== libraries/ghc-internal/src/GHC/Internal/Err.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, ImplicitParams #-} {-# LANGUAGE RankNTypes, PolyKinds, DataKinds #-} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- @@ -25,6 +26,7 @@ module GHC.Internal.Err( absentErr, error, errorWithoutStackTrace, undefined ) where import GHC.Internal.Types (Char, RuntimeRep) import GHC.Internal.Stack.Types +import GHC.Internal.Magic import GHC.Internal.Prim import {-# SOURCE #-} GHC.Internal.Exception ( errorCallWithCallStackException @@ -33,7 +35,10 @@ import {-# SOURCE #-} GHC.Internal.Exception -- | 'error' stops execution and displays an error message. error :: forall (r :: RuntimeRep). forall (a :: TYPE r). HasCallStack => [Char] -> a -error s = raise# (errorCallWithCallStackException s ?callStack) +error s = + -- See Note [Capturing the backtrace in throw] and Note [Hiding precise exception signature in throw] + let !se = noinline (errorCallWithCallStackException s ?callStack) + in raise# se -- Bleh, we should be using 'GHC.Internal.Stack.callStack' instead of -- '?callStack' here, but 'GHC.Internal.Stack.callStack' depends on -- 'GHC.Internal.Stack.popCallStack', which is partial and depends on @@ -73,7 +78,10 @@ undefined :: forall (r :: RuntimeRep). forall (a :: TYPE r). -- nor wanted (see #19886). We’d like to use withFrozenCallStack, but that -- is not available in this module yet, and making it so is hard. So let’s just -- use raise# directly. -undefined = raise# (errorCallWithCallStackException "Prelude.undefined" ?callStack) +undefined = + -- See Note [Capturing the backtrace in throw] and Note [Hiding precise exception signature in throw] + let !se = noinline (errorCallWithCallStackException "Prelude.undefined" ?callStack) + in raise# se -- | Used for compiler-generated error message; -- encoding saves bytes of string junk. ===================================== libraries/ghc-internal/tests/stack-annotation/all.T ===================================== @@ -8,3 +8,4 @@ test('ann_frame001', ann_frame_opts, compile_and_run, ['']) test('ann_frame002', ann_frame_opts, compile_and_run, ['']) test('ann_frame003', ann_frame_opts, compile_and_run, ['']) test('ann_frame004', ann_frame_opts, compile_and_run, ['']) +test('ann_frame005', ann_frame_opts, compile_and_run, ['']) ===================================== libraries/ghc-internal/tests/stack-annotation/ann_frame005.hs ===================================== @@ -0,0 +1,73 @@ +import Control.Concurrent.STM +import Control.Exception +import Control.Exception.Backtrace (BacktraceMechanism(IPEBacktrace), setBacktraceMechanismState) +import Control.Exception.Context (displayExceptionContext) +import Control.Monad +import Data.List (isInfixOf) +import TestUtils + +data SimpleBoom = SimpleBoom deriving (Show) + +instance Exception SimpleBoom + +main :: IO () +main = do + setBacktraceMechanismState IPEBacktrace True + mapM_ (uncurry runCase) + [ ("throwIO SimpleBoom", throwIOAction) + , ("undefined", undefinedAction) + , ("error", errorAction) + , ("throwSTM", throwSTMAction) + ] + +runCase :: String -> IO () -> IO () +runCase label action = do + putStrLn ("=== " ++ label ++ " ===") + annotateCallStackIO $ + annotateStackStringIO ("catch site for " ++ label) $ + catch action (handler label) + +throwIOAction :: IO () +throwIOAction = + annotateStackStringIO "raising action" $ + annotateStackStringIO "throwIO SimpleBoom" $ + throwIO SimpleBoom + +undefinedAction :: IO () +undefinedAction = + annotateStackStringIO "raising undefined action" $ + void $ + evaluate $ + annotateStackString "undefined thunk" (undefined :: Int) + +errorAction :: IO () +errorAction = + annotateStackStringIO "raising error action" $ + void $ + evaluate $ + annotateStackString "error thunk" (error "error from annotateStackString" :: Int) + +throwSTMAction :: IO () +throwSTMAction = + annotateStackStringIO "raising throwSTM action" $ + atomically $ + annotateStackString "throwSTM SimpleBoom" $ + throwSTM SimpleBoom + +handler :: String -> SomeException -> IO () +handler label se = + annotateStackStringIO ("handler for " ++ label) $ + annotateStackStringIO ("forcing SomeException for " ++ label) $ do + message <- evaluate (displayException se) + putStrLn ("Caught exception: " ++ message) + let ctx = displayExceptionContext (someExceptionContext se) + ctxLines = lines ctx + putStrLn "Exception context:" + case ctxLines of + [] -> putStrLn "<empty>" + ls -> mapM_ (putStrLn . ("- " ++)) ls + let handlerTag = "handler for " ++ label + -- Check that the callstack is from the callsite, not the handling site + when (any (handlerTag `isInfixOf`) ctxLines) $ + error $ "handler annotation leaked into context for " ++ label + putStrLn "Handler annotation not present in context" ===================================== libraries/ghc-internal/tests/stack-annotation/ann_frame005.stdout ===================================== @@ -0,0 +1,45 @@ +=== throwIO SimpleBoom === +Caught exception: SimpleBoom +Exception context: +- IPE backtrace: +- throwIO SimpleBoom +- raising action +- catch site for throwIO SimpleBoom +- annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main +- HasCallStack backtrace: +- throwIO, called at ann_frame005.hs:34:7 in main:Main +Handler annotation not present in context +=== undefined === +Caught exception: Prelude.undefined +Exception context: +- IPE backtrace: +- undefined thunk +- raising undefined action +- catch site for undefined +- annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main +- HasCallStack backtrace: +- undefined, called at ann_frame005.hs:41:48 in main:Main +Handler annotation not present in context +=== error === +Caught exception: error from annotateStackString +Exception context: +- IPE backtrace: +- error thunk +- raising error action +- catch site for error +- annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main +- HasCallStack backtrace: +- error, called at ann_frame005.hs:48:44 in main:Main +Handler annotation not present in context +=== throwSTM === +Caught exception: SimpleBoom +Exception context: +- IPE backtrace: +- raising throwSTM action +- catch site for throwSTM +- annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main +- HasCallStack backtrace: +- collectExceptionAnnotation, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:170:37 in ghc-internal:GHC.Internal.Exception +- toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/STM.hs:190:26 in ghc-internal:GHC.Internal.STM +- throwSTM, called at ann_frame005.hs:55:9 in main:Main +Handler annotation not present in context ===================================== testsuite/tests/driver/T16318/Makefile ===================================== @@ -7,5 +7,5 @@ test_pe = test-package-environment T16318: "$(GHC_PKG)" field base id --simple-output > $(test_pe) "$(TEST_HC)" $(TEST_HC_OPTS) -v1 -ignore-dot-ghci -package-env $(test_pe) -e "putStrLn \"Hello\"" > out 2>&1 - C=`cat out | grep "Loaded package environment" -c` ; \ + C=`grep -c "Loaded package environment" out` ; \ if [ $$C != "1" ]; then false; fi ===================================== testsuite/tests/driver/T18125/Makefile ===================================== @@ -9,5 +9,5 @@ T18125: "$(GHC_PKG)" field base id --simple-output > $(test_pe) "$(GHC_PKG)" field $(test_lib) id --simple-outpu >> $(test_pe) "$(TEST_HC)" $(TEST_HC_OPTS) -Wunused-packages -package-env $(test_pe) T18125.hs > out 2>&1 - C=`cat out | grep "$(test_lib)" -c` ; \ + C=`grep -c "$(test_lib)" out` ; \ if [ $$C != "1" ]; then false; fi ===================================== testsuite/tests/ghci.debugger/scripts/T8487.stdout ===================================== @@ -1,4 +1,5 @@ Breakpoint 0 activated at T8487.hs:(5,8)-(7,53) Stopped in Main.f, T8487.hs:(5,8)-(7,53) _result :: IO String = _ -ma :: Either SomeException String = Left _ +ma :: Either SomeException String = Left + (SomeException (ErrorCall ...)) ===================================== testsuite/tests/ghci.debugger/scripts/break011.stdout ===================================== @@ -4,9 +4,10 @@ HasCallStack backtrace: error, called at <interactive>:2:1 in interactive:Ghci1 Stopped in <exception thrown>, <unknown> -_exception :: e = _ +_exception :: e = GHC.Internal.Exception.Type.SomeException + (GHC.Internal.Exception.ErrorCall _) Stopped in <exception thrown>, <unknown> -_exception :: e = _ +_exception :: e = SomeException (ErrorCall _) -1 : main (Test7.hs:2:18-28) -2 : main (Test7.hs:2:8-29) <end of history> @@ -26,7 +27,7 @@ _exception :: SomeException = SomeException (ErrorCall "foo") *** Exception: foo HasCallStack backtrace: - error, called at Test7.hs:2:18 in main:Main + error, called at Test7.hs:2:18 in interactive-session:Main Stopped in <exception thrown>, <unknown> _exception :: e = _ @@ -35,5 +36,5 @@ _exception :: e = _ *** Exception: foo HasCallStack backtrace: - error, called at Test7.hs:2:18 in main:Main + error, called at Test7.hs:2:18 in interactive-session:Main ===================================== testsuite/tests/ghci.debugger/scripts/break017.stdout ===================================== @@ -1,5 +1,6 @@ "Stopped in <exception thrown>, <unknown> -_exception :: e = _ +_exception :: e = GHC.Internal.Exception.Type.SomeException + (GHC.Internal.Exception.ErrorCall _) Logged breakpoint at QSort.hs:6:32-34 _result :: Char -> Bool a :: Char ===================================== testsuite/tests/ghci.debugger/scripts/break025.stdout ===================================== @@ -1,3 +1,4 @@ Stopped in <exception thrown>, <unknown> -_exception :: e = _ +_exception :: e = GHC.Internal.Exception.Type.SomeException + (GHC.Internal.Exception.ErrorCall _) () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a56b0585109fb60738130e6be0d2fc… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a56b0585109fb60738130e6be0d2fc… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/ticked_joins] 2 commits: fix fix
by sheaf (＠sheaf) 26 Jan '26

26 Jan '26

sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC Commits: e4500d48 by sheaf at 2026-01-26T23:46:57+01:00 fix fix - - - - - 5239e258 by sheaf at 2026-01-27T00:01:20+01:00 working? - - - - - 4 changed files: - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs Changes: ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -1151,7 +1151,11 @@ lintJoinBndrType :: OutType -- Type of the body -- E.g. join j x = rhs in body -- The type of 'rhs' must be the same as the type of 'body' lintJoinBndrType body_ty bndr - | JoinPoint { joinPointArity = arity } <- idJoinPointHood bndr + | JoinPoint + { joinPointArity = arity + , joinPointType = TrueJoinPoint + -- SLD TODO: quasi join points can have intervening casts + } <- idJoinPointHood bndr , let bndr_ty = idType bndr , (bndrs, res) <- splitPiTys bndr_ty = do let msg = ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -1127,7 +1127,7 @@ occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs -- returned by of occAnalLamTail. It's totally OK for them to mismatch; -- hence adjust the UDs from the RHS - WUD adj_rhs_uds final_rhs = adjustNonRecRhs (joinPointHoodArity mb_join) $ + WUD adj_rhs_uds final_rhs = adjustNonRecRhs mb_join $ occAnalLamTail rhs_env rhs final_bndr_with_rules | noBinderSwaps env = bndr -- See Note [Unfoldings and rules] @@ -1217,7 +1217,7 @@ occAnalRec !_ lvl = WUD body_uds binds | otherwise = let (bndr', mb_join) = tagNonRecBinder lvl occ bndr - !(WUD rhs_uds' rhs') = adjustNonRecRhs (joinPointHoodArity mb_join) wtuds + !(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds in WUD (body_uds `andUDs` rhs_uds') (NonRec bndr' rhs' : binds) where @@ -2621,7 +2621,7 @@ occAnal env app@(App _ _) = occAnalApp env (collectArgsTicks tickishFloatable app) occAnal env expr@(Lam {}) - = adjustNonRecRhs Nothing $ -- Nothing <=> markAllManyNonTail + = adjustNonRecRhs NotJoinPoint $ -- NotJoinPoint <=> markAllManyNonTail occAnalLamTail env expr occAnal env (Case scrut bndr ty alts) @@ -2749,7 +2749,7 @@ occAnalApp env (Var fun, args, ticks) -- This caused #18296 | fun `hasKey` runRWKey , [t1, t2, arg] <- args - , WUD usage arg' <- adjustNonRecRhs (Just 1) $ occAnalLamTail env arg + , WUD usage arg' <- adjustNonRecRhs (JoinPoint TrueJoinPoint 1) $ occAnalLamTail env arg = let app_out = mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'] in WUD usage app_out @@ -3975,21 +3975,21 @@ lookupOccInfoByUnique (UD { ud_env = env ------------------- -- See Note [Adjusting right-hand sides] -adjustNonRecRhs :: Maybe JoinArity +adjustNonRecRhs :: JoinPointHood -> WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr -- ^ This function concentrates shared logic between occAnalNonRecBind and the -- AcyclicSCC case of occAnalRec. -- It returns the adjusted rhs UsageDetails combined with the body usage -adjustNonRecRhs mb_join_arity (WTUD (TUD rhs_ja uds) rhs) +adjustNonRecRhs mb_join (WTUD (TUD rhs_ja uds) rhs) = WUD (adjustTailUsage exact_join rhs uds) rhs where exact_join = - case mb_join_arity of - Nothing -> Nothing - Just ja' -> + case mb_join of + NotJoinPoint -> Nothing + JoinPoint { joinPointArity = ja', joinPointType = ty } -> if ja' == rhs_ja - then Just TrueJoinPoint + then Just ty else Nothing adjustTailUsage :: HasDebugCallStack @@ -4120,11 +4120,8 @@ decideRecJoinPointHood :: TopLevelFlag -> UsageDetails -> [CoreBndr] -> Maybe JoinPointType decideRecJoinPointHood lvl usage bndrs = do bndrsNE <- NE.nonEmpty bndrs - res <- Semi.sconcat <$> traverse ok bndrsNE -- Invariant 3: Either all are join points or none are - pprTraceM "decideRecJoinPointHood" $ - vcat [ text "bndrs:" <+> ppr bndrs - , text "res:" <+> ppr res ] - return res + -- Invariant 3: Either all are join points or none are + Semi.sconcat <$> traverse ok bndrsNE where ok bndr = okForJoinPoint lvl bndr (lookupTailCallInfo usage bndr) @@ -4132,10 +4129,11 @@ okForJoinPoint :: TopLevelFlag -> Id -> TailCallInfo -> Maybe JoinPointType -- See Note [Invariants on join points]; invariants cited by number below. -- Invariant 2 is always satisfiable by the simplifier by eta expansion. okForJoinPoint lvl bndr tail_call_info - | Just join_ty <- joinId_maybe bndr + | isJoinId bndr -- A current join point should still be one! = warnPprTrace lost_join "Lost join point" lost_join_doc $ - Just join_ty + mb_valid_join + -- NB: we might downgrade 'TrueJoinPoint' to 'QuasiJoinPoint'. | otherwise = mb_valid_join where ===================================== compiler/GHC/Core/Opt/SetLevels.hs ===================================== @@ -1895,7 +1895,7 @@ newPolyBndrs dest_lvl , not dest_is_top = asJoinId new_bndr join_ty - ( join_arity + length abs_vars ) + (join_arity + length abs_vars) | otherwise = new_bndr ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -2088,7 +2088,7 @@ simplNonRecJoinPoint env bndr rhs body cont ; return (floats1 `addFloats` floats2, body') } where do_case_case - | Just TrueJoinPoint <- occInfoJoinPointType_maybe (idOccInfo bndr) + | Just TrueJoinPoint <- joinId_maybe bndr = seCaseCase env | otherwise = False @@ -2114,7 +2114,7 @@ simplRecJoinPoint env pairs body cont ; return (floats1 `addFloats` floats2, body') } where do_case_case = - if all ((== Just TrueJoinPoint) . occInfoJoinPointType_maybe . idOccInfo . fst) pairs + if all ((== Just TrueJoinPoint) . joinId_maybe . fst) pairs then seCaseCase env else False @@ -2154,15 +2154,15 @@ trimJoinCont :: Id -- Used only in error message trimJoinCont _ NotJoinPoint cont = cont -- Not a jump trimJoinCont var (JoinPoint { joinPointType = join_ty, joinPointArity = arity }) cont - | QuasiJoinPoint <- join_ty - -- SLD TODO - = cont - | otherwise = trim arity cont where trim 0 cont@(Stop {}) = cont trim 0 cont + | QuasiJoinPoint <- join_ty + -- SLD TODO explain + = cont + | otherwise = mkBoringStop (contResultType cont) trim n cont@(ApplyToVal { sc_cont = k }) = cont { sc_cont = trim (n-1) k } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a3ef7ffcc6418ab11ba039915f9951… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a3ef7ffcc6418ab11ba039915f9951… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26834] 2 commits: Delete unecessary GHC.Internal.Data.Ix
by Teo Camarasu (＠teo) 26 Jan '26

26 Jan '26

Teo Camarasu pushed to branch wip/T26834 at Glasgow Haskell Compiler / GHC Commits: ffdda2af by Teo Camarasu at 2026-01-26T22:06:19+00:00 Delete unecessary GHC.Internal.Data.Ix - - - - - 2a1f0bdc by Teo Camarasu at 2026-01-26T22:22:43+00:00 ghc-internal: refine List imports - - - - - 17 changed files: - libraries/base/src/Data/Ix.hs - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Zip.hs - libraries/ghc-internal/src/GHC/Internal/Data/Data.hs - − libraries/ghc-internal/src/GHC/Internal/Data/Ix.hs - libraries/ghc-internal/src/GHC/Internal/Data/List/NonEmpty.hs - libraries/ghc-internal/src/GHC/Internal/Data/String.hs - libraries/ghc-internal/src/GHC/Internal/Data/Version.hs - libraries/ghc-internal/src/GHC/Internal/Event/Windows.hsc - libraries/ghc-internal/src/GHC/Internal/ExecutionStack/Internal.hsc - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/CodePage.hs - libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - libraries/ghc-internal/src/GHC/Internal/System/Environment/Blank.hsc - libraries/ghc-internal/src/GHC/Internal/System/Environment/ExecutablePath.hsc - libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs - libraries/ghc-internal/src/GHC/Internal/Windows.hs Changes: ===================================== libraries/base/src/Data/Ix.hs ===================================== @@ -1,4 +1,4 @@ -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} -- | -- @@ -42,4 +42,4 @@ module Data.Ix -- <https://www.haskell.org/onlinereport/haskell2010/haskellch19.html>. ) where -import GHC.Internal.Data.Ix +import GHC.Internal.Ix ===================================== libraries/ghc-internal/ghc-internal.cabal.in ===================================== @@ -153,7 +153,6 @@ Library GHC.Internal.Data.Functor.Identity GHC.Internal.Data.Functor.Utils GHC.Internal.Data.IORef - GHC.Internal.Data.Ix GHC.Internal.Data.List GHC.Internal.Data.List.NonEmpty GHC.Internal.Data.Maybe ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Monad/Zip.hs ===================================== @@ -28,7 +28,7 @@ import GHC.Internal.Data.Proxy --import qualified Data.List.NonEmpty as NE import GHC.Internal.Generics import qualified GHC.Internal.Data.List.NonEmpty as NE -import qualified GHC.Internal.Data.List as List +import qualified GHC.Internal.List as List import GHC.Internal.Data.Maybe import GHC.Internal.Data.Tuple --import Prelude ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Data.hs ===================================== @@ -117,7 +117,7 @@ import GHC.Internal.Data.Maybe import GHC.Internal.Data.Monoid import GHC.Internal.Data.NonEmpty ( NonEmpty(..) ) import GHC.Internal.Data.Ord -import GHC.Internal.Data.List (findIndex) +import GHC.Internal.Data.OldList (findIndex) import GHC.Internal.Data.Typeable import GHC.Internal.Data.Version( Version(..) ) import GHC.Internal.Base hiding (Any, IntRep, FloatRep, NonEmpty(..)) ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Ix.hs deleted ===================================== @@ -1,64 +0,0 @@ -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.Internal.Data.Ix --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries(a)haskell.org --- Stability : stable --- Portability : portable --- --- The 'Ix' class is used to map a contiguous subrange of values in --- type onto integers. It is used primarily for array indexing --- (see the array package). 'Ix' uses row-major order. --- ------------------------------------------------------------------------------ - -module GHC.Internal.Data.Ix - ( - -- * The 'Ix' class - Ix - ( range - , index - , inRange - , rangeSize - ) - -- Ix instances: - -- - -- Ix Char - -- Ix Int - -- Ix Integer - -- Ix Bool - -- Ix Ordering - -- Ix () - -- (Ix a, Ix b) => Ix (a, b) - -- ... - - -- * Deriving Instances of 'Ix' - -- | Derived instance declarations for the class 'Ix' are only possible - -- for enumerations (i.e. datatypes having only nullary constructors) - -- and single-constructor datatypes, including arbitrarily large tuples, - -- whose constituent types are instances of 'Ix'. - -- - -- * For an enumeration, the nullary constructors are assumed to be - -- numbered left-to-right with the indices being 0 to n-1 inclusive. This - -- is the same numbering defined by the 'Enum' class. For example, given - -- the datatype: - -- - -- > data Colour = Red | Orange | Yellow | Green | Blue | Indigo | Violet - -- - -- we would have: - -- - -- > range (Yellow,Blue) == [Yellow,Green,Blue] - -- > index (Yellow,Blue) Green == 1 - -- > inRange (Yellow,Blue) Red == False - -- - -- * For single-constructor datatypes, the derived instance declarations - -- are as shown for tuples in chapter 19, section 2 of the Haskell 2010 report: - -- <https://www.haskell.org/onlinereport/haskell2010/haskellch19.html>. - - ) where - -import GHC.Internal.Ix ===================================== libraries/ghc-internal/src/GHC/Internal/Data/List/NonEmpty.hs ===================================== @@ -8,7 +8,7 @@ module GHC.Internal.Data.List.NonEmpty ) where import GHC.Internal.Data.NonEmpty (NonEmpty (..), map) -import qualified GHC.Internal.Data.List as List +import qualified GHC.Internal.List as List -- | The 'zip' function takes two streams and returns a stream of -- corresponding pairs. ===================================== libraries/ghc-internal/src/GHC/Internal/Data/String.hs ===================================== @@ -35,7 +35,7 @@ module GHC.Internal.Data.String ( import GHC.Internal.Base import GHC.Internal.Data.Functor.Const (Const (Const)) import GHC.Internal.Data.Functor.Identity (Identity (Identity)) -import GHC.Internal.Data.List (lines, words, unlines, unwords) +import GHC.Internal.Data.OldList (lines, words, unlines, unwords) -- | `IsString` is used in combination with the @-XOverloadedStrings@ -- language extension to convert the literals to different string types. ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Version.hs ===================================== @@ -40,7 +40,7 @@ import GHC.Internal.Data.Functor ( Functor(..) ) import GHC.Internal.Data.Bool ( (&&) ) import GHC.Internal.Data.Eq import GHC.Internal.Int ( Int ) -import GHC.Internal.Data.List ( map, sort, concat, concatMap, intersperse, (++) ) +import GHC.Internal.Data.OldList ( map, sort, concat, concatMap, intersperse, (++) ) import GHC.Internal.Data.Ord import GHC.Internal.Data.String ( String ) import GHC.Internal.Base ( Applicative(..) ) ===================================== libraries/ghc-internal/src/GHC/Internal/Event/Windows.hsc ===================================== @@ -103,7 +103,7 @@ import GHC.Internal.IORef import GHC.Internal.Maybe import GHC.Internal.Ptr import GHC.Internal.Word -import GHC.Internal.Data.OldList (deleteBy) +import GHC.Internal.List (deleteBy) import qualified GHC.Internal.Event.Array as A import GHC.Internal.Base import GHC.Internal.Conc.Bound ===================================== libraries/ghc-internal/src/GHC/Internal/ExecutionStack/Internal.hsc ===================================== @@ -39,7 +39,7 @@ module GHC.Internal.ExecutionStack.Internal ( import GHC.Internal.Data.Functor import GHC.Internal.Data.Maybe -import GHC.Internal.Data.List (reverse, null) +import GHC.Internal.List (reverse, null) import GHC.Internal.Word import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.C.String (peekCString, CString) ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Encoding/CodePage.hs ===================================== @@ -30,7 +30,7 @@ import GHC.Internal.IO.Encoding.Types import GHC.Internal.IO.Buffer import GHC.Internal.Data.Bits import GHC.Internal.Data.Maybe -import GHC.Internal.Data.OldList (lookup) +import GHC.Internal.List (lookup) import qualified GHC.Internal.IO.Encoding.CodePage.API as API import GHC.Internal.IO.Encoding.CodePage.Table ===================================== libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs ===================================== @@ -28,7 +28,7 @@ import GHC.Internal.Control.Exception import GHC.Internal.Data.Foldable (Foldable(..)) import GHC.Internal.Base import GHC.Internal.Unicode (isSpace) -import GHC.Internal.Data.List (filter, unlines, concat, reverse) +import GHC.Internal.Data.OldList (filter, unlines, concat, reverse) import GHC.Internal.Text.Show (show) import GHC.Internal.System.Environment (getArgs) import GHC.Internal.System.Exit (exitFailure) ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs ===================================== @@ -36,7 +36,7 @@ import GHC.Internal.Num import GHC.Internal.Data.Bits import GHC.Internal.Data.Functor import GHC.Internal.Data.Maybe (catMaybes) -import GHC.Internal.Data.List +import GHC.Internal.List import GHC.Internal.Data.Tuple import GHC.Internal.Foreign.Ptr import GHC.Internal.Foreign.Storable ===================================== libraries/ghc-internal/src/GHC/Internal/System/Environment/Blank.hsc ===================================== @@ -40,14 +40,14 @@ module GHC.Internal.System.Environment.Blank ) where import GHC.Internal.Data.Functor -import GHC.Internal.Data.List (elem, null, takeWhile) +import GHC.Internal.List (elem, null, takeWhile) import GHC.Internal.Foreign.C.String import GHC.Internal.Base #if defined(mingw32_HOST_OS) import GHC.Internal.Foreign.Ptr import GHC.Internal.Windows import GHC.Internal.Control.Monad -import GHC.Internal.Data.List (lookup) +import GHC.Internal.List (lookup) #else import GHC.Internal.Foreign.C.Error import GHC.Internal.Foreign.C.Types ===================================== libraries/ghc-internal/src/GHC/Internal/System/Environment/ExecutablePath.hsc ===================================== @@ -53,7 +53,7 @@ import GHC.Internal.System.IO.Error (isDoesNotExistError) import GHC.Internal.System.Posix.Internals #elif defined(linux_HOST_OS) || defined(gnu_HOST_OS) import GHC.Internal.Data.Functor -import GHC.Internal.Data.List (isSuffixOf) +import GHC.Internal.Data.OldList (isSuffixOf) import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.C.Error import GHC.Internal.Foreign.C.String @@ -85,7 +85,7 @@ import GHC.Internal.System.Posix.Internals import GHC.Internal.Control.Exception import GHC.Internal.Control.Monad.Fail import GHC.Internal.Data.Functor -import GHC.Internal.Data.List (isPrefixOf, drop) +import GHC.Internal.OldList (isPrefixOf, drop) import GHC.Internal.Word import GHC.Internal.Foreign.C.String import GHC.Internal.Foreign.Marshal.Array ===================================== libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs ===================================== @@ -70,7 +70,7 @@ import GHC.Internal.Foreign.Storable import qualified GHC.Internal.Foreign.C.String.Encoding as GHC #else import GHC.Internal.Int -import GHC.Internal.Data.OldList (elem) +import GHC.Internal.List (elem) #endif -- --------------------------------------------------------------------------- ===================================== libraries/ghc-internal/src/GHC/Internal/Windows.hs ===================================== @@ -80,7 +80,7 @@ module GHC.Internal.Windows ( import GHC.Internal.Data.Bits (finiteBitSize, shiftL, shiftR, (.|.), (.&.)) import GHC.Internal.Unicode (isSpace) -import GHC.Internal.Data.OldList +import GHC.Internal.List import GHC.Internal.Data.Maybe import GHC.Internal.Word import GHC.Internal.Int View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/966bd642640e2ccd17bbe43f2f5145… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/966bd642640e2ccd17bbe43f2f5145… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/ticked_joins] WIP try harder
by sheaf (＠sheaf) 26 Jan '26

26 Jan '26

sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC Commits: a3ef7ffc by sheaf at 2026-01-26T23:12:26+01:00 WIP try harder - - - - - 5 changed files: - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Monad.hs - compiler/GHC/Types/Id/Info.hs Changes: ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -915,7 +915,7 @@ lintCoreExpr (Lit lit) ; return (literalType lit, zeroUE) } lintCoreExpr (Cast expr co) - = do { (expr_ty, ue) <- markAllJoinsBad (lintCoreExpr expr) + = do { (expr_ty, ue) <- lintCoreExpr expr -- SLD TODO markAllJoinsBad (lintCoreExpr expr) -- markAllJoinsBad: see Note [Join points and casts] ; lintCoercion co @@ -1146,7 +1146,7 @@ checkDeadIdOcc id ------------------ lintJoinBndrType :: OutType -- Type of the body -> OutId -- Possibly a join Id - -> LintM () + -> LintM () -- Checks that the return type of a join Id matches the body -- E.g. join j x = rhs in body -- The type of 'rhs' must be the same as the type of 'body' ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -42,7 +42,7 @@ import GHC.Core.Coercion import GHC.Core.Type import GHC.Core.TyCo.FVs ( tyCoVarsOfMCo ) -import GHC.Data.Maybe( orElse ) +import GHC.Data.Maybe( orElse, isNothing ) import GHC.Data.Graph.Directed ( SCC(..), Node(..) , stronglyConnCompFromEdgedVerticesUniq , stronglyConnCompFromEdgedVerticesUniqR ) @@ -68,6 +68,7 @@ import GHC.Builtin.Names( runRWKey ) import GHC.Unit.Module( Module ) import Data.List (mapAccumL) +import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup as Semi {- @@ -2299,7 +2300,7 @@ occ_anal_lam_tail env (Cast expr co) _ -> usage1 -- usage3: see Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration. - usage3 = markAllNonTail usage2 -- SLD TODO + usage3 = markAllQuasiTail usage2 -- SLD TODO in WUD usage3 (Cast expr' co) @@ -2612,7 +2613,7 @@ occAnal env (Cast expr co) = let (WUD usage expr') = occAnal env expr usage1 = addManyOccs usage (coVarsOfCo co) -- usage1: see Note [Gather occurrences of coercion variables] - usage2 = markAllNonTail usage1 -- SLD TODO + usage2 = markAllQuasiTail usage1 -- SLD TODO -- usage2: see Note [Quasi join points] in WUD usage2 (Cast expr' co) @@ -3985,20 +3986,31 @@ adjustNonRecRhs mb_join_arity (WTUD (TUD rhs_ja uds) rhs) where exact_join = case mb_join_arity of - Nothing -> False - Just ja' -> ja' == rhs_ja - -adjustTailUsage :: Bool -- True <=> Exactly-matching join point; don't do markNonTail + Nothing -> Nothing + Just ja' -> + if ja' == rhs_ja + then Just TrueJoinPoint + else Nothing + +adjustTailUsage :: HasDebugCallStack + => Maybe JoinPointType -> CoreExpr -- Rhs usage, AFTER occAnalLamTail -> UsageDetails -> UsageDetails -adjustTailUsage exact_join rhs uds +adjustTailUsage mb_join rhs uds = -- c.f. occAnal (Lam {}) markAllInsideLamIf (not one_shot) $ - markAllNonTailIf (not exact_join) $ + mb_mark_nontail $ uds where - one_shot = isOneShotFun rhs + one_shot = isOneShotFun rhs + mb_mark_nontail = + case mb_join of + Nothing -> markAllNonTail + Just join_ty -> + case join_ty of + QuasiJoinPoint -> markAllQuasiTail + TrueJoinPoint -> id adjustTailArity :: Maybe JoinArity -> TailUsageDetails -> UsageDetails adjustTailArity mb_rhs_ja (TUD ja usage) = markAllNonTailIf not_same_arity usage @@ -4036,11 +4048,8 @@ tagNonRecBinder :: TopLevelFlag -- At top level? -- No-op on TyVars -- Precondition: OccInfo is not IAmDead tagNonRecBinder lvl occ bndr - | okForJoinPoint lvl bndr tail_call_info - , AlwaysTailCalled - { tailCallArity = ar - , tailCallJoinPointType = join_ty - } <- tail_call_info + | Just join_ty <- okForJoinPoint lvl bndr tail_call_info + , AlwaysTailCalled { tailCallArity = ar } <- tail_call_info = (setBinderOcc occ bndr, JoinPoint join_ty ar) | otherwise = (setBinderOcc zapped_occ bndr, NotJoinPoint) @@ -4070,7 +4079,7 @@ tagRecBinders lvl body_uds details_s = assertPpr (rhs_ja == joinRhsArity rhs) (ppr rhs_ja $$ ppr uds $$ ppr rhs) $ uds - will_be_joins :: Bool + will_be_joins :: Maybe JoinPointType will_be_joins = decideRecJoinPointHood lvl unadj_uds bndrs -- 2. Adjust usage details of each RHS, taking into account the @@ -4108,42 +4117,50 @@ setBinderOcc occ_info bndr -- -- See Note [Invariants on join points] in "GHC.Core". decideRecJoinPointHood :: TopLevelFlag -> UsageDetails - -> [CoreBndr] -> Bool -decideRecJoinPointHood lvl usage bndrs - = all ok bndrs -- Invariant 3: Either all are join points or none are + -> [CoreBndr] -> Maybe JoinPointType +decideRecJoinPointHood lvl usage bndrs = do + bndrsNE <- NE.nonEmpty bndrs + res <- Semi.sconcat <$> traverse ok bndrsNE -- Invariant 3: Either all are join points or none are + pprTraceM "decideRecJoinPointHood" $ + vcat [ text "bndrs:" <+> ppr bndrs + , text "res:" <+> ppr res ] + return res where ok bndr = okForJoinPoint lvl bndr (lookupTailCallInfo usage bndr) -okForJoinPoint :: TopLevelFlag -> Id -> TailCallInfo -> Bool +okForJoinPoint :: TopLevelFlag -> Id -> TailCallInfo -> Maybe JoinPointType -- See Note [Invariants on join points]; invariants cited by number below. -- Invariant 2 is always satisfiable by the simplifier by eta expansion. okForJoinPoint lvl bndr tail_call_info - | isJoinId bndr -- A current join point should still be one! + | Just join_ty <- joinId_maybe bndr + -- A current join point should still be one! = warnPprTrace lost_join "Lost join point" lost_join_doc $ - True - | valid_join - = True + Just join_ty | otherwise - = False + = mb_valid_join where - valid_join | NotTopLevel <- lvl - , AlwaysTailCalled { tailCallArity = arity } <- tail_call_info - - , -- Invariant 1 as applied to LHSes of rules - all (ok_rule arity) (idCoreRules bndr) - - -- Invariant 2a: stable unfoldings - -- See Note [Join points and INLINE pragmas] - , ok_unfolding arity (realIdUnfolding bndr) - - -- Invariant 4: Satisfies polymorphism rule - , isValidJoinPointType arity (idType bndr) - = True - | otherwise - = False + mb_valid_join + | NotTopLevel <- lvl + , AlwaysTailCalled + { tailCallArity = arity + , tailCallJoinPointType = join_ty + } <- tail_call_info + + , -- Invariant 1 as applied to LHSes of rules + all (ok_rule arity) (idCoreRules bndr) + + -- Invariant 2a: stable unfoldings + -- See Note [Join points and INLINE pragmas] + , ok_unfolding arity (realIdUnfolding bndr) + + -- Invariant 4: Satisfies polymorphism rule + , isValidJoinPointType arity (idType bndr) + = Just join_ty + | otherwise + = Nothing lost_join | JoinPoint { joinPointArity = ja } <- idJoinPointHood bndr - = not valid_join || + = isNothing mb_valid_join || (case tail_call_info of -- Valid join but arity differs AlwaysTailCalled { tailCallArity = ja' } -> ja /= ja' _ -> False) ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -2056,6 +2056,17 @@ is a join point, and what 'cont' is, in a value of type MaybeJoinCont of a SpecConstr-generated RULE for a join point. -} +-- SLD TODO horrible logic that must be removed +peelJoinResTy :: Int -> Type -> Type +peelJoinResTy 0 ty = ty +peelJoinResTy n ty + | Just (_bndr, inner_ty) <- splitForAllTyCoVar_maybe ty + = peelJoinResTy n inner_ty + | Just (_, _mult, _arg, res_ty) <- splitFunTy_maybe ty + = peelJoinResTy (n-1) res_ty + | otherwise + = ty + simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) @@ -2064,8 +2075,12 @@ simplNonRecJoinPoint env bndr rhs body cont wrapJoinCont do_case_case env cont $ \ env cont -> do { -- We push join_cont into the join RHS and the body; -- and wrap wrap_cont around the whole thing - ; let mult = contHoleScaling cont - res_ty = contResultType cont + ; let (mult, res_ty) + -- SLD TODO + | Just QuasiJoinPoint <- occInfoJoinPointType_maybe (idOccInfo bndr) + = (idMult bndr, peelJoinResTy (idJoinArity bndr) $ substTy env (idType bndr)) + | otherwise + = (contHoleScaling cont, contResultType cont) ; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont) ; (floats1, env3) <- simplJoinBind NonRecursive cont (bndr,env) (bndr2,env2) (rhs,env) @@ -2084,8 +2099,13 @@ simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)] simplRecJoinPoint env pairs body cont = wrapJoinCont do_case_case env cont $ \ env cont -> do { let bndrs = map fst pairs - mult = contHoleScaling cont - res_ty = contResultType cont + (mult, res_ty) + -- SLD TODO + | [b] <- bndrs + , Just QuasiJoinPoint <- occInfoJoinPointType_maybe (idOccInfo b) + = (idMult b, peelJoinResTy (idJoinArity b) $ substTy env (idType b)) + | otherwise + = (contHoleScaling cont, contResultType cont) ; env1 <- simplRecJoinBndrs env bndrs mult res_ty -- NB: bndrs' don't have unfoldings or rules -- We add them as we go down @@ -2135,7 +2155,7 @@ trimJoinCont _ NotJoinPoint cont = cont -- Not a jump trimJoinCont var (JoinPoint { joinPointType = join_ty, joinPointArity = arity }) cont | QuasiJoinPoint <- join_ty - -- As per Note [Quasi join points], don't do any trimming for quasi join points. + -- SLD TODO = cont | otherwise = trim arity cont ===================================== compiler/GHC/Core/Opt/Simplify/Monad.hs ===================================== @@ -214,7 +214,7 @@ newJoinId bndrs body_ty -- arity: See Note [Invariants on join points] invariant 2b, in GHC.Core join_arity = length bndrs details = JoinId - { joinIdType = TrueJoinPoint -- SLD TODO this is very suspicious + { joinIdType = TrueJoinPoint -- SLD TODO this is suspicious , joinIdArity = join_arity , joinIdCbvMarks = Nothing } ===================================== compiler/GHC/Types/Id/Info.hs ===================================== @@ -441,7 +441,7 @@ pprIdDetails other = brackets (pp other) pp CoVarId = text "CoVarId" pp (JoinId ty arity marks) = quasi <> text "JoinId" <> parens (int arity) <> parens (ppr marks) where - quasi = case ty of { QuasiJoinPoint -> text "quasi"; TrueJoinPoint -> empty } + quasi = case ty of { QuasiJoinPoint -> text "Quasi"; TrueJoinPoint -> empty } {- ************************************************************************ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a3ef7ffcc6418ab11ba039915f99513… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a3ef7ffcc6418ab11ba039915f99513… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T26834
by Teo Camarasu (＠teo) 26 Jan '26

26 Jan '26

Teo Camarasu pushed new branch wip/T26834 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T26834 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26832] 2 commits: ghc-internal: move considerAccessible to GHC.Internal.Magic
by Teo Camarasu (＠teo) 26 Jan '26

26 Jan '26

Teo Camarasu pushed to branch wip/T26832 at Glasgow Haskell Compiler / GHC Commits: 23516844 by Teo Camarasu at 2026-01-26T20:42:39+00:00 ghc-internal: move considerAccessible to GHC.Internal.Magic Previously it lived in GHC.Internal.Exts, but it really deserves to live along with the other magic function, which are already re-exported from .Exts - - - - - f5cee207 by Teo Camarasu at 2026-01-26T20:51:24+00:00 ghc-internal: move maxTupleSize to GHC.Internal.Tuple This previously lived in GHC.Internal.Exts but a comment already said it should be moved to .Tuple - - - - - 4 changed files: - compiler/GHC/Builtin/Names.hs - libraries/ghc-internal/src/GHC/Internal/Exts.hs - libraries/ghc-internal/src/GHC/Internal/Magic.hs - libraries/ghc-internal/src/GHC/Internal/Tuple.hs Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -1063,7 +1063,7 @@ alternativeClassKey = mkPreludeMiscIdUnique 754 -- Functions for GHC extensions considerAccessibleName :: Name -considerAccessibleName = varQual gHC_INTERNAL_EXTS (fsLit "considerAccessible") considerAccessibleIdKey +considerAccessibleName = varQual gHC_MAGIC (fsLit "considerAccessible") considerAccessibleIdKey -- Random GHC.Internal.Base functions fromStringName, otherwiseIdName, foldrName, buildName, augmentName, ===================================== libraries/ghc-internal/src/GHC/Internal/Exts.hs ===================================== @@ -321,10 +321,7 @@ import GHC.Internal.Data.Data import GHC.Internal.Data.Ord import qualified GHC.Internal.Debug.Trace import GHC.Internal.Unsafe.Coerce ( unsafeCoerce# ) -- just for re-export - --- XXX This should really be in Data.Tuple, where the definitions are -maxTupleSize :: Int -maxTupleSize = 64 +import GHC.Internal.Tuple (maxTupleSize) -- | 'the' ensures that all the elements of the list are identical -- and then returns that unique element @@ -444,27 +441,3 @@ resizeSmallMutableArray# arr0 szNew a s0 = (# s2, arr1 #) -> case copySmallMutableArray# arr0 0# arr1 0# szOld s2 of s3 -> (# s3, arr1 #) else (# s1, arr0 #) - --- | Semantically, @considerAccessible = True@. But it has special meaning --- to the pattern-match checker, which will never flag the clause in which --- 'considerAccessible' occurs as a guard as redundant or inaccessible. --- Example: --- --- > case (x, x) of --- > (True, True) -> 1 --- > (False, False) -> 2 --- > (True, False) -> 3 -- Warning: redundant --- --- The pattern-match checker will warn here that the third clause is redundant. --- It will stop doing so if the clause is adorned with 'considerAccessible': --- --- > case (x, x) of --- > (True, True) -> 1 --- > (False, False) -> 2 --- > (True, False) | considerAccessible -> 3 -- No warning --- --- Put 'considerAccessible' as the last statement of the guard to avoid get --- confusing results from the pattern-match checker, which takes \"consider --- accessible\" by word. -considerAccessible :: Bool -considerAccessible = True ===================================== libraries/ghc-internal/src/GHC/Internal/Magic.hs ===================================== @@ -24,7 +24,7 @@ -- ----------------------------------------------------------------------------- -module GHC.Internal.Magic ( inline, noinline, lazy, oneShot, runRW#, DataToTag(..) ) where +module GHC.Internal.Magic ( inline, noinline, lazy, oneShot, runRW#, DataToTag(..), considerAccessible ) where -------------------------------------------------- -- See Note [magicIds] in GHC.Types.Id.Make @@ -34,7 +34,7 @@ module GHC.Internal.Magic ( inline, noinline, lazy, oneShot, runRW#, DataToTag(. -- because TYPE is not exported by the source Haskell module generated by -- genprimops which Haddock will typecheck (#15935). import GHC.Internal.Prim (State#, realWorld#, RealWorld, Int#) -import GHC.Internal.Types (RuntimeRep(BoxedRep), TYPE, Levity, Constraint) +import GHC.Internal.Types (RuntimeRep(BoxedRep), TYPE, Levity, Constraint, Bool(True)) -- | The call @inline f@ arranges that @f@ is inlined, regardless of -- its size. More precisely, the call @inline f@ rewrites to the @@ -137,3 +137,27 @@ type DataToTag :: forall {lev :: Levity}. TYPE (BoxedRep lev) -> Constraint -- So it does not get its own Unsafe module, unlike WithDict. class DataToTag a where dataToTag# :: a -> Int# + +-- | Semantically, @considerAccessible = True@. But it has special meaning +-- to the pattern-match checker, which will never flag the clause in which +-- 'considerAccessible' occurs as a guard as redundant or inaccessible. +-- Example: +-- +-- > case (x, x) of +-- > (True, True) -> 1 +-- > (False, False) -> 2 +-- > (True, False) -> 3 -- Warning: redundant +-- +-- The pattern-match checker will warn here that the third clause is redundant. +-- It will stop doing so if the clause is adorned with 'considerAccessible': +-- +-- > case (x, x) of +-- > (True, True) -> 1 +-- > (False, False) -> 2 +-- > (True, False) | considerAccessible -> 3 -- No warning +-- +-- Put 'considerAccessible' as the last statement of the guard to avoid get +-- confusing results from the pattern-match checker, which takes \"consider +-- accessible\" by word. +considerAccessible :: Bool +considerAccessible = True ===================================== libraries/ghc-internal/src/GHC/Internal/Tuple.hs ===================================== @@ -27,10 +27,11 @@ module GHC.Internal.Tuple ( Tuple40(..), Tuple41(..), Tuple42(..), Tuple43(..), Tuple44(..), Tuple45(..), Tuple46(..), Tuple47(..), Tuple48(..), Tuple49(..), Tuple50(..), Tuple51(..), Tuple52(..), Tuple53(..), Tuple54(..), Tuple55(..), Tuple56(..), Tuple57(..), Tuple58(..), Tuple59(..), Tuple60(..), Tuple61(..), Tuple62(..), Tuple63(..), Tuple64(..), + maxTupleSize, ) where -- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base -import GHC.Internal.Types () +import GHC.Internal.Types (Int) default () -- Double and Integer aren't available yet @@ -598,3 +599,6 @@ data Tuple64 a b c d e f g h i j k l m n o p q r s t u v w x y z a1 b1 c1 d1 e1 r1 s1 t1 u1 v1 w1 x1 y1 z1 a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2 l2 = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, r1,s1,t1,u1,v1,w1,x1,y1,z1,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2) + +maxTupleSize :: Int +maxTupleSize = 64 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/af41951a5efa750a9dad9ba877ef0d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/af41951a5efa750a9dad9ba877ef0d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/ticked_joins] WIP: give up on casts
by sheaf (＠sheaf) 26 Jan '26

26 Jan '26

sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC Commits: f84e5d95 by sheaf at 2026-01-26T21:49:00+01:00 WIP: give up on casts - - - - - 3 changed files: - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Monad.hs Changes: ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -2299,7 +2299,7 @@ occ_anal_lam_tail env (Cast expr co) _ -> usage1 -- usage3: see Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration. - usage3 = markAllQuasiTail usage2 -- SLD TODO + usage3 = markAllNonTail usage2 -- SLD TODO in WUD usage3 (Cast expr' co) @@ -2602,6 +2602,7 @@ occAnal env (Tick tickish body) | Breakpoint _ _ ids <- tickish = -- Never substitute for any of the Ids in a Breakpoint addManyOccs usage_lam (mkVarSet ids) + | otherwise = usage_lam @@ -2611,7 +2612,7 @@ occAnal env (Cast expr co) = let (WUD usage expr') = occAnal env expr usage1 = addManyOccs usage (coVarsOfCo co) -- usage1: see Note [Gather occurrences of coercion variables] - usage2 = markAllQuasiTail usage1 -- SLD TODO + usage2 = markAllNonTail usage1 -- SLD TODO -- usage2: see Note [Quasi join points] in WUD usage2 (Cast expr' co) @@ -2748,7 +2749,6 @@ occAnalApp env (Var fun, args, ticks) | fun `hasKey` runRWKey , [t1, t2, arg] <- args , WUD usage arg' <- adjustNonRecRhs (Just 1) $ occAnalLamTail env arg - -- SLD TODO TrueJoinPoint OK here?? = let app_out = mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'] in WUD usage app_out ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -2135,7 +2135,7 @@ trimJoinCont _ NotJoinPoint cont = cont -- Not a jump trimJoinCont var (JoinPoint { joinPointType = join_ty, joinPointArity = arity }) cont | QuasiJoinPoint <- join_ty - -- SLD TODO: not sure why we can end up here. Needs further investigation. + -- As per Note [Quasi join points], don't do any trimming for quasi join points. = cont | otherwise = trim arity cont ===================================== compiler/GHC/Core/Opt/Simplify/Monad.hs ===================================== @@ -214,7 +214,7 @@ newJoinId bndrs body_ty -- arity: See Note [Invariants on join points] invariant 2b, in GHC.Core join_arity = length bndrs details = JoinId - { joinIdType = TrueJoinPoint + { joinIdType = TrueJoinPoint -- SLD TODO this is very suspicious , joinIdArity = join_arity , joinIdCbvMarks = Nothing } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f84e5d955ab9a3233b5ad30a61310b0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f84e5d955ab9a3233b5ad30a61310b0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T26832
by Teo Camarasu (＠teo) 26 Jan '26

26 Jan '26

Teo Camarasu pushed new branch wip/T26832 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T26832 You're receiving this email because of your account on gitlab.haskell.org.

1 0