From 1d27f7b9aac4058f28aa8e56cb112ad1018614d7 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 23 Dec 2015 20:45:54 +0100 Subject: FFP 09 --- ws2015/ffp/blaetter/09/FFP_U09_Concurrent.hs | 328 +++++++++++++++++++++++++++ 1 file changed, 328 insertions(+) create mode 100644 ws2015/ffp/blaetter/09/FFP_U09_Concurrent.hs diff --git a/ws2015/ffp/blaetter/09/FFP_U09_Concurrent.hs b/ws2015/ffp/blaetter/09/FFP_U09_Concurrent.hs new file mode 100644 index 0000000..99026c0 --- /dev/null +++ b/ws2015/ffp/blaetter/09/FFP_U09_Concurrent.hs @@ -0,0 +1,328 @@ +-- Fortgeschrittene Funktionale Programmierung, +-- LMU, TCS, Wintersemester 2015/16 + +-- Steffen Jost, Alexander Isenko +-- +-- Übungsblatt 09. 16.12.2015 +-- +-- Thema: Ausnahmen & Nebenläufigkeit +-- +-- Hinweis: +-- Für diese Übung ist ein Rechner mit mehreren Kernen +-- nützlich, aber nicht zwingend notwendig. +-- Wenn Sie möchten, dann Benutzen Sie einfach einen +-- Mehrkern-Rechner am CIP-Pool der Informatik. Hinweise +-- zum Remote-Login am CIP-Pool finden Sie am Anfang des +-- vorherigen Übungsblattes. +-- +-- +-- Anweisungen: +-- +-- Gehen Sie diese Datei durch und bearbeiten Sie +-- alle Vorkommen von undefined bzw. die mit -- !!! TODO !!! +-- markierten Stellen. Testen Sie Ihre Lösungen mit GHC! +-- + + +import Data.List +import Data.Typeable +import Control.Exception +import Control.Monad +import Control.Concurrent +import Control.DeepSeq + +import Data.Ord (comparing) + +import System.Environment (getArgs) + +-- Zum Umschalten zwischen den Aufgaben umkommentieren, +-- oder besser die Aufgaben in einzelne Dateien auftrennen. +main = main' [ ("1", main_A8_1) + , ("2", main_A8_2) + , ("3", main_A8_3) + ] + +main' :: [(String, IO ())] -> IO () +main' as = do + args <- getArgs + let + handler (x, a) + | x `elem` args = a + | otherwise = return () + mapM_ handler as + + +-- A8-1 Ausnahmen +-- +-- a) +-- Definieren Sie eine Funktion "myHead", +-- welche wie "head" aus der Standardbibliothek funktioniert, +-- aber stattdessen eine von Ihnen selbst-definierte +-- Ausnahme wirft. +-- + +data EmptyListException = EmptyListException + deriving (Show, Typeable) + +instance Exception EmptyListException + +myHead :: [a] -> a +myHead [] = throw EmptyListException +myHead (a:_) = a + +main_A8_1 :: IO () +main_A8_1 = do + putStrLn "Jetzt sollten drei Werte kommen, aber keine Exception:" + print $ myHead [1,2,undefined] -- Zeile nicht ändern! + h1 <- mySafeHead [3,4,undefined] -- Zeile nicht ändern! + print h1 + h2 <- mySafeHead empty + print h2 + putStrLn "Jetzt sollte gleich eine benutzerdefinierte Exception kommen:" + print $ myHead empty + where + empty = [] :: [Int] -- Typangabe für leere Liste, + -- damit Show-Instance festgelegt wird. + -- HINWEIS: + -- Das ist gar nicht albern, denn + -- "print ([] :: String)" soll ja etwas + -- anderes ausgeben als + -- "print ([] :: [Int])"! + + +-- b) +-- Implementieren Sie "mySafeHead" unter Verwendung +-- von "myHead", indem Sie die Ausnahme abfangen und behandeln. +-- +-- Hinweis: +-- Ausnahmen können nur innerhalb der IO-Monade gefangen werden. + + +mySafeHead :: [a] -> IO (Maybe a) +-- mySafeHead [] = return Nothing -- Gilt hier nicht als Lösung! Zu Übungszwecken bitte myHead mit catch/try einsetzen! +mySafeHead = handle (\EmptyListException -> return Nothing) . (fmap Just) . evaluate . myHead + + + + +-- A8-2 Paralleles Rechnen mit Nebenläufigkeit +-- +-- Auch wenn es eigentlich nicht der Sinn der Sache ist: +-- Nebenläufigkeit kann ebenfalls dazu verwendet werden, +-- die Ausführung eines Programmes durch Ausnutzung mehrerer +-- Prozessorkerne zu beschleunigen. +-- +-- Das folgende Programm führt vier unterschiedlich aufwändige +-- Berechnungen durch (Aufgabenstellung folgt weiter unten): + +main_A8_2 :: IO () +main_A8_2 = main' [ ("seq", main_A8_2_seq) + , ("a", main_A8_2_a) + , ("b", main_A8_2_b) + ] + +type Task = Integer -> [String] + +main_A8_2_seq :: IO () +main_A8_2_seq = do + putStrLn "Ein paar interessante Fakten:" + putStrLn " " + mapM_ putStrLn $ taskA nA + mapM_ putStrLn $ taskB nB + mapM_ putStrLn $ taskC nC + mapM_ putStrLn $ taskD nD + putStrLn " " + putStrLn "Höchst interessant, oder?" + + +-- Hilfsfunktionen, zur Erzeugung von Rechnenlast, +-- zur Lösung der Aufgabe sind diese unbedeutend. +-- +-- HINWEIS: +-- Die Werte sind zur Ausführung mit GHC -O2 auf aktueller Hardware gedacht +-- Bei Ausführung in GHCI sind die Werte anzupassen (halbieren?). +-- Idealerweise sollte jeder Task ca. 10 Sekunden Laufzeit benötigen. + +nA = 14 + +taskA :: Task +taskA n = ["* Ein Hanoi-Turm der Höhe " ++ (show n) + ," braucht genau " ++ (show steps) ++ " Schritte zum versetzen." ] + where + steps = length $ hanoi n 1 3 + +hanoi :: (Num a, Eq a) => a -> a -> a -> [(a,a)] +hanoi 1 i j = [(i,j)] +hanoi n i j = + hanoi n' i otherTower + ++ [(i,j)] + ++ hanoi n' otherTower j + where + n' = n-1 + otherTower = 1+2+3-i-j + +nB = 30 + +taskB :: Task +taskB n = ["* Die " ++ (show n) ++ ". Fibonacci-Zahl" + ," lautet: " ++ (show fn) ] + where + fn = fib n + +fib :: (Ord a, Num a, Num b) => a -> b +fib 0 = 0 -- absichtlich langsame Berechnung +fib n | n <= 1 = 1 + | otherwise = fib (n-1) + fib (n-2) + +nC = 11728 + +taskC :: Task +taskC n = ["* Die Fakultät von " ++ (show n) + ," ist eine Zahl mit " ++ (show l) ++ " Stellen." ] + where + fn = product [1..n] + l = length $ show fn + +nD = 279 + +taskD :: Task +taskD n = ["* Die Anzahl der Collatz-Schritte von " ++ (show n) ++ " bis 1 " + ," beträgt genau " ++ (show cn)] + where + cn = numCSteps n + + +collatzStep :: Integral a => a -> a +collatzStep n + | even n = n `div` 2 + | otherwise = 3*n+1 + +numCSteps :: Integral a => a -> a +numCSteps n = ncs 0 n + where -- Hinweis: Es ist unbekannt, ob es immer terminiert. + ncs steps 1 = steps + ncs steps m = ncs (succ steps) (collatzStep m) + + +-- a) +-- Verändern Sie das gegebene Hauptprogramm so, dass +-- die vier Ergebnisse so schnell wie möglich ausgegeben werden. +-- Das am schnellsten zu berechnende Ergebnis soll also zuerst ausgegeben werden, +-- das am langsamsten zu berechnende Ergebnis am Ende. +-- Die einzelnen Zeilen einer Aufgabe sollen auch zusammen ausgegeben werden! +-- +-- Hinweis: +-- Sie sehen zwar keine Beschleunigung, wenn Sie nur einen Prozessorkern +-- zur Verfügung haben, aber Sie sehen trotzdem, dass +-- die leichteste Aufgabe (taskD) als erste ausgegeben wird, +-- wenn Sie die Aufgabe richtig gelöst haben! + +main_A8_2_a :: IO () +main_A8_2_a = do + putStrLn "Ein paar interessante Fakten:" + putStrLn " " + runPar [ taskA nA + , taskB nB + , taskC nC + , taskD nD + ] + putStrLn " " + putStrLn "Höchst interessant, oder?" + where + runPar as = do + rChan <- newChan + mapM_ (forkIO . (writeChan rChan $!!)) as + replicateM_ (length as) (readChan rChan >>= mapM_ putStrLn) + + +-- b) +-- Verändern Sie das Hauptprogramm so, dass die Berechnungen +-- zwar parallel ausgeführt werden, aber das die gesamte Ausgabe +-- in einem Schritt nach Ende der langsamsten Berechnung erfolgt, +-- in der gleichen Reihenfolge des ursprünglichen Programmes. + +main_A8_2_b :: IO () +main_A8_2_b = do + putStrLn "Ein paar interessante Fakten:" + putStrLn " " + runPar [ taskA nA + , taskB nB + , taskC nC + , taskD nD + ] + putStrLn " " + putStrLn "Höchst interessant, oder?" + where + runPar as = do + rChan <- newChan + mapM_ (forkIO . (writeChan rChan $!!)) as' + rs <- replicateM (length as) (readChan rChan) + mapM_ putStrLn . join $ map snd $ sortBy (comparing fst) rs + where + as' = zip ([0..] :: [Integer]) as + + + +-- A8-3 Dead Locks und Race-Conditions +-- +-- Was passiert in folgendem Programm? +-- Wieso kommt es zu einem Dead-Lock? +-- Überlegen Sie sich Möglichkeiten, dies zu vermeiden! + +{- + Neither `md` nor `workerC` ever actually get used + + It suffices to show that a scheduling exists for which + a deadlock occurs. + + Consider: A.1, B.1, B'.1, A.2, B.2, B'.2 + + + To prevent deadlocks with only minimal changes to semantics + consider using one `MVar (Integer, Integer, Integer)`. + + However in the authors opinion considerable changes to the + semantics are preferable. +-} + +main_A8_3 :: IO () +main_A8_3 = do + ma <- newMVar 0 + mb <- newMVar 0 + mc <- newMVar 0 + md <- newMVar 0 + forkIO $ forever $ workerA ma mb -- thread A + forkIO $ forever $ workerB mb mc -- thread B + forkIO $ forever $ workerB mc ma -- thread B' + replicateM_ 1000 $ do + a <- readMVar ma + b <- readMVar mb + c <- readMVar mc + d <- readMVar md + print (a,b,c,d) + threadDelay 4000 + +workerA :: MVar Integer -> MVar Integer -> IO () +workerA mx my = do + x <- takeMVar mx -- A.1 + y <- takeMVar my -- A.2 + let x' = x+1 + let y' = y-1 + putMVar my $! y' + putMVar mx $! x' + +workerB :: MVar Integer -> MVar Integer -> IO () +workerB mx my = do + x <- takeMVar mx -- B.1 / B'.1 + y <- takeMVar my -- B.2 / B'.2 + putMVar mx $! collatzStep x + putMVar my $! collatzStep y + +workerC :: MVar Integer -> MVar Integer -> IO () +workerC mx my = do + x <- takeMVar mx + let x' = if x < 42 then fib x else 0 + putMVar mx $! x' + y <- takeMVar my + let y' = y + x' + putMVar my $! y' -- cgit v1.2.3