- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/jeltsch/obtaining-os-handles] Add variants of the operations that do not flush buffers
by Wolfgang Jeltsch (＠jeltsch) 09 Sep '25

09 Sep '25

Wolfgang Jeltsch pushed to branch wip/jeltsch/obtaining-os-handles at Glasgow Haskell Compiler / GHC Commits: a979a516 by Wolfgang Jeltsch at 2025-09-09T17:18:01+03:00 Add variants of the operations that do not flush buffers - - - - - 1 changed file: - libraries/base/src/GHC/IO/Handle.hs Changes: ===================================== libraries/base/src/GHC/IO/Handle.hs ===================================== @@ -79,7 +79,11 @@ module GHC.IO.Handle withFileDescriptorReadingBiased, withFileDescriptorWritingBiased, withWindowsHandleReadingBiased, - withWindowsHandleWritingBiased + withWindowsHandleWritingBiased, + withFileDescriptorReadingBiasedRaw, + withFileDescriptorWritingBiasedRaw, + withWindowsHandleReadingBiasedRaw, + withWindowsHandleWritingBiasedRaw -- ** Caveats -- $with-ref-caveats @@ -90,7 +94,7 @@ import GHC.Internal.IO.Handle import GHC.Internal.Control.Monad (return) import GHC.Internal.Control.Concurrent.MVar (MVar) import GHC.Internal.Control.Exception (mask) -import GHC.Internal.Data.Function ((.), ($)) +import GHC.Internal.Data.Function (const, (.), ($)) import GHC.Internal.Data.Functor (fmap) #if defined(mingw32_HOST_OS) import GHC.Internal.Data.Bool (otherwise) @@ -132,11 +136,11 @@ import GHC.Internal.Foreign.C.Types (CInt) {-| Obtains an operating-system handle that underlies a Haskell handle and - executes a user-provided action on it. The Haskell-managed buffers related - to the operating-system 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. + executes a user-provided action on it. Before the user-provided action is + run, user-defined perparation 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. -} @@ -149,16 +153,18 @@ withOSHandle :: String -} -> (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 handle act +withOSHandle opName handleStateVar getOSHandle prepare handle act = mask $ \ withOriginalMaskingState -> withHandleState $ \ handleState@Handle__ {haDevice = dev} -> do osHandle <- getOSHandle dev - flushBuffer handleState + prepare handleState withOriginalMaskingState $ act osHandle where @@ -272,6 +278,7 @@ withFileDescriptorReadingBiased :: Handle -> (CInt -> IO r) -> IO r withFileDescriptorReadingBiased = withOSHandle "withFileDescriptorReadingBiased" handleStateVarReadingBiased getFileDescriptor + flushBuffer {-| Obtains the POSIX file descriptor that underlies a handle or specifically @@ -290,6 +297,7 @@ withFileDescriptorWritingBiased :: Handle -> (CInt -> IO r) -> IO r withFileDescriptorWritingBiased = withOSHandle "withFileDescriptorWritingBiased" handleStateVarWritingBiased getFileDescriptor + flushBuffer {-| Obtains the Windows handle that underlies a Haskell handle or specifically @@ -308,6 +316,7 @@ withWindowsHandleReadingBiased :: Handle -> (Ptr () -> IO r) -> IO r withWindowsHandleReadingBiased = withOSHandle "withWindowsHandleReadingBiased" handleStateVarReadingBiased getWindowsHandle + flushBuffer {-| Obtains the Windows handle that underlies a Haskell handle or specifically @@ -326,17 +335,62 @@ 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#There are the following caveats regarding each of the - above operations: + #with-ref-caveats#There are the following caveats regarding the above + operations: - * The flushing of buffers can fail if the given handle is readable but not + * Flushing of buffers can fail if the given handle is readable but not seekable. - * If the operation is performed as part of an action executed by + * If one of these operation is performed as part of an action executed by 'unsafePerformIO', '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: View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a979a516a57dc3da9561ebd23a59128… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a979a516a57dc3da9561ebd23a59128… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T26394
by Ben Gamari (＠bgamari) 09 Sep '25

09 Sep '25

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

1 0

[Git][ghc/ghc][wip/jeltsch/obtaining-os-handles] Fix the texts regarding handle type errors
by Wolfgang Jeltsch (＠jeltsch) 09 Sep '25

09 Sep '25

Wolfgang Jeltsch pushed to branch wip/jeltsch/obtaining-os-handles at Glasgow Haskell Compiler / GHC Commits: fd01c7b8 by Wolfgang Jeltsch at 2025-09-09T17:11:46+03:00 Fix the texts regarding handle type errors Note, in particular, that the operations for obtaining operating-system handles also fail with socket-based handles; so failure is not just about the I/O manager in use. - - - - - 1 changed file: - libraries/base/src/GHC/IO/Handle.hs Changes: ===================================== libraries/base/src/GHC/IO/Handle.hs ===================================== @@ -198,38 +198,45 @@ 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 a certain I/O subsystem is not in use. + because some Haskell handle does not use an operating-system handle of a + required type. -} -requiringSubsystem :: String - -- ^ The name of the required subsystem - -> Maybe a - -- ^ The result of the other operation if it succeeded - -> IO a -requiringSubsystem subsystemName - = maybe (ioException subsystemRequired) return +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 - subsystemRequired :: IOException - subsystemRequired = IOError Nothing - IllegalOperation - "" - (subsystemName ++ " I/O subsystem required") - Nothing - Nothing + osHandleOfTypeRequired :: IOException + osHandleOfTypeRequired + = IOError Nothing + IllegalOperation + "" + ("handle does not use " ++ osHandleTypeName ++ "s") + Nothing + Nothing {-| - Obtains the POSIX file descriptor of a device if the POSIX I/O subsystem is - in use, and throws an exception otherwise. + 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 = requiringSubsystem "POSIX" . fmap fdFD . cast +getFileDescriptor = requiringOSHandleOfType "POSIX file descriptor" . + fmap fdFD . cast {-| - Obtains the Windows handle of a device if the Windows I/O subsystem is in - use, and throws an exception otherwise. + Obtains the Windows handle of a device if the device contains one, and + throws an exception otherwise. -} getWindowsHandle :: Typeable d => d -> IO (Ptr ()) -getWindowsHandle = requiringSubsystem "native" . toMaybeWindowsHandle where +getWindowsHandle = requiringOSHandleOfType "Windows handle" . + toMaybeWindowsHandle + where toMaybeWindowsHandle :: Typeable d => d -> Maybe (Ptr ()) #if defined(mingw32_HOST_OS) @@ -257,7 +264,7 @@ getWindowsHandle = requiringSubsystem "native" . toMaybeWindowsHandle where further operations on the handle are blocked to a degree that interference with this action is prevented. - If the I/O subsystem in use is not the POSIX one, an exception is thrown. + If the handle does not use POSIX file descriptors, an exception is thrown. See [below](#with-ref-caveats) for caveats regarding this operation. -} @@ -275,7 +282,7 @@ withFileDescriptorReadingBiased = withOSHandle "withFileDescriptorReadingBiased" further operations on the handle are blocked to a degree that interference with this action is prevented. - If the I/O subsystem in use is not the POSIX one, an exception is thrown. + If the handle does not use POSIX file descriptors, an exception is thrown. See [below](#with-ref-caveats) for caveats regarding this operation. -} @@ -293,7 +300,7 @@ withFileDescriptorWritingBiased = withOSHandle "withFileDescriptorWritingBiased" operations on the Haskell handle are blocked to a degree that interference with this action is prevented. - If the I/O subsystem in use is not the Windows one, an exception is thrown. + If the Haskell handle does not use Windows handles, an exception is thrown. See [below](#with-ref-caveats) for caveats regarding this operation. -} @@ -311,7 +318,7 @@ withWindowsHandleReadingBiased = withOSHandle "withWindowsHandleReadingBiased" operations on the Haskell handle are blocked to a degree that interference with this action is prevented. - If the I/O subsystem in use is not the Windows one, an exception is thrown. + If the Haskell handle does not use Windows handles, an exception is thrown. See [below](#with-ref-caveats) for caveats regarding this operation. -} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fd01c7b8ce5eca29346fcb90257c757… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fd01c7b8ce5eca29346fcb90257c757… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/obtaining-os-handles] Fix the texts regarding handle type errors
by Wolfgang Jeltsch (＠jeltsch) 09 Sep '25

09 Sep '25

Wolfgang Jeltsch pushed to branch wip/jeltsch/obtaining-os-handles at Glasgow Haskell Compiler / GHC Commits: 87b8495c by Wolfgang Jeltsch at 2025-09-09T17:10:21+03:00 Fix the texts regarding handle type errors Note, in particular, that the operations for obtaining operating-system handles also fail with socket-based handles; so failure is not just about the I/O manager in use. - - - - - 1 changed file: - libraries/base/src/GHC/IO/Handle.hs Changes: ===================================== libraries/base/src/GHC/IO/Handle.hs ===================================== @@ -198,38 +198,45 @@ 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 a certain I/O subsystem is not in use. + because some Haskell handle does not use an operating-system handle of a + required type. -} -requiringSubsystem :: String - -- ^ The name of the required subsystem - -> Maybe a - -- ^ The result of the other operation if it succeeded - -> IO a -requiringSubsystem subsystemName - = maybe (ioException subsystemRequired) return +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 - subsystemRequired :: IOException - subsystemRequired = IOError Nothing - IllegalOperation - "" - (subsystemName ++ " I/O subsystem required") - Nothing - Nothing + osHandleOfTypeRequired :: IOException + osHandleOfTypeRequired + = IOError Nothing + IllegalOperation + "" + ("handle does not use " ++ osHandleTypeName ++ "s") + Nothing + Nothing {-| - Obtains the POSIX file descriptor of a device if the POSIX I/O subsystem is - in use, and throws an exception otherwise. + 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 = requiringSubsystem "POSIX" . fmap fdFD . cast +getFileDescriptor = requiringOSHandleType "POSIX file descriptor" . + fmap fdFD . cast {-| - Obtains the Windows handle of a device if the Windows I/O subsystem is in - use, and throws an exception otherwise. + Obtains the Windows handle of a device if the device contains one, and + throws an exception otherwise. -} getWindowsHandle :: Typeable d => d -> IO (Ptr ()) -getWindowsHandle = requiringSubsystem "native" . toMaybeWindowsHandle where +getWindowsHandle = requiringOSHandleType "Windows handle" . + toMaybeWindowsHandle + where toMaybeWindowsHandle :: Typeable d => d -> Maybe (Ptr ()) #if defined(mingw32_HOST_OS) @@ -257,7 +264,7 @@ getWindowsHandle = requiringSubsystem "native" . toMaybeWindowsHandle where further operations on the handle are blocked to a degree that interference with this action is prevented. - If the I/O subsystem in use is not the POSIX one, an exception is thrown. + If the handle does not use POSIX file descriptors, an exception is thrown. See [below](#with-ref-caveats) for caveats regarding this operation. -} @@ -275,7 +282,7 @@ withFileDescriptorReadingBiased = withOSHandle "withFileDescriptorReadingBiased" further operations on the handle are blocked to a degree that interference with this action is prevented. - If the I/O subsystem in use is not the POSIX one, an exception is thrown. + If the handle does not use POSIX file descriptors, an exception is thrown. See [below](#with-ref-caveats) for caveats regarding this operation. -} @@ -293,7 +300,7 @@ withFileDescriptorWritingBiased = withOSHandle "withFileDescriptorWritingBiased" operations on the Haskell handle are blocked to a degree that interference with this action is prevented. - If the I/O subsystem in use is not the Windows one, an exception is thrown. + If the Haskell handle does not use Windows handles, an exception is thrown. See [below](#with-ref-caveats) for caveats regarding this operation. -} @@ -311,7 +318,7 @@ withWindowsHandleReadingBiased = withOSHandle "withWindowsHandleReadingBiased" operations on the Haskell handle are blocked to a degree that interference with this action is prevented. - If the I/O subsystem in use is not the Windows one, an exception is thrown. + If the Haskell handle does not use Windows handles, an exception is thrown. See [below](#with-ref-caveats) for caveats regarding this operation. -} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/87b8495c487b179e6d69da213485faa… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/87b8495c487b179e6d69da213485faa… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/26264] compiler: Attempt to systematize Unique tags by introducing an ADT for each different tag
by Zubin (＠wz1000) 09 Sep '25

09 Sep '25

Zubin pushed to branch wip/26264 at Glasgow Haskell Compiler / GHC Commits: 12a57111 by Zubin Duggal at 2025-09-09T18:32:32+05:30 compiler: Attempt to systematize Unique tags by introducing an ADT for each different tag Fixes #26264 - - - - - 32 changed files: - compiler/GHC/Builtin/Uniques.hs - compiler/GHC/Cmm/Info.hs - compiler/GHC/Cmm/Info/Build.hs - compiler/GHC/Cmm/Pipeline.hs - compiler/GHC/Cmm/UniqueRenamer.hs - compiler/GHC/CmmToLlvm/Base.hs - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Simplify/Monad.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/HsToCore/Foreign/JavaScript.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/Iface/Binary.hs - compiler/GHC/Iface/Rename.hs - compiler/GHC/JS/JStg/Monad.hs - compiler/GHC/Platform/Reg.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Stg/EnforceEpt.hs - compiler/GHC/Stg/Pipeline.hs - compiler/GHC/StgToCmm/ExtCode.hs - compiler/GHC/StgToCmm/Monad.hs - compiler/GHC/StgToJS/CodeGen.hs - compiler/GHC/StgToJS/Ids.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Name/Cache.hs - compiler/GHC/Types/Unique.hs - compiler/GHC/Types/Unique/DSM.hs - compiler/GHC/Types/Unique/Supply.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/12a57111dbc025a1459d5bff8faba46… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/12a57111dbc025a1459d5bff8faba46… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/26352
by Zubin (＠wz1000) 09 Sep '25

09 Sep '25

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

1 0

[Git][ghc/ghc] Pushed new branch wip/T26349
by Simon Peyton Jones (＠simonpj) 09 Sep '25

09 Sep '25

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

1 0

[Git][ghc/ghc][wip/26264] compiler: Attempt to systematize Unique tags by introducing an ADT for each different tag
by Zubin (＠wz1000) 09 Sep '25

09 Sep '25

Zubin pushed to branch wip/26264 at Glasgow Haskell Compiler / GHC Commits: ae584a58 by Zubin Duggal at 2025-09-09T17:30:24+05:30 compiler: Attempt to systematize Unique tags by introducing an ADT for each different tag Fixes #26264 - - - - - 32 changed files: - compiler/GHC/Builtin/Uniques.hs - compiler/GHC/Cmm/Info.hs - compiler/GHC/Cmm/Info/Build.hs - compiler/GHC/Cmm/Pipeline.hs - compiler/GHC/Cmm/UniqueRenamer.hs - compiler/GHC/CmmToLlvm/Base.hs - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Simplify/Monad.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/HsToCore/Foreign/JavaScript.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/Iface/Binary.hs - compiler/GHC/Iface/Rename.hs - compiler/GHC/JS/JStg/Monad.hs - compiler/GHC/Platform/Reg.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Stg/EnforceEpt.hs - compiler/GHC/Stg/Pipeline.hs - compiler/GHC/StgToCmm/ExtCode.hs - compiler/GHC/StgToCmm/Monad.hs - compiler/GHC/StgToJS/CodeGen.hs - compiler/GHC/StgToJS/Ids.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Name/Cache.hs - compiler/GHC/Types/Unique.hs - compiler/GHC/Types/Unique/DSM.hs - compiler/GHC/Types/Unique/Supply.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ae584a589a00ffb611eacc4ff20deb0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ae584a589a00ffb611eacc4ff20deb0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/26264] 22 commits: cleanup: Move dehydrateCgBreakInfo to Stg2Bc
by Zubin (＠wz1000) 09 Sep '25

09 Sep '25

Zubin pushed to branch wip/26264 at Glasgow Haskell Compiler / GHC Commits: 79816cc4 by Rodrigo Mesquita at 2025-09-02T12:19:59-04:00 cleanup: Move dehydrateCgBreakInfo to Stg2Bc This no longer has anything to do with Core. - - - - - 53da94ff by Rodrigo Mesquita at 2025-09-02T12:19:59-04:00 rts/Disassembler: Fix spacing of BRK_FUN - - - - - 08c0cf85 by Rodrigo Mesquita at 2025-09-02T12:19:59-04:00 debugger: Fix bciPtr in Step-out We need to use `BCO_NEXT` to move bciPtr to ix=1, because ix=0 points to the instruction itself! I do not understand how this didn't crash before. - - - - - e7e021fa by Rodrigo Mesquita at 2025-09-02T12:19:59-04:00 debugger: Allow BRK_FUNs to head case continuation BCOs When we start executing a BCO, we may want to yield to the scheduler: this may be triggered by a heap/stack check, context switch, or a breakpoint. To yield, we need to put the stack in a state such that when execution is resumed we are back to where we yielded from. Previously, a BKR_FUN could only head a function BCO because we only knew how to construct a valid stack for yielding from one -- simply add `apply_interp_info` + the BCO to resume executing. This is valid because the stack at the start of run_BCO is headed by that BCO's arguments. However, in case continuation BCOs (as per Note [Case continuation BCOs]), we couldn't easily reconstruct a valid stack that could be resumed because we dropped too soon the stack frames regarding the value returned (stg_ret) and received (stg_ctoi) by that continuation. This is especially tricky because of the variable type and size return frames (e.g. pointer ret_p/ctoi_R1p vs a tuple ret_t/ctoi_t2). The trick to being able to yield from a BRK_FUN at the start of a case cont BCO is to stop removing the ret frame headers eagerly and instead keep them until the BCO starts executing. The new layout at the start of a case cont. BCO is described by the new Note [Stack layout when entering run_BCO]. Now, we keep the ret_* and ctoi_* frames when entering run_BCO. A BRK_FUN is then executed if found, and the stack is yielded as-is with the preserved ret and ctoi frames. Then, a case cont BCO's instructions always SLIDE off the headers of the ret and ctoi frames, in StgToByteCode.doCase, turning a stack like | .... | +---------------+ | fv2 | +---------------+ | fv1 | +---------------+ | BCO | +---------------+ | stg_ctoi_ret_ | +---------------+ | retval | +---------------+ | stg_ret_..... | +---------------+ into | .... | +---------------+ | fv2 | +---------------+ | fv1 | +---------------+ | retval | +---------------+ for the remainder of the BCO. Moreover, this more uniform approach of keeping the ret and ctoi frames means we need less ad-hoc logic concerning the variable size of ret_tuple vs ret_p/np frames in the code generator and interpreter: Always keep the return to cont. stack intact at the start of run_BCO, and the statically generated instructions will take care of adjusting it. Unlocks BRK_FUNs at the start of case cont. BCOs which will enable a better user-facing step-out (#26042) which is free of the bugs the current BRK_ALTS implementation suffers from (namely, using BRK_FUN rather than BRK_ALTS in a case cont. means we'll never accidentally end up in a breakpoint "deeper" than the continuation, because we stop at the case cont itself rather than on the first breakpoint we evaluate after it). - - - - - ade3c1e6 by Rodrigo Mesquita at 2025-09-02T12:19:59-04:00 BRK_FUN with InternalBreakLocs for code-generation time breakpoints At the start of a case continuation BCO, place a BRK_FUN. This BRK_FUN uses the new "internal breakpoint location" -- allowing us to come up with a valid source location for this breakpoint that is not associated with a source-level tick. For case continuation BCOs, we use the last tick seen before it as the source location. The reasoning is described in Note [Debugger: Stepout internal break locs]. Note how T26042c, which was broken because it displayed the incorrect behavior of the previous step out when we'd end up at a deeper level than the one from which we initiated step-out, is now fixed. As of this commit, BRK_ALTS is now dead code and is thus dropped. Note [Debugger: Stepout internal break locs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Step-out tells the interpreter to run until the current function returns to where it was called from, and stop there. This is achieved by enabling the BRK_FUN found on the first RET_BCO frame on the stack (See [Note Debugger: Step-out]). Case continuation BCOs (which select an alternative branch) must therefore be headed by a BRK_FUN. An example: f x = case g x of <--- end up here 1 -> ... 2 -> ... g y = ... <--- step out from here - `g` will return a value to the case continuation BCO in `f` - The case continuation BCO will receive the value returned from g - Match on it and push the alternative continuation for that branch - And then enter that alternative. If we step-out of `g`, the first RET_BCO on the stack is the case continuation of `f` -- execution should stop at its start, before selecting an alternative. (One might ask, "why not enable the breakpoint in the alternative instead?", because the alternative continuation is only pushed to the stack *after* it is selected by the case cont. BCO) However, the case cont. BCO is not associated with any source-level tick, it is merely the glue code which selects alternatives which do have source level ticks. Therefore, we have to come up at code generation time with a breakpoint location ('InternalBreakLoc') to display to the user when it is stopped there. Our solution is to use the last tick seen just before reaching the case continuation. This is robust because a case continuation will thus always have a relevant breakpoint location: - The source location will be the last source-relevant expression executed before the continuation is pushed - So the source location will point to the thing you've just stepped out of - Doing :step-local from there will put you on the selected alternative (which at the source level may also be the e.g. next line in a do-block) Examples, using angle brackets (<<...>>) to denote the breakpoint span: f x = case <<g x>> {- step in here -} of 1 -> ... 2 -> ...> g y = <<...>> <--- step out from here ... f x = <<case g x of <--- end up here, whole case highlighted 1 -> ... 2 -> ...>> doing :step-local ... f x = case g x of 1 -> <<...>> <--- stop in the alternative 2 -> ... A second example based on T26042d2, where the source is a do-block IO action, optimised to a chain of `case expressions`. main = do putStrLn "hello1" <<f>> <--- step-in here putStrLn "hello3" putStrLn "hello4" f = do <<putStrLn "hello2.1">> <--- step-out from here putStrLn "hello2.2" ... main = do putStrLn "hello1" <<f>> <--- end up here again, the previously executed expression putStrLn "hello3" putStrLn "hello4" doing step/step-local ... main = do putStrLn "hello1" f <<putStrLn "hello3">> <--- straight to the next line putStrLn "hello4" Finishes #26042 - - - - - c66910c0 by Rodrigo Mesquita at 2025-09-02T12:19:59-04:00 debugger: Re-use the last BreakpointId whole in step-out Previously, to come up with a location to stop at for `:stepout`, we would store the location of the last BreakpointId surrounding the continuation, as described by Note [Debugger: Stepout internal break locs]. However, re-using just the location from the last source breakpoint isn't sufficient to provide the necessary information in the break location. Specifically, it wouldn't bind any variables at that location. Really, there is no reason not to re-use the last breakpoint wholesale, and re-use all the information we had there. Step-out should behave just as if we had stopped at the call, but s.t. continuing will not re-execute the call. This commit updates the CgBreakInfo to always store a BreakpointId, be it the original one or the one we're emulating (for step-out). It makes variable bindings on :stepout work - - - - - e4abed7b by sheaf at 2025-09-02T12:20:40-04:00 Revert accidental changes to hie.yaml - - - - - 003b715b by meooow25 at 2025-09-02T23:48:51+02:00 Adjust the strictness of Data.List.iterate' * Don't force the next element in advance when generating a (:). * Force the first element to WHNF like every other element. Now every element in the output list is forced to WHNF when the (:) containing it is forced. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/335 - - - - - b2f6aad0 by Simon Hengel at 2025-09-03T04:36:10-04:00 Refactoring: More consistently use logOutput, logInfo, fatalErrorMsg - - - - - 60a16db7 by Rodrigo Mesquita at 2025-09-03T10:55:50+01:00 bytecode: Don't PUSH_L 0; SLIDE 1 1 While looking through bytecode I noticed a quite common unfortunate pattern: ... PUSH_L 0 SLIDE 1 1 We do this often by generically constructing a tail call from a function atom that may be somewhere arbitrary on the stack. However, for the special case that the function can be found directly on top of the stack, as part of the arguments, it's plain redundant to push then slide it. In this commit we add a small optimisation to the generation of tailcalls in bytecode. Simply: lookahead for the function in the stack. If it is the first thing on the stack and it is part of the arguments which would be dropped as we entered the tail call, then don't push then slide it. In a simple example (T26042b), this already produced a drastic improvement in generated code (left is old, right is with this patch): ```diff 3c3 < 2025-07-29 10:14:02.081277 UTC --- > 2025-07-29 10:50:36.560949 UTC 160,161c160 < PUSH_L 0 < SLIDE 1 2 --- > SLIDE 1 1 164,165d162 < PUSH_L 0 < SLIDE 1 1 175,176c172 < PUSH_L 0 < SLIDE 1 2 --- > SLIDE 1 1 179,180d174 < PUSH_L 0 < SLIDE 1 1 206,207d199 < PUSH_L 0 < SLIDE 1 1 210,211d201 < PUSH_L 0 < SLIDE 1 1 214,215d203 < PUSH_L 0 < SLIDE 1 1 218,219d205 < PUSH_L 0 < SLIDE 1 1 222,223d207 < PUSH_L 0 < SLIDE 1 1 ... 600,601c566 < PUSH_L 0 < SLIDE 1 2 --- > SLIDE 1 1 604,605d568 < PUSH_L 0 < SLIDE 1 1 632,633d594 < PUSH_L 0 < SLIDE 1 1 636,637d596 < PUSH_L 0 < SLIDE 1 1 640,641d598 < PUSH_L 0 < SLIDE 1 1 644,645d600 < PUSH_L 0 < SLIDE 1 1 648,649d602 < PUSH_L 0 < SLIDE 1 1 652,653d604 < PUSH_L 0 < SLIDE 1 1 656,657d606 < PUSH_L 0 < SLIDE 1 1 660,661d608 < PUSH_L 0 < SLIDE 1 1 664,665d610 < PUSH_L 0 < SLIDE 1 1 ``` I also compiled lib:Cabal to bytecode and counted the number of bytecode lines with `find dist-newstyle -name "*.dump-BCOs" -exec wc {} +`: with unoptimized core: 1190689 lines (before) - 1172891 lines (now) = 17798 less redundant instructions (-1.5% lines) with optimized core: 1924818 lines (before) - 1864836 lines (now) = 59982 less redundant instructions (-3.1% lines) - - - - - 8b2c72c0 by L0neGamer at 2025-09-04T06:32:03-04:00 Add Control.Monad.thenM and Control.Applicative.thenA - - - - - 39e1b7cb by Teo Camarasu at 2025-09-04T06:32:46-04:00 ghc-internal: invert dependency of GHC.Internal.TH.Syntax on Data.Data This means that Data.Data no longer blocks building TH.Syntax, which allows greater parallelism in our builds. We move the Data.Data.Data instances to Data.Data. Quasi depends on Data.Data for one of its methods, so, we split the Quasi/Q, etc definition out of GHC.Internal.TH.Syntax into its own module. This has the added benefit of splitting up this quite large module. Previously TH.Syntax was a bottleneck when compiling ghc-internal. Now it is less of a bottle-neck and is also slightly quicker to compile (since it no longer contains these instances) at the cost of making Data.Data slightly more expensive to compile. TH.Lift which depends on TH.Syntax can also compile quicker and no longer blocks ghc-internal finishing to compile. Resolves #26217 ------------------------- Metric Decrease: MultiLayerModulesTH_OneShot T13253 T21839c T24471 Metric Increase: T12227 ------------------------- - - - - - bdf82fd2 by Teo Camarasu at 2025-09-04T06:32:46-04:00 compiler: delete unused names in Builtins.Names.TH returnQ and bindQ are no longer used in the compiler. There was also a very old comment that referred to them that I have modernized - - - - - 41a448e5 by Ben Gamari at 2025-09-04T19:21:43-04:00 hadrian: Pass lib & include directories to ghc `Setup configure` - - - - - 46bb9a79 by Ben Gamari at 2025-09-04T19:21:44-04:00 rts/IPE: Fix compilation when zstd is enabled This was broken by the refactoring undertaken in c80dd91c0bf6ac034f0c592f16c548b9408a8481. Closes #26312. - - - - - 138a6e34 by sheaf at 2025-09-04T19:22:46-04:00 Make mkCast assertion a bit clearer This commit changes the assertion message that gets printed when one calls mkCast with a coercion whose kind does not match the type of the inner expression. I always found the assertion message a bit confusing, as it didn't clearly state what exactly was the error. - - - - - 9d626be1 by sheaf at 2025-09-04T19:22:46-04:00 Simplifier/rules: fix mistakes in Notes & comments - - - - - 94b62aa7 by Simon Peyton Jones at 2025-09-08T03:37:14-04:00 Refactor ForAllCo This is a pure refactor, addressing #26389. It arranges that the kind coercion in a ForAllCo is a MCoercion, rather than a plain Coercion, thus removing redundancy in the common case. See (FC8) in Note [ForAllCo] It's a nice cleanup. - - - - - 624afa4a by sheaf at 2025-09-08T03:38:05-04:00 Use tcMkScaledFunTys in matchExpectedFunTys We should use tcMkScaledFunTys rather than mkScaledFunTys in GHC.Tc.Utils.Unify.matchExpectedFunTys, as the latter crashes when the kind of the result type is a bare metavariable. We know the result is always Type-like, so we don't need scaledFunTys to try to rediscover that from the kind. Fixes #26277 - - - - - 0975d2b6 by sheaf at 2025-09-08T03:38:54-04:00 Revert "Remove hptAllFamInstances usage during upsweep" This reverts commit 3bf6720eff5e86e673568e756161e6d6150eb440. - - - - - 0cf34176 by soulomoon at 2025-09-08T03:38:54-04:00 Family consistency checks: add test for #26154 This commit adds the test T26154, to make sure that GHC doesn't crash when performing type family consistency checks. This test case was extracted from Agda. Fixes #26154 - - - - - 0d93ce50 by Zubin Duggal at 2025-09-09T16:55:25+05:30 compiler: Attempt to systematize Unique tags by introducing an ADT for each different tag Fixes #26264 - - - - - 145 changed files: - compiler/GHC/Builtin/Names/TH.hs - compiler/GHC/Builtin/Uniques.hs - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Breakpoints.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/Cmm/Info.hs - compiler/GHC/Cmm/Info/Build.hs - compiler/GHC/Cmm/Pipeline.hs - compiler/GHC/Cmm/UniqueRenamer.hs - compiler/GHC/CmmToLlvm/Base.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Coercion.hs-boot - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Simplify.hs - compiler/GHC/Core/Opt/Simplify/Monad.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Reduction.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/TyCo/Tidy.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Data/IOEnv.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Binary.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Rename.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/JS/JStg/Monad.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Platform/Reg.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Stg/EnforceEpt.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/Stg/Pipeline.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm/ExtCode.hs - compiler/GHC/StgToCmm/Monad.hs - compiler/GHC/StgToJS/CodeGen.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Gen/Splice.hs-boot - compiler/GHC/Tc/Instance/Family.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Types/TH.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/Name/Cache.hs - compiler/GHC/Types/Unique.hs - compiler/GHC/Types/Unique/DSM.hs - compiler/GHC/Types/Unique/Supply.hs - compiler/GHC/Unit/Home/Graph.hs - compiler/GHC/Unit/Home/PackageTable.hs - ghc/GHCi/UI.hs - hadrian/src/Settings/Packages.hs - hie.yaml - libraries/base/changelog.md - libraries/base/src/Control/Applicative.hs - libraries/base/src/Control/Monad.hs - libraries/base/src/Data/Array/Byte.hs - libraries/base/src/Data/Fixed.hs - + libraries/ghc-boot-th/GHC/Boot/TH/Monad.hs - libraries/ghc-boot-th/ghc-boot-th.cabal.in - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Base.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad.hs - libraries/ghc-internal/src/GHC/Internal/Data/Data.hs - libraries/ghc-internal/src/GHC/Internal/List.hs - libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs - libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs - + libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs - libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/GHCi/TH.hs - libraries/template-haskell/Language/Haskell/TH/Quote.hs - libraries/template-haskell/Language/Haskell/TH/Syntax.hs - rts/Disassembler.c - rts/IPE.c - rts/Interpreter.c - rts/Profiling.c - rts/include/rts/Bytecodes.h - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/deriving/should_compile/T14682.stderr - testsuite/tests/deriving/should_compile/drv-empty-data.stderr - testsuite/tests/ghci.debugger/scripts/T26042b.script - testsuite/tests/ghci.debugger/scripts/T26042b.stdout - testsuite/tests/ghci.debugger/scripts/T26042c.script - testsuite/tests/ghci.debugger/scripts/T26042c.stdout - + testsuite/tests/ghci.debugger/scripts/T26042d2.hs - + testsuite/tests/ghci.debugger/scripts/T26042d2.script - + testsuite/tests/ghci.debugger/scripts/T26042d2.stdout - testsuite/tests/ghci.debugger/scripts/T26042e.stdout - testsuite/tests/ghci.debugger/scripts/T26042f.script - testsuite/tests/ghci.debugger/scripts/T26042f1.stdout - testsuite/tests/ghci.debugger/scripts/T26042f2.stdout - testsuite/tests/ghci.debugger/scripts/T26042g.stdout - testsuite/tests/ghci.debugger/scripts/all.T - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/plugins/plugins10.stdout - testsuite/tests/profiling/should_run/callstack001.stdout - testsuite/tests/simplCore/should_compile/OpaqueNoCastWW.stderr - testsuite/tests/splice-imports/SI29.stderr - testsuite/tests/th/T11452.stderr - testsuite/tests/th/T15321.stderr - testsuite/tests/th/T7276.stderr - testsuite/tests/th/TH_NestedSplicesFail3.stderr - testsuite/tests/th/TH_NestedSplicesFail4.stderr - + testsuite/tests/typecheck/should_compile/T26154.hs - + testsuite/tests/typecheck/should_compile/T26154_A.hs - + testsuite/tests/typecheck/should_compile/T26154_B.hs - + testsuite/tests/typecheck/should_compile/T26154_B.hs-boot - + testsuite/tests/typecheck/should_compile/T26154_Other.hs - + testsuite/tests/typecheck/should_compile/T26277.hs - testsuite/tests/typecheck/should_compile/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ccd2023e2d2a98d406f77b55a855bc… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ccd2023e2d2a98d406f77b55a855bc… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/supersven/fix-foundation-test-shift-amounts] foundation test: Fix shift amount (#26248)
by Sven Tennie (＠supersven) 09 Sep '25

09 Sep '25

Sven Tennie pushed to branch wip/supersven/fix-foundation-test-shift-amounts at Glasgow Haskell Compiler / GHC Commits: 817899db by Sven Tennie at 2025-09-09T11:41:55+02:00 foundation test: Fix shift amount (#26248) Shift primops' results are only defined for shift amounts of 0 to word size - 1. The approach is similar to testing div-like operations (which have a constraint regarding zero operands.) This was partly vibe coded (https://github.com/supersven/ghc/pull/1) but then heavily refactored. - - - - - 4 changed files: - compiler/GHC/Builtin/primops.txt.pp - testsuite/tests/numeric/should_run/foundation.hs - utils/genprimopcode/Main.hs - utils/genprimopcode/Syntax.hs Changes: ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -148,6 +148,7 @@ defaults vector = [] deprecated_msg = {} -- A non-empty message indicates deprecation div_like = False -- Second argument expected to be non zero - used for tests + shift_like = False -- Second argument expected to be atmost first argument's word size -1 - used for tests defined_bits = Nothing -- The number of bits the operation is defined for (if not all bits) -- Note [When do out-of-line primops go in primops.txt.pp] @@ -312,8 +313,16 @@ primop Int8QuotRemOp "quotRemInt8#" GenPrimOp Int8# -> Int8# -> (# Int8#, Int8# div_like = True primop Int8SllOp "uncheckedShiftLInt8#" GenPrimOp Int8# -> Int# -> Int8# + with + shift_like = True + primop Int8SraOp "uncheckedShiftRAInt8#" GenPrimOp Int8# -> Int# -> Int8# + with + shift_like = True + primop Int8SrlOp "uncheckedShiftRLInt8#" GenPrimOp Int8# -> Int# -> Int8# + with + shift_like = True primop Int8ToWord8Op "int8ToWord8#" GenPrimOp Int8# -> Word8# with code_size = 0 @@ -372,7 +381,12 @@ primop Word8XorOp "xorWord8#" GenPrimOp Word8# -> Word8# -> Word8# primop Word8NotOp "notWord8#" GenPrimOp Word8# -> Word8# primop Word8SllOp "uncheckedShiftLWord8#" GenPrimOp Word8# -> Int# -> Word8# + with + shift_like = True + primop Word8SrlOp "uncheckedShiftRLWord8#" GenPrimOp Word8# -> Int# -> Word8# + with + shift_like = True primop Word8ToInt8Op "word8ToInt8#" GenPrimOp Word8# -> Int8# with code_size = 0 @@ -422,8 +436,16 @@ primop Int16QuotRemOp "quotRemInt16#" GenPrimOp Int16# -> Int16# -> (# Int16#, I div_like = True primop Int16SllOp "uncheckedShiftLInt16#" GenPrimOp Int16# -> Int# -> Int16# + with + shift_like = True + primop Int16SraOp "uncheckedShiftRAInt16#" GenPrimOp Int16# -> Int# -> Int16# + with + shift_like = True + primop Int16SrlOp "uncheckedShiftRLInt16#" GenPrimOp Int16# -> Int# -> Int16# + with + shift_like = True primop Int16ToWord16Op "int16ToWord16#" GenPrimOp Int16# -> Word16# with code_size = 0 @@ -482,7 +504,12 @@ primop Word16XorOp "xorWord16#" GenPrimOp Word16# -> Word16# -> Word16# primop Word16NotOp "notWord16#" GenPrimOp Word16# -> Word16# primop Word16SllOp "uncheckedShiftLWord16#" GenPrimOp Word16# -> Int# -> Word16# + with + shift_like = True + primop Word16SrlOp "uncheckedShiftRLWord16#" GenPrimOp Word16# -> Int# -> Word16# + with + shift_like = True primop Word16ToInt16Op "word16ToInt16#" GenPrimOp Word16# -> Int16# with code_size = 0 @@ -532,8 +559,16 @@ primop Int32QuotRemOp "quotRemInt32#" GenPrimOp Int32# -> Int32# -> (# Int32#, I div_like = True primop Int32SllOp "uncheckedShiftLInt32#" GenPrimOp Int32# -> Int# -> Int32# + with + shift_like = True + primop Int32SraOp "uncheckedShiftRAInt32#" GenPrimOp Int32# -> Int# -> Int32# + with + shift_like = True + primop Int32SrlOp "uncheckedShiftRLInt32#" GenPrimOp Int32# -> Int# -> Int32# + with + shift_like = True primop Int32ToWord32Op "int32ToWord32#" GenPrimOp Int32# -> Word32# with code_size = 0 @@ -592,7 +627,12 @@ primop Word32XorOp "xorWord32#" GenPrimOp Word32# -> Word32# -> Word32# primop Word32NotOp "notWord32#" GenPrimOp Word32# -> Word32# primop Word32SllOp "uncheckedShiftLWord32#" GenPrimOp Word32# -> Int# -> Word32# + with + shift_like = True + primop Word32SrlOp "uncheckedShiftRLWord32#" GenPrimOp Word32# -> Int# -> Word32# + with + shift_like = True primop Word32ToInt32Op "word32ToInt32#" GenPrimOp Word32# -> Int32# with code_size = 0 @@ -637,8 +677,16 @@ primop Int64RemOp "remInt64#" GenPrimOp Int64# -> Int64# -> Int64# div_like = True primop Int64SllOp "uncheckedIShiftL64#" GenPrimOp Int64# -> Int# -> Int64# + with + shift_like = True + primop Int64SraOp "uncheckedIShiftRA64#" GenPrimOp Int64# -> Int# -> Int64# + with + shift_like = True + primop Int64SrlOp "uncheckedIShiftRL64#" GenPrimOp Int64# -> Int# -> Int64# + with + shift_like = True primop Int64ToWord64Op "int64ToWord64#" GenPrimOp Int64# -> Word64# with code_size = 0 @@ -692,7 +740,12 @@ primop Word64XorOp "xor64#" GenPrimOp Word64# -> Word64# -> Word64# primop Word64NotOp "not64#" GenPrimOp Word64# -> Word64# primop Word64SllOp "uncheckedShiftL64#" GenPrimOp Word64# -> Int# -> Word64# + with + shift_like = True + primop Word64SrlOp "uncheckedShiftRL64#" GenPrimOp Word64# -> Int# -> Word64# + with + shift_like = True primop Word64ToInt64Op "word64ToInt64#" GenPrimOp Word64# -> Int64# with code_size = 0 @@ -865,12 +918,20 @@ primop WordToDoubleOp "word2Double#" GenPrimOp Word# -> Double# primop IntSllOp "uncheckedIShiftL#" GenPrimOp Int# -> Int# -> Int# {Shift left. Result undefined if shift amount is not in the range 0 to word size - 1 inclusive.} + with + shift_like = True + primop IntSraOp "uncheckedIShiftRA#" GenPrimOp Int# -> Int# -> Int# {Shift right arithmetic. Result undefined if shift amount is not in the range 0 to word size - 1 inclusive.} + with + shift_like = True + primop IntSrlOp "uncheckedIShiftRL#" GenPrimOp Int# -> Int# -> Int# {Shift right logical. Result undefined if shift amount is not in the range 0 to word size - 1 inclusive.} + with + shift_like = True ------------------------------------------------------------------------ section "Word#" @@ -946,9 +1007,14 @@ primop WordNotOp "not#" GenPrimOp Word# -> Word# primop WordSllOp "uncheckedShiftL#" GenPrimOp Word# -> Int# -> Word# {Shift left logical. Result undefined if shift amount is not in the range 0 to word size - 1 inclusive.} + with + shift_like = True + primop WordSrlOp "uncheckedShiftRL#" GenPrimOp Word# -> Int# -> Word# {Shift right logical. Result undefined if shift amount is not in the range 0 to word size - 1 inclusive.} + with + shift_like = True primop WordToIntOp "word2Int#" GenPrimOp Word# -> Int# with code_size = 0 ===================================== testsuite/tests/numeric/should_run/foundation.hs ===================================== @@ -13,6 +13,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeAbstractions #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE MagicHash #-} @@ -24,7 +25,7 @@ module Main ( main ) where -import Data.Bits (Bits((.&.), bit)) +import Data.Bits (Bits((.&.), bit), FiniteBits, finiteBitSize) import Data.Word import Data.Int import GHC.Natural @@ -133,6 +134,16 @@ newtype NonZero a = NonZero { getNonZero :: a } instance (Arbitrary a, Num a, Eq a) => Arbitrary (NonZero a) where arbitrary = nonZero +-- | A newtype for shift amounts that are bounded by @wordSize - 1@ +newtype BoundedShiftAmount a = BoundedShiftAmount {getBoundedShiftAmount :: Int} + deriving (Eq, Ord, Show) + +instance (FiniteBits a) => Arbitrary (BoundedShiftAmount a) where + arbitrary = do + x <- arbitrary + let widthBits = finiteBitSize (undefined :: a) + pure $ BoundedShiftAmount (abs x `mod` widthBits) + instance Arbitrary Natural where arbitrary = integralDownsize . (`mod` 10000) . abs <$> arbitraryInt64 @@ -395,6 +406,10 @@ class TestPrimop f where testPrimopDivLike :: String -> f -> f -> Test testPrimopDivLike _ _ _ = error "Div testing not supported for this type." + -- | Special test method for shift operations that bounds the shift amount + testPrimopShift :: String -> f -> f -> Test + testPrimopShift _ _ _ = error "Shift testing not supported for this type." + {- instance TestPrimop (Int# -> Int# -> Int#) where testPrimop s l r = Property s $ \(uInt -> a1) (uInt -> a2) -> (wInt (l a1 a2)) === wInt (r a1 a2) @@ -460,9 +475,9 @@ testPrimops = Group "primop" , testPrimopDivLike "quotInt8#" Primop.quotInt8# Wrapper.quotInt8# , testPrimopDivLike "remInt8#" Primop.remInt8# Wrapper.remInt8# , testPrimopDivLike "quotRemInt8#" Primop.quotRemInt8# Wrapper.quotRemInt8# - , testPrimop "uncheckedShiftLInt8#" Primop.uncheckedShiftLInt8# Wrapper.uncheckedShiftLInt8# - , testPrimop "uncheckedShiftRAInt8#" Primop.uncheckedShiftRAInt8# Wrapper.uncheckedShiftRAInt8# - , testPrimop "uncheckedShiftRLInt8#" Primop.uncheckedShiftRLInt8# Wrapper.uncheckedShiftRLInt8# + , testPrimopShift "uncheckedShiftLInt8#" Primop.uncheckedShiftLInt8# Wrapper.uncheckedShiftLInt8# + , testPrimopShift "uncheckedShiftRAInt8#" Primop.uncheckedShiftRAInt8# Wrapper.uncheckedShiftRAInt8# + , testPrimopShift "uncheckedShiftRLInt8#" Primop.uncheckedShiftRLInt8# Wrapper.uncheckedShiftRLInt8# , testPrimop "int8ToWord8#" Primop.int8ToWord8# Wrapper.int8ToWord8# , testPrimop "eqInt8#" Primop.eqInt8# Wrapper.eqInt8# , testPrimop "geInt8#" Primop.geInt8# Wrapper.geInt8# @@ -482,8 +497,8 @@ testPrimops = Group "primop" , testPrimop "orWord8#" Primop.orWord8# Wrapper.orWord8# , testPrimop "xorWord8#" Primop.xorWord8# Wrapper.xorWord8# , testPrimop "notWord8#" Primop.notWord8# Wrapper.notWord8# - , testPrimop "uncheckedShiftLWord8#" Primop.uncheckedShiftLWord8# Wrapper.uncheckedShiftLWord8# - , testPrimop "uncheckedShiftRLWord8#" Primop.uncheckedShiftRLWord8# Wrapper.uncheckedShiftRLWord8# + , testPrimopShift "uncheckedShiftLWord8#" Primop.uncheckedShiftLWord8# Wrapper.uncheckedShiftLWord8# + , testPrimopShift "uncheckedShiftRLWord8#" Primop.uncheckedShiftRLWord8# Wrapper.uncheckedShiftRLWord8# , testPrimop "word8ToInt8#" Primop.word8ToInt8# Wrapper.word8ToInt8# , testPrimop "eqWord8#" Primop.eqWord8# Wrapper.eqWord8# , testPrimop "geWord8#" Primop.geWord8# Wrapper.geWord8# @@ -500,9 +515,9 @@ testPrimops = Group "primop" , testPrimopDivLike "quotInt16#" Primop.quotInt16# Wrapper.quotInt16# , testPrimopDivLike "remInt16#" Primop.remInt16# Wrapper.remInt16# , testPrimopDivLike "quotRemInt16#" Primop.quotRemInt16# Wrapper.quotRemInt16# - , testPrimop "uncheckedShiftLInt16#" Primop.uncheckedShiftLInt16# Wrapper.uncheckedShiftLInt16# - , testPrimop "uncheckedShiftRAInt16#" Primop.uncheckedShiftRAInt16# Wrapper.uncheckedShiftRAInt16# - , testPrimop "uncheckedShiftRLInt16#" Primop.uncheckedShiftRLInt16# Wrapper.uncheckedShiftRLInt16# + , testPrimopShift "uncheckedShiftLInt16#" Primop.uncheckedShiftLInt16# Wrapper.uncheckedShiftLInt16# + , testPrimopShift "uncheckedShiftRAInt16#" Primop.uncheckedShiftRAInt16# Wrapper.uncheckedShiftRAInt16# + , testPrimopShift "uncheckedShiftRLInt16#" Primop.uncheckedShiftRLInt16# Wrapper.uncheckedShiftRLInt16# , testPrimop "int16ToWord16#" Primop.int16ToWord16# Wrapper.int16ToWord16# , testPrimop "eqInt16#" Primop.eqInt16# Wrapper.eqInt16# , testPrimop "geInt16#" Primop.geInt16# Wrapper.geInt16# @@ -522,8 +537,8 @@ testPrimops = Group "primop" , testPrimop "orWord16#" Primop.orWord16# Wrapper.orWord16# , testPrimop "xorWord16#" Primop.xorWord16# Wrapper.xorWord16# , testPrimop "notWord16#" Primop.notWord16# Wrapper.notWord16# - , testPrimop "uncheckedShiftLWord16#" Primop.uncheckedShiftLWord16# Wrapper.uncheckedShiftLWord16# - , testPrimop "uncheckedShiftRLWord16#" Primop.uncheckedShiftRLWord16# Wrapper.uncheckedShiftRLWord16# + , testPrimopShift "uncheckedShiftLWord16#" Primop.uncheckedShiftLWord16# Wrapper.uncheckedShiftLWord16# + , testPrimopShift "uncheckedShiftRLWord16#" Primop.uncheckedShiftRLWord16# Wrapper.uncheckedShiftRLWord16# , testPrimop "word16ToInt16#" Primop.word16ToInt16# Wrapper.word16ToInt16# , testPrimop "eqWord16#" Primop.eqWord16# Wrapper.eqWord16# , testPrimop "geWord16#" Primop.geWord16# Wrapper.geWord16# @@ -540,9 +555,9 @@ testPrimops = Group "primop" , testPrimopDivLike "quotInt32#" Primop.quotInt32# Wrapper.quotInt32# , testPrimopDivLike "remInt32#" Primop.remInt32# Wrapper.remInt32# , testPrimopDivLike "quotRemInt32#" Primop.quotRemInt32# Wrapper.quotRemInt32# - , testPrimop "uncheckedShiftLInt32#" Primop.uncheckedShiftLInt32# Wrapper.uncheckedShiftLInt32# - , testPrimop "uncheckedShiftRAInt32#" Primop.uncheckedShiftRAInt32# Wrapper.uncheckedShiftRAInt32# - , testPrimop "uncheckedShiftRLInt32#" Primop.uncheckedShiftRLInt32# Wrapper.uncheckedShiftRLInt32# + , testPrimopShift "uncheckedShiftLInt32#" Primop.uncheckedShiftLInt32# Wrapper.uncheckedShiftLInt32# + , testPrimopShift "uncheckedShiftRAInt32#" Primop.uncheckedShiftRAInt32# Wrapper.uncheckedShiftRAInt32# + , testPrimopShift "uncheckedShiftRLInt32#" Primop.uncheckedShiftRLInt32# Wrapper.uncheckedShiftRLInt32# , testPrimop "int32ToWord32#" Primop.int32ToWord32# Wrapper.int32ToWord32# , testPrimop "eqInt32#" Primop.eqInt32# Wrapper.eqInt32# , testPrimop "geInt32#" Primop.geInt32# Wrapper.geInt32# @@ -562,8 +577,8 @@ testPrimops = Group "primop" , testPrimop "orWord32#" Primop.orWord32# Wrapper.orWord32# , testPrimop "xorWord32#" Primop.xorWord32# Wrapper.xorWord32# , testPrimop "notWord32#" Primop.notWord32# Wrapper.notWord32# - , testPrimop "uncheckedShiftLWord32#" Primop.uncheckedShiftLWord32# Wrapper.uncheckedShiftLWord32# - , testPrimop "uncheckedShiftRLWord32#" Primop.uncheckedShiftRLWord32# Wrapper.uncheckedShiftRLWord32# + , testPrimopShift "uncheckedShiftLWord32#" Primop.uncheckedShiftLWord32# Wrapper.uncheckedShiftLWord32# + , testPrimopShift "uncheckedShiftRLWord32#" Primop.uncheckedShiftRLWord32# Wrapper.uncheckedShiftRLWord32# , testPrimop "word32ToInt32#" Primop.word32ToInt32# Wrapper.word32ToInt32# , testPrimop "eqWord32#" Primop.eqWord32# Wrapper.eqWord32# , testPrimop "geWord32#" Primop.geWord32# Wrapper.geWord32# @@ -579,9 +594,9 @@ testPrimops = Group "primop" , testPrimop "timesInt64#" Primop.timesInt64# Wrapper.timesInt64# , testPrimopDivLike "quotInt64#" Primop.quotInt64# Wrapper.quotInt64# , testPrimopDivLike "remInt64#" Primop.remInt64# Wrapper.remInt64# - , testPrimop "uncheckedIShiftL64#" Primop.uncheckedIShiftL64# Wrapper.uncheckedIShiftL64# - , testPrimop "uncheckedIShiftRA64#" Primop.uncheckedIShiftRA64# Wrapper.uncheckedIShiftRA64# - , testPrimop "uncheckedIShiftRL64#" Primop.uncheckedIShiftRL64# Wrapper.uncheckedIShiftRL64# + , testPrimopShift "uncheckedIShiftL64#" Primop.uncheckedIShiftL64# Wrapper.uncheckedIShiftL64# + , testPrimopShift "uncheckedIShiftRA64#" Primop.uncheckedIShiftRA64# Wrapper.uncheckedIShiftRA64# + , testPrimopShift "uncheckedIShiftRL64#" Primop.uncheckedIShiftRL64# Wrapper.uncheckedIShiftRL64# , testPrimop "int64ToWord64#" Primop.int64ToWord64# Wrapper.int64ToWord64# , testPrimop "eqInt64#" Primop.eqInt64# Wrapper.eqInt64# , testPrimop "geInt64#" Primop.geInt64# Wrapper.geInt64# @@ -600,8 +615,8 @@ testPrimops = Group "primop" , testPrimop "or64#" Primop.or64# Wrapper.or64# , testPrimop "xor64#" Primop.xor64# Wrapper.xor64# , testPrimop "not64#" Primop.not64# Wrapper.not64# - , testPrimop "uncheckedShiftL64#" Primop.uncheckedShiftL64# Wrapper.uncheckedShiftL64# - , testPrimop "uncheckedShiftRL64#" Primop.uncheckedShiftRL64# Wrapper.uncheckedShiftRL64# + , testPrimopShift "uncheckedShiftL64#" Primop.uncheckedShiftL64# Wrapper.uncheckedShiftL64# + , testPrimopShift "uncheckedShiftRL64#" Primop.uncheckedShiftRL64# Wrapper.uncheckedShiftRL64# , testPrimop "word64ToInt64#" Primop.word64ToInt64# Wrapper.word64ToInt64# , testPrimop "eqWord64#" Primop.eqWord64# Wrapper.eqWord64# , testPrimop "geWord64#" Primop.geWord64# Wrapper.geWord64# @@ -632,9 +647,9 @@ testPrimops = Group "primop" , testPrimop "<=#" (Primop.<=#) (Wrapper.<=#) , testPrimop "chr#" Primop.chr# Wrapper.chr# , testPrimop "int2Word#" Primop.int2Word# Wrapper.int2Word# - , testPrimop "uncheckedIShiftL#" Primop.uncheckedIShiftL# Wrapper.uncheckedIShiftL# - , testPrimop "uncheckedIShiftRA#" Primop.uncheckedIShiftRA# Wrapper.uncheckedIShiftRA# - , testPrimop "uncheckedIShiftRL#" Primop.uncheckedIShiftRL# Wrapper.uncheckedIShiftRL# + , testPrimopShift "uncheckedIShiftL#" Primop.uncheckedIShiftL# Wrapper.uncheckedIShiftL# + , testPrimopShift "uncheckedIShiftRA#" Primop.uncheckedIShiftRA# Wrapper.uncheckedIShiftRA# + , testPrimopShift "uncheckedIShiftRL#" Primop.uncheckedIShiftRL# Wrapper.uncheckedIShiftRL# , testPrimop "plusWord#" Primop.plusWord# Wrapper.plusWord# , testPrimop "addWordC#" Primop.addWordC# Wrapper.addWordC# , testPrimop "subWordC#" Primop.subWordC# Wrapper.subWordC# @@ -649,8 +664,8 @@ testPrimops = Group "primop" , testPrimop "or#" Primop.or# Wrapper.or# , testPrimop "xor#" Primop.xor# Wrapper.xor# , testPrimop "not#" Primop.not# Wrapper.not# - , testPrimop "uncheckedShiftL#" Primop.uncheckedShiftL# Wrapper.uncheckedShiftL# - , testPrimop "uncheckedShiftRL#" Primop.uncheckedShiftRL# Wrapper.uncheckedShiftRL# + , testPrimopShift "uncheckedShiftL#" Primop.uncheckedShiftL# Wrapper.uncheckedShiftL# + , testPrimopShift "uncheckedShiftRL#" Primop.uncheckedShiftRL# Wrapper.uncheckedShiftRL# , testPrimop "word2Int#" Primop.word2Int# Wrapper.word2Int# , testPrimop "gtWord#" Primop.gtWord# Wrapper.gtWord# , testPrimop "geWord#" Primop.geWord# Wrapper.geWord# @@ -709,6 +724,7 @@ instance TestPrimop (Char# -> Int#) where instance TestPrimop (Int# -> Int# -> Int#) where testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uInt#-> x0) (BoundedShiftAmount @Int shift) -> wInt# (l x0 (uInt# shift)) === wInt# (r x0 (uInt# shift)) instance TestPrimop (Int# -> Int# -> (# Int#,Int# #)) where testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1)) @@ -741,6 +757,7 @@ instance TestPrimop (Int# -> Word#) where instance TestPrimop (Int16# -> Int# -> Int16#) where testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt#-> x1) -> wInt16# (l x0 x1) === wInt16# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uInt16#-> x0) (BoundedShiftAmount @Int16 shift) -> wInt16# (l x0 (uInt# shift)) === wInt16# (r x0 (uInt# shift)) instance TestPrimop (Int16# -> Int16# -> Int#) where testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) @@ -765,6 +782,7 @@ instance TestPrimop (Int16# -> Word16#) where instance TestPrimop (Int32# -> Int# -> Int32#) where testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt#-> x1) -> wInt32# (l x0 x1) === wInt32# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uInt32#-> x0) (BoundedShiftAmount @Int32 shift) -> wInt32# (l x0 (uInt# shift)) === wInt32# (r x0 (uInt# shift)) instance TestPrimop (Int32# -> Int32# -> Int#) where testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) @@ -789,6 +807,7 @@ instance TestPrimop (Int32# -> Word32#) where instance TestPrimop (Int64# -> Int# -> Int64#) where testPrimop s l r = Property s $ \ (uInt64#-> x0) (uInt#-> x1) -> wInt64# (l x0 x1) === wInt64# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uInt64#-> x0) (BoundedShiftAmount @Int64 shift) -> wInt64# (l x0 (uInt# shift)) === wInt64# (r x0 (uInt# shift)) instance TestPrimop (Int64# -> Int64# -> Int#) where testPrimop s l r = Property s $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) @@ -809,6 +828,7 @@ instance TestPrimop (Int64# -> Word64#) where instance TestPrimop (Int8# -> Int# -> Int8#) where testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt#-> x1) -> wInt8# (l x0 x1) === wInt8# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uInt8#-> x0) (BoundedShiftAmount @Int8 shift) -> wInt8# (l x0 (uInt# shift)) === wInt8# (r x0 (uInt# shift)) instance TestPrimop (Int8# -> Int8# -> Int#) where testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) @@ -833,6 +853,7 @@ instance TestPrimop (Int8# -> Word8#) where instance TestPrimop (Word# -> Int# -> Word#) where testPrimop s l r = Property s $ \ (uWord#-> x0) (uInt#-> x1) -> wWord# (l x0 x1) === wWord# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uWord#-> x0) (BoundedShiftAmount @Word shift) -> wWord# (l x0 (uInt# shift)) === wWord# (r x0 (uInt# shift)) instance TestPrimop (Word# -> Word# -> Int#) where testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) @@ -870,6 +891,7 @@ instance TestPrimop (Word# -> Word8#) where instance TestPrimop (Word16# -> Int# -> Word16#) where testPrimop s l r = Property s $ \ (uWord16#-> x0) (uInt#-> x1) -> wWord16# (l x0 x1) === wWord16# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uWord16#-> x0) (BoundedShiftAmount @Word16 shift) -> wWord16# (l x0 (uInt# shift)) === wWord16# (r x0 (uInt# shift)) instance TestPrimop (Word16# -> Word16# -> Int#) where testPrimop s l r = Property s $ \ (uWord16#-> x0) (uWord16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) @@ -894,6 +916,7 @@ instance TestPrimop (Word16# -> Word16#) where instance TestPrimop (Word32# -> Int# -> Word32#) where testPrimop s l r = Property s $ \ (uWord32#-> x0) (uInt#-> x1) -> wWord32# (l x0 x1) === wWord32# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uWord32#-> x0) (BoundedShiftAmount @Word32 shift) -> wWord32# (l x0 (uInt# shift)) === wWord32# (r x0 (uInt# shift)) instance TestPrimop (Word32# -> Word32# -> Int#) where testPrimop s l r = Property s $ \ (uWord32#-> x0) (uWord32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) @@ -918,6 +941,7 @@ instance TestPrimop (Word32# -> Word32#) where instance TestPrimop (Word64# -> Int# -> Word64#) where testPrimop s l r = Property s $ \ (uWord64#-> x0) (uInt#-> x1) -> wWord64# (l x0 x1) === wWord64# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uWord64#-> x0) (BoundedShiftAmount @Word64 shift) -> wWord64# (l x0 (uInt# shift)) === wWord64# (r x0 (uInt# shift)) instance TestPrimop (Word64# -> Word64# -> Int#) where testPrimop s l r = Property s $ \ (uWord64#-> x0) (uWord64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) @@ -938,6 +962,7 @@ instance TestPrimop (Word64# -> Word64#) where instance TestPrimop (Word8# -> Int# -> Word8#) where testPrimop s l r = Property s $ \ (uWord8#-> x0) (uInt#-> x1) -> wWord8# (l x0 x1) === wWord8# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uWord8#-> x0) (BoundedShiftAmount @Word8 shift) -> wWord8# (l x0 (uInt# shift)) === wWord8# (r x0 (uInt# shift)) instance TestPrimop (Word8# -> Word8# -> Int#) where testPrimop s l r = Property s $ \ (uWord8#-> x0) (uWord8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) ===================================== utils/genprimopcode/Main.hs ===================================== @@ -705,12 +705,16 @@ gen_foundation_tests (Info _ entries) mkInstances inst_ty = let test_lambda = "\\ " ++ intercalate " " (zipWith mkArg [0::Int ..] (arg_tys)) ++ " -> " ++ mk_body "l" ++ " === " ++ mk_body "r" + shift_lambda = "\\ " ++ mkArg (0::Int) (head arg_tys) ++ " (BoundedShiftAmount @" ++ dropMagicHash (head arg_tys) ++ " shift) -> " ++ mk_shift_body "l" ++ " === " ++ mk_shift_body "r" in unlines $ [ "instance TestPrimop (" ++ pprTy inst_ty ++ ") where" , " testPrimop s l r = Property s $ " ++ test_lambda ] ++ (if mb_divable_tys then [" testPrimopDivLike s l r = Property s $ twoNonZero $ " ++ test_lambda] else []) + ++ (if mb_shiftable_tys + then [" testPrimopShift s l r = Property s $ " ++ shift_lambda] + else []) where arg_tys = args inst_ty -- eg Int -> Int -> a @@ -718,7 +722,14 @@ gen_foundation_tests (Info _ entries) [ty1,ty2] -> ty1 == ty2 && ty1 `elem` divableTyCons _ -> False + -- eg SomeType# -> Int# -> SomeType# + mb_shiftable_tys = case arg_tys of + [ty1,"Int#"] -> let res_type = getResultType inst_ty + in ty1 == res_type && ty1 `elem` shiftableTyCons + _ -> False + mk_body s = res_ty inst_ty (" (" ++ s ++ " " ++ intercalate " " vs ++ ")") + mk_shift_body s = res_ty inst_ty (" (" ++ s ++ " x0 (uInt# shift))") vs = zipWith (\n _ -> "x" ++ show n) [0::Int ..] (arg_tys) @@ -761,6 +772,8 @@ gen_foundation_tests (Info _ entries) , (testable (ty po)) = let testPrimOpHow = if is_divLikeOp po then "testPrimopDivLike" + else if is_shiftLikeOp po + then "testPrimopShift" else "testPrimop" qualOp qualification = let qName = wrap qualification poName @@ -784,6 +797,17 @@ gen_foundation_tests (Info _ entries) testableTyCon _ = False divableTyCons = ["Int#", "Word#", "Word8#", "Word16#", "Word32#", "Word64#" ,"Int8#", "Int16#", "Int32#", "Int64#"] + shiftableTyCons = ["Int#", "Word#", "Word8#", "Word16#", "Word32#", "Word64#" + ,"Int8#", "Int16#", "Int32#", "Int64#"] + + dropMagicHash :: String -> String + dropMagicHash = takeWhile (not . (== '#')) + + getResultType :: Ty -> String + getResultType (TyF _ t2) = getResultType t2 + getResultType (TyApp (TyCon c) []) = c + getResultType (TyUTup _) = "" -- Unboxed tuples can't be shift operations + getResultType t = error $ "getResultType: unexpected type " ++ pprTy t mb_defined_bits :: Entry -> Maybe Word mb_defined_bits op@(PrimOpSpec{}) = ===================================== utils/genprimopcode/Syntax.hs ===================================== @@ -54,17 +54,23 @@ is_primtype (PrimTypeSpec {}) = True is_primtype _ = False is_divLikeOp :: Entry -> Bool -is_divLikeOp entry = case entry of - PrimOpSpec{} -> has_div_like - PseudoOpSpec{} -> has_div_like - PrimVecOpSpec{} -> has_div_like - PrimTypeSpec{} -> False - PrimVecTypeSpec{} -> False - Section{} -> False - where - has_div_like = case lookup_attrib "div_like" (opts entry) of - Just (OptionTrue{}) -> True - _ -> False +is_divLikeOp = is_likeOp "div_like" + +is_shiftLikeOp :: Entry -> Bool +is_shiftLikeOp = is_likeOp "shift_like" + +is_likeOp :: String -> Entry -> Bool +is_likeOp attrName entry = case entry of + PrimOpSpec {} -> has_attr + PseudoOpSpec {} -> has_attr + PrimVecOpSpec {} -> has_attr + PrimTypeSpec {} -> False + PrimVecTypeSpec {} -> False + Section {} -> False + where + has_attr = case lookup_attrib attrName (opts entry) of + Just (OptionTrue {}) -> True + _ -> False -- a binding of property to value data Option View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/817899db55a16710506380ebd1dbd10… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/817899db55a16710506380ebd1dbd10… You're receiving this email because of your account on gitlab.haskell.org.

1 0