import System.IO import Control.Concurrent import Control.Concurrent.MVar import System.IO.Unsafe -- Beispiel zu 'unsafeInterleaveIO' readFile1 :: FilePath -> IO String readFile1 path = do handle <- openFile path ReadMode inhalt <- leseHandleAus' handle return inhalt readFile2 :: FilePath -> IO String readFile2 path = do handle <- openFile path ReadMode inhalt <- leseHandleAus handle return inhalt leseHandleAus' handle = do ende <- hIsEOF handle if ende then hClose handle >> return [] else do c <- hGetChar handle cs <- leseHandleAus' handle return (c:cs) leseHandleAus handle = do ende <- hIsEOF handle if ende then hClose handle >> return [] else do c <- hGetChar handle cs <- unsafeInterleaveIO (leseHandleAus handle) return (c:cs) -- Echo-Beispiel ohne Synchronisation echo i = do putStrLn $ "Eingabe fuer Thread" ++ show i ++ ":" line <- getLine putStrLn $ "Letzte Eingabe fuer Thread" ++ show i ++ ":" ++ line echo i zweiEchos = do -- hSetBuffering stdout NoBuffering forkIO (echo 1) forkIO (echo 2) block nEchos n = do sequence_ [forkIO (echo i) | i <- [1..n]] block -- Echo-Beispiel mit Schutz des kritischen Bereichs: atomar mvar aktionen = do putMVar mvar () -- MVar belegen result <- aktionen -- gesch"utzte Aktionen takeMVar mvar -- MVar entleeren return result echoS sem i = do result <- atomar sem ( do putStr $ "Eingabe fuer Thread" ++ show i ++ ":" line <- getLine return line ) atomar sem (putStrLn $ "Letzte Eingabe fuer Thread" ++ show i ++ ":" ++ result) echoS sem i zweiEchosS = do sem <- newEmptyMVar forkIO (echoS sem 1) forkIO (echoS sem 2) block nEchosS n = do sem <- newEmptyMVar sequence_ [forkIO (echoS sem i) | i <- [1..n]] block block = do block -- Kanal type Kanal a = (MVar (Strom a), MVar (Strom a)) type Strom a = MVar (SCons a) data SCons a = SCons a (Strom a) -- Ein Strom ist eine "Liste", wobei jeder Tail durch -- MVar's verkettet sind => Die Liste ist veränderlich -- Das "Nil" ist einfach eine leere MVar -- MVar (Cons 1 (MVar Cons 1) appendStroeme strom1 strom2 = do test <- isEmptyMVar strom2 if test then return strom1 else do kopf2 <- readMVar strom2 ende <- findeEnde strom1 putMVar ende kopf2 return strom1 findeEnde strom = do test <- isEmptyMVar strom if test then return strom else do SCons hd tl <- readMVar strom findeEnde tl listToStrom [] = newEmptyMVar listToStrom (x:xs) = do tl <- listToStrom xs v <- newMVar (SCons x tl) return v printStrom strom = do test <- isEmptyMVar strom if test then putStrLn "[]" else do SCons el tl <- readMVar strom putStr (show el ++ ":") printStrom tl neuerKanal :: IO (Kanal a) neuerKanal = do hole <- newEmptyMVar read <- newMVar hole write <- newMVar hole return $ (read, write) schreibe :: Kanal a -> a -> IO () schreibe (read,write) val = do new_hole <- newEmptyMVar old_hole <- takeMVar write putMVar write new_hole putMVar old_hole (SCons val new_hole) lese :: Kanal a -> IO a lese (read,write) = do kopf <- takeMVar read (SCons val stream) <- takeMVar kopf putMVar read stream return val strom123 = do ende <- newEmptyMVar drei <- newMVar (SCons 3 ende) zwei <- newMVar (SCons 2 drei) eins <- newMVar (SCons 1 drei) return eins -- Speisende Philosophen, mit Deadlock: philosoph i gabeln = do let n = length gabeln -- Anzahl Gabeln takeMVar $ gabeln!!i -- nehme linke Gabel putStr $ "Philosoph " ++ show i ++ " hat linke Gabel ...\n" takeMVar $ gabeln!!(mod (i+1) n) -- nehme rechte Gabel putStr $ "Philosoph " ++ show i ++ " isst ...\n" putMVar (gabeln!!i) () -- lege linke Gabel ab putMVar (gabeln!!(mod (i+1) n)) () -- lege rechte Gabel ab putStr $ "Philosoph " ++ show i ++ " denkt ...\n" philosoph i gabeln philosophen n = do hSetBuffering stdout LineBuffering -- erzeuge Gabeln (n MVars): gabeln <- sequence $ replicate n (newMVar ()) -- erzeuge Philosophen: ids <- sequence [forkIO (philosoph i gabeln) | i <- [0..n-1]] -- Moeglichkeit zum Beenden: quit sequence_ $ map killThread ids -- Deadlockfreie Version, aber nicht fair: philosophen' n = do hSetBuffering stdout LineBuffering sem <- newEmptyMVar gabeln <- sequence $ replicate n (newMVar ()) ids <- sequence [forkIO (philosoph' sem i gabeln) | i <- [0..n-1]] -- Moeglichkeit zum Beenden: quit sequence_ $ map killThread ids quit = do c <- getLine if c == "q" then return () else quit philosoph' sem i gabeln = do let n = length gabeln atomar sem (do takeMVar $ gabeln!!i putStr $ "Philosoph " ++ show i ++ " hat linke Gabel ...\n" takeMVar $ gabeln!!(mod (i+1) n) putStr $ "Philosoph " ++ show i ++ " isst ...\n" putMVar (gabeln!!i) () putMVar (gabeln!!(mod (i+1) n)) () ) putStr $ "Philosoph " ++ show i ++ " denkt ...\n" philosoph' sem i gabeln amb :: a -> a -> IO a amb s t = do ergebnisMVar <- newEmptyMVar id_s <- forkIO (let x = s in seq x (putMVar ergebnisMVar x)) id_t <- forkIO (let x = t in seq x (putMVar ergebnisMVar x)) ergebnis <- takeMVar ergebnisMVar killThread id_s killThread id_t return ergebnis por :: Bool -> Bool -> IO Bool por s t = do ergebnisMVar <- newEmptyMVar id_s <- forkIO (if s then (putMVar ergebnisMVar True) else (putMVar ergebnisMVar t)) id_t <- forkIO (if t then (putMVar ergebnisMVar True) else (putMVar ergebnisMVar s)) ergebnis <- takeMVar ergebnisMVar killThread id_s killThread id_t return ergebnis safePor :: Bool -> Bool -> Bool safePor s t = unsafePerformIO $ por s t por2 :: Bool -> Bool -> IO Bool por2 s t = amb (if s then True else t) (if t then True else s) choice :: a -> a -> IO a choice s t = do res <- (amb (\x -> s) (\x -> t)) return (res ()) ndMerge xs ys = do chan <- neuerKanal id_s <- forkIO (schreibeListeAufKanal chan xs) id_t <- forkIO (schreibeListeAufKanal chan ys) leseKanal chan False leseKanal chan flag = do (flag1,el) <- lese chan if flag1 && flag then return [] else do rest <- unsafeInterleaveIO (leseKanal chan (flag || flag1)) if flag1 then return (rest) else return (el:rest) schreibeListeAufKanal chan [] = schreibe chan (True,undefined) schreibeListeAufKanal chan (x:xs) = do schreibe chan (False,x) yield schreibeListeAufKanal chan xs unsafeInterleaveIO' :: IO a -> IO a unsafeInterleaveIO' f = return (unsafePerformIO f) -- ambList :: [a] -> IO a -- ambList [] = block where block = do -- yield -- block -- ambList (x:xs) = do -- xs' <- unsafeInterleaveIO (ambList xs) -- amb x xs' data Suchbaum a = Ziel a | Knoten a [Suchbaum a] ndBFsearch res (Ziel a) = return (reverse $ a:res) ndBFsearch res (Knoten a []) = do yield ndBFsearch res (Knoten a []) ndBFsearch res (Knoten a nf) = do nf' <- mapM (unsafeInterleaveIO . ndBFsearch (a:res)) nf ambList nf' suche = do result <- ndBFsearch [] labyrinth print result labyrinth = let kn51 = Knoten (5,1) [kn52] kn12 = Knoten (1,2) [kn13] kn22 = Knoten (2,2) [kn12] kn32 = Knoten (3,2) [kn22] kn42 = Knoten (4,2) [kn32] kn52 = Knoten (5,2) [kn42,kn53,kn62] kn62 = Knoten (6,2) [kn72] kn72 = Knoten (7,2) [kn82] kn82 = Knoten (8,2) [kn83] kn13 = Knoten (1,3) [kn14] kn53 = Knoten (5,3) [kn54] kn83 = Knoten (8,3) [kn84] kn14 = Knoten (1,4) [kn24] kn24 = Knoten (2,4) [kn25] kn54 = Knoten (5,4) [kn64] kn64 = Knoten (6,4) [kn65] kn84 = Knoten (8,4) [kn85] kn25 = Knoten (2,5) [kn26] kn65 = Knoten (6,5) [kn66] kn85 = Knoten (8,5) [kn86] kn16 = Knoten (1,6) [kn17] kn26 = Knoten (2,6) [kn16,kn36] kn36 = Knoten (3,6) [kn37] kn56 = Knoten (5,6) [kn66] kn66 = Knoten (6,6) [kn56] kn86 = Knoten (8,6) [kn87] kn17 = Knoten (1,7) [] kn37 = Knoten (3,7) [] kn77 = Knoten (7,7) [kn78] kn87 = Knoten (8,7) [kn77] kn78 = Ziel (7,8) in kn51 {- 12345678 1 x 2xxxxxxxx 3x x x 4xx xx x 5 x x x 6xxx xx x 7x x xx 8 x -} ambL [x] = return x ambL (x:xs) = do l <- ambL xs amb x l ambList [x] = return x ambList (x:xs) = do l <- unsafeInterleaveIO (ambList xs ) amb x l -- Tests main = zweiEchos main1 = do putStr (unlines [" Bitte Test auswaehlen:", " (1) 3 Philosophen mit Deadlock", " (2) 3 Philosophem ohne Deadlock (unfair)" ]) c <- getChar putStrLn "" case c of '1' -> mainPhilosophen '2' -> mainPhilosophen' other -> main mainPhilosophen = philosophen 3 mainPhilosophen' = philosophen' 3