On Thu, Jul 29, 1999 at 12:19:10 +0200, George Russell wrote:
> I would like to add my strong support, as the person in charge of
> transferring the UniForM workbench, for the implementation of wait
> functions on input and output handles and input on Posix.FD which don't
> block everything else to be done urgently.
Wanna have a workaround for this? :-)
Today, I was playing around with green-card, and now I do have an (almost)
non-blocking hGetline...
Consider this piece of code, which was suggested by Peter Amstutz, who
started this thread:
\begin{code}
main = do
hSetBuffering stdin NoBuffering
forkIO (loop 'a')
booga
where
loop ch = hPutChar stdout ch >> loop ch
booga = do out <- almostPreemptiveGetLine 100 stdin
hPutStrLn stdout out
booga
\end{code}
After starting this program, you get blasted by 'a' chars, and if you type
in a line (still getting your terminal full of a's), it is printed in the
middle of these a's, just as one would expect...
Do I get a cookie now? :-)
How was this achieved?
Basically, I made a Haskell wrapper for select(2), so if one needs another
preemptive Input/Output function, it is possible to (non-blockingly) test,
whether there is I/O ready...
This is not really a solution, but I bet, it'll work in quite some
situations until Concurrent Haskell is *really* preemptive. ;-)
BTW: This should work with sockets, too, I didn't test, but I did a directly
coded (i.e. without green-card), similar function for sockets some weeks
ago, which worked...
Source code (~5K) follows in attachment...
Cheers,
Michael
--
W*ndoze NT is faster... CRASHING!
{-
- HSelect.gc - a Haskell interface for select(2)
- Copyright (C) 1999 Michael Weber <[EMAIL PROTECTED]>
- Version 0.1
-
- This library is free software; you can redistribute it and/or
- modify it under the terms of the GNU Library General Public
- License as published by the Free Software Foundation; either
- version 2 of the License, or (at your option) any later version.
-
- This library is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- Library General Public License for more details.
-
- You should have received a copy of the GNU Library General Public
- License along with this library; if not, write to the Free
- Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-}
module HSelect
( FdStatus(..) -- :: Error | Timeout | IOAvail
, FdList -- :: [Int]
, testHandles -- :: [Handle] -> [Handle] -> [Handle] -> Int -> Int -> IO FdStatus
, testFds -- :: FdList -> FdList -> FdList -> Int -> Int -> IO FdStatus
)
where
import StdDIS
import Monad (zipWithM_)
import IO(Handle)
import PrelHandle (getHandleFd)
%#include "hSelect.h"
-- The Good... ----------------------------------------------------------------
type FdList = [Int]
%enum FdStatus (Eq,Show) Int
% [ Error = {-1}
% , Timeout = {0}
% , IOAvail = {1}
% ]
testHandles :: [Handle] -> [Handle] -> [Handle] -> Int -> Int -> IO FdStatus
testHandles inh outh exh tsec tmsec = do
inFd <- mapM getHandleFd inh
outFd <- mapM getHandleFd outh
exFd <- mapM getHandleFd exh
testFds inFd outFd exFd tsec tmsec
%fun testFds :: FdList -> FdList -> FdList -> Int -> Int -> IO FdStatus
-- ...the Bad... --------------------------------------------------------------
%dis fdList x = fdList_ (addr ({int *} x))
-- stolen and adjusted from Green-Cards lib/ghc/StdDIS.gc
marshall_fdList_ :: FdList -> IO Addr
marshall_fdList_ cs =
do arr <- allocIntStar (1 + length cs)
zipWithM_ (writeIntAddr arr) [0..] (cs ++ [-1])
return arr
unmarshall_fdList_ :: Addr -> IO FdList
unmarshall_fdList_ ptr = reads [] 0
where
reads str i =
readIntAddr ptr i >>= \c ->
if c == -1 then
return (reverse str)
else
reads (c:str) (i+1)
%fun allocIntStar :: Int -> IO Addr
%{ res1 = (int *)calloc(sizeof(int),arg1); %}
%result (addr ({int*} res1))
%fun writeIntAddr :: Addr -> Int -> Int -> IO ()
%call (addr ({int*} s)) (int i) (int v)
%{ s[i] = v; %}
%fun readIntAddr :: Addr -> Int -> IO Int
%call (addr ({int *} s)) (int i)
%{ res1 = s[i]; %}
-- ...and the Ugly! :-) -------------------------------------------------------
%C
% #include <stdio.h>
% #include <unistd.h>
% #include <sys/types.h>
% #include <sys/time.h>
%
% int
% testFds (int *arg1, int *arg2, int *arg3, int arg4, int arg5)
% {
% fd_set set_in;
% fd_set set_out;
% fd_set set_ex;
% struct timeval timeout;
%
% FD_ZERO (&set_in);
% FD_ZERO (&set_out);
% FD_ZERO (&set_ex);
% while ((*arg1) >= 0) {
% FD_SET (*arg1, &set_in);
% arg1++;
% }
% while ((*arg2) >= 0) {
% printf ("<<testFds out: %d >>\n", *arg2);
% FD_SET (*arg2, &set_out);
% arg2++;
% }
% while ((*arg3) >= 0) {
% printf ("<<testFds ex: %d >>\n", *arg3);
% FD_SET (*arg3, &set_ex);
% arg3++;
% }
% timeout.tv_sec = arg4;
% timeout.tv_usec = arg5;
% /* TEMP_FAILURE_RETRY(select(...)) on Linux? */
% return select (FD_SETSIZE, &set_in, &set_out, &set_ex, &timeout);
% }
#ifndef HSELECT_H
#define HSELECT_H
/*
* hSelect.h - part of HSelect, a Haskell interface for select(2)
* Copyright (C) 1999 Michael Weber <[EMAIL PROTECTED]>
*/
int testFds (int *, int *, int *, int, int);
#endif /* HSELECT_H */
TOP = ..
include $(TOP)/mk/boilerplate.mk
HS_PROG = hsel_test
HS_SRCS = HSelect.hs StdDIS.hs test.hs
C_SRCS = HSelect_stub.c
HS_OBJS += $(C_OBJS)
CLEAN_FILES += HSelect_stub.c HSelect.hs StdDIS.hs
SRC_HC_OPTS += -recomp -cpp -fglasgow-exts -fvia-C -syslib concurrent
SRC_GREENCARD_OPTS += --haskell98 --target ghc
include $(TOP)/mk/target.mk
{-
- test.hs - Test for HSelect module
-}
module Main where
import Concurrent
import HSelect
import IO
-- timeout says, how "preemptive" aPGetLine is...
almostPreemptiveGetLine :: Int -> Handle -> IO String
almostPreemptiveGetLine timeout handle = loop ""
where
loop str = do
tst <- testHandles [handle] [] [] 0 timeout {- msec -}
if tst == IOAvail then getL str
else loop str
getL s = do
c <- hGetChar handle
if c == '\n' then return (reverse s)
else loop (c:s)
main = do
hSetBuffering stdin NoBuffering
forkIO (loop 'a')
booga
where
loop ch = hPutChar stdout ch >> loop ch
booga = do out <- almostPreemptiveGetLine 100 stdin
hPutStrLn stdout out
booga
