Experiments with an IO system written in Haskell.

ExplicitIO.hs

@@ -0,0 +1,267 @@
+{-# LANGUAGE GADTs, ExistentialQuantification, NoImplicitPrelude, Rank2Types #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+module ExplicitIO where
+
+import Prelude (Show(..), Monad(..), undefined, String, (++) )
+
+import qualified Data.IORef as Prelude
+import qualified Prelude
+import qualified System.IO.Unsafe as Prelude
+
+
+{-# NOINLINE threadList #-}
+threadList :: Prelude.IORef [AnyIOPrim]
+threadList = Prelude.unsafePerformIO (Prelude.newIORef [])
+
+
+
+pushThread :: IOPrim a -> Prelude.IO ()
+pushThread prim = Prelude.modifyIORef threadList (\lst -> AnyIOPrim prim : lst)
+
+popThread :: Prelude.IO AnyIOPrim
+popThread = do
+  threads <- Prelude.readIORef threadList
+  case threads of
+    [] -> Prelude.error "No more threads."
+    (x:xs) -> do
+      Prelude.writeIORef threadList xs
+      return x
+
+data Bool = True | False
+  deriving (Show)
+
+
+
+execIO :: IO a -> Prelude.IO a
+execIO io = runIOPrim (runIO io Unit)
+
+
+newtype IO a = IO { runIO :: forall r. (a -> IOPrim r) -> IOPrim r }
+
+instance Monad IO where
+  return a = IO (\cont -> cont a)
+  (>>=) f g = IO (\cont -> runIO f (\a -> runIO (g a) cont))
+
+
+terminate :: Bool -> IO ()
+terminate False = return ()
+terminate True  = IO (\_ -> Terminate)
+
+data AnyIOPrim = forall r. AnyIOPrim (IOPrim r)
+
+data IOPrim a where
+  Unit       :: a -> IOPrim a
+  Terminate  :: IOPrim a
+  NewIORef   :: a -> IOPrim (IORef a)
+  ReadIORef  :: IORef a -> IOPrim a
+  WriteIORef :: IORef a -> a -> IOPrim ()
+  Bind       :: IOPrim a -> (a -> IOPrim b) -> IOPrim b
+  --CFFI :: String -> [PrimType] -> IO PrimType
+  -- BlockingFFI
+  -- NonBlockingFFI
+
+  -- Basic I/O
+  PutStrLn   :: String -> IOPrim ()
+
+--  -- libuv
+  ASyncSpawn :: forall a. IOPrim a -> IOPrim ()
+  Yield      :: IOPrim a
+
+  -- Exception handling
+  ThrowIO :: SomeException -> IOPrim a
+  --ThrowTo :: ThreadId -> SomeException -> IOPrim a
+  Catch :: (SomeException -> IOPrim a) -> IOPrim a -> IOPrim a
+
+runIOPrim :: IOPrim a -> Prelude.IO a
+runIOPrim prim =
+  case prim of
+    Unit a           -> return a
+    Terminate        -> Prelude.error "Terminate"
+    NewIORef a       -> Prelude.newIORef a
+    ReadIORef ref    -> Prelude.readIORef ref
+    WriteIORef ref a -> Prelude.writeIORef ref a
+    Bind f g         -> do
+      a <- runIOPrim f
+      runIOPrim (g a)
+
+    PutStrLn str -> Prelude.putStrLn str
+
+    ASyncSpawn prim -> do
+      Prelude.putStrLn "Spawn"
+      pushThread prim
+    Yield -> do
+      thread <- popThread
+      Prelude.putStrLn "Yield"
+      case thread of
+        AnyIOPrim prim -> runIOPrim prim >> runIOPrim Yield
+
+
+
+
+putStrLn :: String -> IO ()
+putStrLn str = IO (\cont -> PutStrLn str `Bind` cont)
+
+-- Assume IORefs
+type IORef a = Prelude.IORef a
+
+newIORef :: a -> IO (IORef a)
+newIORef a = IO (\cont -> NewIORef a `Bind` cont)
+
+readIORef :: IORef a -> IO a
+readIORef ref = IO (\cont -> ReadIORef ref `Bind` cont)
+
+writeIORef :: IORef a -> a -> IO ()
+writeIORef ref a = IO (\cont -> WriteIORef ref a `Bind` (\_ -> cont ()))
+
+
+data MVar a = MVar (IORef (MVarContent a))
+data MVarContent a =
+  MVarReaders [a -> AnyIOPrim] |
+  MVarWriters a [(a,AnyIOPrim)]
+
+newEmptyMVar :: IO (MVar a)
+newEmptyMVar = IO (\cont ->
+  NewIORef (MVarReaders []) `Bind` \ref ->
+  cont (MVar ref)
+  )
+
+takeMVar :: MVar a -> IO a
+takeMVar (MVar ref) = IO (\cont ->
+  ReadIORef ref `Bind` \content ->
+  case content of
+    MVarReaders lst ->
+      let lst' = (\a -> AnyIOPrim (cont a)) : lst in
+      WriteIORef ref (MVarReaders lst') `Bind` \_ ->
+      Yield
+    MVarWriters a [] ->
+      WriteIORef ref (MVarReaders []) `Bind` \_ ->
+      cont a
+    MVarWriters a ((a',x):xs) ->
+      WriteIORef ref (MVarWriters a' xs) `Bind` \_ ->
+      cont a
+  )
+
+putMVar :: MVar a -> a -> IO ()
+putMVar (MVar ref) a = IO (\cont ->
+  ReadIORef ref `Bind` \content ->
+  case content of
+    MVarReaders [] ->
+      WriteIORef ref (MVarWriters a []) `Bind` \_ ->
+      cont ()
+    MVarReaders (x:xs) ->
+      WriteIORef ref (MVarReaders xs) `Bind` \_ ->
+      case x a of
+        AnyIOPrim t ->
+          ASyncSpawn t `Bind` cont
+    MVarWriters orig lst ->
+      WriteIORef ref (MVarWriters orig ((a, AnyIOPrim (cont ())) : lst)) `Bind` \_ ->
+      Yield
+  )
+
+
+spawn :: IO () -> IO ()
+spawn io = IO (\cont -> ASyncSpawn ((runIO io Unit)) `Bind` cont)
+
+
+
+
+testProgram :: IO ()
+testProgram = do
+  ref <- newEmptyMVar
+  spawn (putMVar ref True)
+  val <- takeMVar ref
+  putStrLn ("Boolean: " ++ show val)
+
+
+testYield :: IO Bool
+testYield = IO (\cont -> Yield)
+
+testReturn :: IO Bool
+testReturn = return True
+
+
+{-
+
+fn = do
+  v <- store ...
+  a <- fnA v
+  b <- fnB v
+  return a+b
+
+fn = \cont ->
+  store ... (\v ->
+    fnA v (\a ->
+      fnB v (\b ->
+        cont (a+b)
+      )
+    )
+  )
+
+fn = \cont ->
+  store_fn ... cont
+
+store_fn ... cont =
+  if no heap
+    mark_root cont
+    do_gc
+
+  let v = ...
+  fn_fnA v cont
+
+fn_fnA v cont =
+  let a = ...
+  fn_fnB v a cont
+
+fn_fnB v a cont =
+  let b = ...
+  cont (a+b)
+
+gc_alloc :: (Ptr -> IO a) -> Int -> IO a
+
+
+
+foreign import "prim cont" unsafePerformIO :: IO a -> a
+
+mkContinuation :: ((a -> IOPrim r) -> IOPrim r) -> a
+
+unsafePerformIO :: IO a -> a
+unsafePerformIO io = mkContinuation $ \cont ->
+  runIO io cont
+
+
+
+-}
+
+
+unsafeCoerce :: a -> b
+unsafeCoerce = undefined
+
+data Any
+
+data SomeException = forall x. Show x => SomeException x
+
+
+throw :: SomeException -> a
+throw = undefined
+
+-- Primitive.
+--foreign import ccall mkContinuation :: ((a -> IOPrim r) -> IOPrim r) -> a
+mkContinuation :: ((a -> IOPrim r) -> IOPrim r) -> a
+mkContinuation = undefined
+
+
+unsafePerformIO :: IO a -> a
+unsafePerformIO io = mkContinuation (\cont -> runIO io cont)
+
+{-
+ioFromPure cont = runIO getLine cont
+-}
+data Addr = Addr
+gc_alloc :: (Addr -> IOPrim a) -> IOPrim a
+gc_alloc cont = undefined
+
+
+
+
+
+