Skip to content

Update Eff to make it work with GHC 9.6 #17

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
s-and-witch wants to merge 1 commit into
base: master
Choose a base branch
from
Open

Update Eff to make it work with GHC 9.6 #17

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
16 changes: 0 additions & 16 deletions cabal.project
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,22 +1,6 @@
packages: eff
jobs: $ncpus

repository head.hackage.ghc.haskell.org
url: https://ghc.gitlab.haskell.org/head.hackage/
secure: True
key-threshold: 3
root-keys:
f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89
26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329
7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d

allow-newer:
primitive-0.7.0.1:base
splitmix-0.0.5:base

constraints:
primitive ==0.7.0.1,
QuickCheck ==2.13.2 || ==2.14

package *
optimization: 2
Expand Down
15 changes: 11 additions & 4 deletions eff/src/Control/Effect/Internal.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -23,9 +23,9 @@ import Data.IORef
import Data.Kind (Constraint, Type)
import Data.Type.Coercion (Coercion(..), gcoerceWith)
import Data.Type.Equality ((:~:)(..), gcastWith)
import GHC.Exts (Any, Int(..), Int#, RealWorld, RuntimeRep(..), SmallArray#, State#, TYPE, prompt#, control0#)
import GHC.Exts (Any, Int(..), Int#, RealWorld, RuntimeRep(..), SmallArray#, State#, TYPE, prompt#, control0#, PromptTag#, newPromptTag#)
import GHC.Types (IO(..))
import System.IO.Unsafe (unsafeDupablePerformIO)
import System.IO.Unsafe (unsafeDupablePerformIO, unsafePerformIO)
import Unsafe.Coerce (unsafeCoerce)

import Control.Effect.Internal.Debug
Expand Down Expand Up @@ -268,6 +268,13 @@ captureVM a = gcoerceWith (Coercion.sym $ anyCo @a) $
IO.throwIO $! UnwindControl (coerce a)
{-# INLINE captureVM #-}

data PromptTag a = MkPromptTag {unPromptTag :: PromptTag# a}

globalPromptTag :: PromptTag a
globalPromptTag = unsafePerformIO $ IO \s1 -> case newPromptTag# s1 of
(# s2, pt #) -> (#s2, MkPromptTag pt #)
{-# NOINLINE globalPromptTag #-}

-- | Runs an 'EVM' action with a new prompt installed. The arguments specify
-- what happens when control exits the action.
promptVM
Expand All @@ -283,7 +290,7 @@ promptVM
promptVM m onReturn onAbort onControl = IO.handle handleUnwind do
-- TODO: Explain why it is crucial that the exception handler is installed
-- outside of the frame where we replace the registers!
Result _ a <- IO (prompt# (unIO (packIOResult m)))
Result _ a <- IO (prompt# (unPromptTag globalPromptTag) (unIO (packIOResult m)))
onReturn a
where
handleUnwind (UnwindAbort pid a) = onAbort pid a
Expand All @@ -307,7 +314,7 @@ promptVM_ m rs onCapture = promptVM m onReturn rethrowAbort onCapture where
{-# INLINE promptVM_ #-}

controlVM :: ((a -> EVM b) -> IO (Registers, b)) -> IO (Registers, a)
controlVM f = IO (control0# f#) <&> \(Result rs a) -> (BoxRegisters rs, a) where
controlVM f = IO (control0# (unPromptTag globalPromptTag) f#) <&> \(Result rs a) -> (BoxRegisters rs, a) where
f# k# = unIO (f k <&> \(BoxRegisters rs, a) -> Result rs a) where
k a = EVM# \rs -> IO $ k# \s -> (# s, Result rs a #)
{-# INLINE controlVM #-}
Expand Down