diff options
Diffstat (limited to 'ghc/misc')
67 files changed, 2668 insertions, 0 deletions
diff --git a/ghc/misc/examples/cats/ccat4.c b/ghc/misc/examples/cats/ccat4.c new file mode 100644 index 0000000000..a02a7101b0 --- /dev/null +++ b/ghc/misc/examples/cats/ccat4.c @@ -0,0 +1,18 @@ +#include <stdio.h> + +main () +{ + char c[4096]; + int n; + + while ((n=fread(c,1,4096,stdin)) > 0) { + fwrite(c,1,n,stdout); + } + exit(0); +} + +/* +-- 8,937,757 bytes/sec ( 600KB input) +-- 12,146,094 bytes/sec ( 9.3MB input) +-- 8,658,233 bytes/sec (25.5MB input) +*/ diff --git a/ghc/misc/examples/cats/ccat5.c b/ghc/misc/examples/cats/ccat5.c new file mode 100644 index 0000000000..6c9e38da50 --- /dev/null +++ b/ghc/misc/examples/cats/ccat5.c @@ -0,0 +1,16 @@ +#include <stdio.h> + +main () +{ + int c; + while ((c = getchar()) != EOF) { + putchar(c); + } + exit(0); +} + +/* +-- 2,085,477 bytes/sec ( 600KB input) +-- 2,320,718 bytes/sec ( 9.3MB input) +-- 2,130,143 bytes/sec (25.5MB input) +*/ diff --git a/ghc/misc/examples/cats/hcat1.hs b/ghc/misc/examples/cats/hcat1.hs new file mode 100644 index 0000000000..9a29bf7b46 --- /dev/null +++ b/ghc/misc/examples/cats/hcat1.hs @@ -0,0 +1,4 @@ +main :: IO () +main = interact id + +-- 46,173 bytes/sec (600KB input) diff --git a/ghc/misc/examples/cats/hcat2.hs b/ghc/misc/examples/cats/hcat2.hs new file mode 100644 index 0000000000..3323ae8301 --- /dev/null +++ b/ghc/misc/examples/cats/hcat2.hs @@ -0,0 +1,10 @@ +module Main (main) where + +main :: IO () +main + = try getChar >>= + {-then-}either (\ _ -> return ()) + {-or-} (\ c -> putChar c >> + main) + +-- 51,156 bytes/sec (600KB input) diff --git a/ghc/misc/examples/cats/hcat3.hs b/ghc/misc/examples/cats/hcat3.hs new file mode 100644 index 0000000000..82208b9af7 --- /dev/null +++ b/ghc/misc/examples/cats/hcat3.hs @@ -0,0 +1,17 @@ +module Main (main) where + +import LibPosix + +main :: IO () +main = copy standardInput standardOutput + where + copy inn out + = try (readFileDescriptor inn 4096) >>= + either + (\ _ -> return ()) + (\ s -> writeFileDescriptor out s >> + copy inn out) + +-- 124,879 bytes/sec ( 600KB input) +-- 130,694 bytes/sec ( 9.3MB input) +-- 127,263 bytes/sec (25.5MB input) diff --git a/ghc/misc/examples/cats/hcat4.hs b/ghc/misc/examples/cats/hcat4.hs new file mode 100644 index 0000000000..d4e6ce3611 --- /dev/null +++ b/ghc/misc/examples/cats/hcat4.hs @@ -0,0 +1,20 @@ +module Main (mainPrimIO) where + +import PreludePrimIO + +mainPrimIO :: PrimIO () +mainPrimIO + = copy (``stdin'' :: _FILE) + (``stdout'' :: _FILE) + where + copy inn out + = fread 1 4096 inn + `thenPrimIO` \ (n, s) -> + if n <= 0 + then returnPrimIO () + else fwrite s 1 n out `seqPrimIO` + copy inn out + +-- 4,170,953 bytes/sec ( 600KB input) +-- 7,993,583 bytes/sec ( 9.3MB input) +-- 6,917,175 bytes/sec (25.5MB input) diff --git a/ghc/misc/examples/cats/hcat5.hs b/ghc/misc/examples/cats/hcat5.hs new file mode 100644 index 0000000000..0a7a59f6b6 --- /dev/null +++ b/ghc/misc/examples/cats/hcat5.hs @@ -0,0 +1,19 @@ +module Main (mainPrimIO) where + +import PreludePrimIO + +mainPrimIO :: PrimIO () +mainPrimIO + = _ccall_ stg_getc (``stdin'' :: _Addr) + `thenPrimIO` \ (I# ch) -> + if ch <# 0# then -- SIGH: ch ==# ``EOF'' + returnPrimIO () + else + _ccall_ stg_putc (C# (chr# ch)) + (``stdout'' :: _Addr) + `seqPrimIO` + mainPrimIO + +-- 1,737,897 bytes/sec ( 600KB input) +-- 1,808,993 bytes/sec ( 9.3MB input) +-- 1,711,850 bytes/sec (25.5MB input) diff --git a/ghc/misc/examples/cats/hcat6.hs b/ghc/misc/examples/cats/hcat6.hs new file mode 100644 index 0000000000..ce9b4e68d8 --- /dev/null +++ b/ghc/misc/examples/cats/hcat6.hs @@ -0,0 +1,18 @@ +module Main (mainPrimIO) where + +import PreludePrimIO + +mainPrimIO :: PrimIO () +mainPrimIO + = _casm_ + ``do { int c; + while ((c = getchar()) != EOF) { + putchar(c); + }} while (0); + %r = 1;'' -- pretend we have a "result" + `thenPrimIO` \ (I# _) -> + returnPrimIO () + +-- 1,955,134 bytes/sec ( 600KB input) +-- 1,989,892 bytes/sec ( 9.3MB input) +-- 1,871,706 bytes/sec (25.5MB input) diff --git a/ghc/misc/examples/cats/mangle_times b/ghc/misc/examples/cats/mangle_times new file mode 100644 index 0000000000..b595a5b467 --- /dev/null +++ b/ghc/misc/examples/cats/mangle_times @@ -0,0 +1,23 @@ +#! /usr/local/bin/perl + +$InputSize = 0; + +while (<>) { + chop; + + if ( m,< /users/fp/partain/bib/comp.bib, ) { + $InputSize = 625643; + print "$_\n"; + } elsif ( m,\$bghc/lib/libHS_p.a, ) { + $InputSize = 9352492; + print "$_\n"; + } elsif ( m,\$bghca/lib/libHS_p.a, ) { + $InputSize = 25455204; + print "$_\n"; + + } elsif ( /^\s*(\d+\.\d+)u (\d+\.\d+)s / ) { + $UserSysTime = $1 + $2; + $BytesPerSec = $InputSize / $UserSysTime; + printf "%.0f\t%s\n", $BytesPerSec, $_; + } +} diff --git a/ghc/misc/examples/hsh/Hsh.hs b/ghc/misc/examples/hsh/Hsh.hs new file mode 100644 index 0000000000..ffe2f167ed --- /dev/null +++ b/ghc/misc/examples/hsh/Hsh.hs @@ -0,0 +1,284 @@ +module Main (main) +where + +import LibPosix +import LibSystem + + +main = + initialize >> + commandLoop + +{- + Standard shell practice: move std descriptors out of the way so + it's more convenient to set them up for children. Also set up an + interrupt handler which will put us back in the main loop. +-} + +initialize :: IO () +initialize = + dupChannelTo stdInput myStdin >> + dupChannelTo stdOutput myStdout >> + dupChannelTo stdError myStderr >> + closeChannel stdInput >> + closeChannel stdOutput >> +-- closeChannel stdError >> + installHandler sigINT (Catch intr) Nothing >> + return () + +myStdin = 16 :: Channel +myStdout = 17 :: Channel +myStderr = 18 :: Channel + +-- For user interrupts + +intr :: IO () +intr = + writeChannel myStdout "\n" >> + commandLoop + +{- + Simple command loop: print a prompt, read a command, process the command. + Repeat as necessary. +-} + +commandLoop :: IO () +commandLoop = + writeChannel myStdout "$ " >> + try (readCommand myStdin) >>= + either + (\ err -> case err of + EOF -> return () + _ -> dieHorribly) + (\ cmd -> + try (processCommand cmd) >>= + either + (\ err -> commandLoop) + (\ succ -> commandLoop)) + where + dieHorribly :: IO () + dieHorribly = + errMsg "read failed" >> + exitWith (ExitFailure 1) + +{- + Read a command a character at a time (to allow for fancy processing later). + On newline, you're done, unless the newline was escaped by a backslash. +-} + +readCommand :: Channel -> IO String +readCommand chan = + accumString "" >>= \ cmd -> + return cmd + where + accumString :: String -> IO String + accumString s = + myGetChar chan >>= \ c -> + case c of + '\\' -> + myGetChar chan >>= \ c' -> + accumString (c':c:s) + '\n' -> return (reverse s) + ch -> accumString (ch:s) + +myGetChar :: Channel -> IO Char +myGetChar chan = + readChannel chan 1 >>= \ (s, len) -> + case len of + 0 -> myGetChar chan + 1 -> return (head s) + +{- + To process a command, first parse it into words, then do the necessary + redirections, and finally perform the desired command. Built-ins are + checked first, and if none match, we execute an external command. +-} + +processCommand :: String -> IO () +processCommand "" = return () +processCommand s = + parseCommand s >>= \ words -> + parseRedirection words >>= \ (inFile, outFile, words) -> + performRedirections inFile outFile >> + let + cmd = head words + args = tail words + in + case builtin cmd of + Just f -> + f args >> + closeChannel stdInput >> + closeChannel stdOutput + Nothing -> + exec cmd args + +{- + Redirections are a bit of a pain, really. If none are specified, we + dupChannel our own file descriptors. Otherwise, we try to open the files + as requested. +-} + +performRedirections :: Maybe String -> Maybe String -> IO () +performRedirections inFile outFile = + (case inFile of + Nothing -> + dupChannelTo myStdin stdInput + Just x -> + try (openChannel x ReadOnly Nothing False False False False False) + >>= + either + (\ err -> + errMsg ("Can't redirect input from " ++ x) + >> + failWith (UserError "redirect")) + (\ succ -> return ())) >> + (case outFile of + Nothing -> + dupChannelTo myStdout stdOutput + Just x -> + try (createFile x stdFileMode) + >>= + either + (\ err -> + errMsg ("Can't redirect output to " ++ x) + >> + closeChannel stdInput >> + failWith (UserError "redirect")) + (\ succ -> return ())) + +{- + We parse a command line into words according to the following rules: + 1) Anything inside pairs of "" or '' is parsed literally. + 2) Anything (outside of quotes) escaped by \ is taken literally. + 3) '<' and '>' are words all by themselves, unless escaped or quoted. + 4) Whitespace separates words +-} + +parseCommand :: String -> IO [String] +parseCommand = getTokens [] + where + getTokens :: [String] -> String -> IO [String] + getTokens ts "" = return (reverse ts) + getTokens ts s = + getToken s >>= \ (t, s') -> + getTokens (t:ts) s' + + getToken :: String -> IO (String, String) + getToken (c:cs) + | c == '<' || c == '>' = return ([c], cs) + | isSpace c = getToken cs + | c == '"' || c == '\'' = accumQuote c "" cs + | otherwise = accumToken [c] cs + + accumToken :: [Char] -> String -> IO (String, String) + accumToken cs "" = return (reverse cs, "") + accumToken cs ('\\':c:s) = accumToken (c:cs) s + accumToken cs x@(c:s) + | isSpace c || c == '<' || c == '>' = return (reverse cs, x) + | c == '"' || c == '\'' = accumQuote c cs s + | otherwise = accumToken (c:cs) s + + accumQuote :: Char -> [Char] -> String -> IO (String, String) + accumQuote q cs "" = + errMsg ("Unmatched " ++ [q]) >> + failWith (UserError "unmatched quote") + accumQuote q cs (c:s) + | c == q = accumToken cs s + | otherwise = accumQuote q (c:cs) s + +{- + Here we look for "<" and ">". When we find one, we remove it and the + following word from the word list. The arguments following the redirection + symbols and the remaining words are returned to our caller. However, it's + an error to end a word list with a redirection or for the same redirection + to appear twice. +-} + +parseRedirection :: [String] -> IO (Maybe String, Maybe String, [String]) +parseRedirection = redirect Nothing Nothing [] + where + redirect inFile outFile args [] = + return (inFile, outFile, reverse args) + redirect inFile outFile args [arg] + | arg == "<" || arg == ">" = + errMsg "Missing name for redirect" >> + failWith (UserError "parse redirect") + | otherwise = + return (inFile, outFile, reverse (arg:args)) + redirect inFile outFile args ("<":name:more) + | inFile == Nothing = + redirect (Just name) outFile args more + | otherwise = + errMsg "Ambiguous input redirect" >> + failWith (UserError "parse redirect") + redirect inFile outFile args (">":name:more) + | outFile == Nothing = + redirect inFile (Just name) args more + | otherwise = + errMsg "Ambiguous output redirect" >> + failWith (UserError "parse redirect") + redirect inFile outFile args (arg:more) = + redirect inFile outFile (arg:args) more + +{- + Executing an external command is pretty simple, but what if it fails? + Fortunately, we don't have any way to redirect stdError just yet, + so we let it complain and then exit. +-} + +exec :: String -> [String] -> IO () +exec cmd args = + forkProcess >>= \ maybe_pid -> + case maybe_pid of + Nothing -> + dupChannelTo myStderr stdError >> + closeChannel myStdin >> + closeChannel myStdout >> + closeChannel myStderr >> + executeFile cmd True args Nothing `handle` + \ err -> + writeChannel stdError ("command not found: " ++ cmd ++ ".\n") + >> + exitImmediately (ExitFailure 1) + Just pid -> + closeChannel stdInput >> + closeChannel stdOutput >> +-- closeChannel stdError >> + getProcessStatus True False pid >> + return () + +{- + Builtins: + cd [arg] -> change directory (default to HOME) + exit ... -> exit successfully + + Builtins must provide their own error messages, since the main command + loop ignores any errors. +-} + +builtin :: String -> Maybe ([String] -> IO ()) +builtin "cd" = Just chdir +builtin "exit" = Just exit +builtin _ = Nothing + +chdir :: [String] -> IO () +chdir [] = + getEnvVar "HOME" >>= \ home -> + changeWorkingDirectory home `handle` + \ err -> errMsg "cd: can't go home" + +chdir [dir] = + changeWorkingDirectory dir `handle` + \ err -> errMsg ("cd: can't chdir to " ++ dir) +chdir _ = + errMsg "cd: too many arguments" + +exit :: [String] -> IO () +exit _ = exitWith ExitSuccess + +-- Print an error message to my std error. + +errMsg :: String -> IO () +errMsg msg = + writeChannel myStderr ("hsh: " ++ msg ++ ".\n") >> + return () diff --git a/ghc/misc/examples/io/io001/Main.hs b/ghc/misc/examples/io/io001/Main.hs new file mode 100644 index 0000000000..6620e3c1fe --- /dev/null +++ b/ghc/misc/examples/io/io001/Main.hs @@ -0,0 +1 @@ +main = putStr "Hello, world\n" diff --git a/ghc/misc/examples/io/io002/Main.hs b/ghc/misc/examples/io/io002/Main.hs new file mode 100644 index 0000000000..346bffb8a1 --- /dev/null +++ b/ghc/misc/examples/io/io002/Main.hs @@ -0,0 +1,12 @@ +import LibSystem (getEnv) + +main = + getEnv "TERM" >>= \ term -> + putStr term >> + putChar '\n' >> + getEnv "One fish, two fish, red fish, blue fish" >>= \ fish -> + putStr fish >> + putChar '\n' + + + diff --git a/ghc/misc/examples/io/io003/Main.hs b/ghc/misc/examples/io/io003/Main.hs new file mode 100644 index 0000000000..535b4716df --- /dev/null +++ b/ghc/misc/examples/io/io003/Main.hs @@ -0,0 +1,9 @@ +import LibSystem (getProgName, getArgs) + +main = + getProgName >>= \ argv0 -> + putStr argv0 >> + getArgs >>= \ argv -> + sequence (map (\ x -> putChar ' ' >> putStr x) argv) >> + putChar '\n' + diff --git a/ghc/misc/examples/io/io004/Main.hs b/ghc/misc/examples/io/io004/Main.hs new file mode 100644 index 0000000000..59c745d4b1 --- /dev/null +++ b/ghc/misc/examples/io/io004/Main.hs @@ -0,0 +1,3 @@ +import LibSystem (exitWith, ExitCode(..)) + +main = exitWith (ExitFailure 42) diff --git a/ghc/misc/examples/io/io005/Main.hs b/ghc/misc/examples/io/io005/Main.hs new file mode 100644 index 0000000000..a987b9fb27 --- /dev/null +++ b/ghc/misc/examples/io/io005/Main.hs @@ -0,0 +1,11 @@ +import LibSystem (system, ExitCode(..), exitWith) + +main = + system "cat dog 1>/dev/null 2>&1" >>= \ ec -> + case ec of + ExitSuccess -> putStr "What?!?\n" >> fail "dog succeeded" + ExitFailure _ -> + system "cat Main.hs 2>/dev/null" >>= \ ec -> + case ec of + ExitSuccess -> exitWith ExitSuccess + ExitFailure _ -> putStr "What?!?\n" >> fail "cat failed" diff --git a/ghc/misc/examples/io/io006/Main.hs b/ghc/misc/examples/io/io006/Main.hs new file mode 100644 index 0000000000..c6fc5394e3 --- /dev/null +++ b/ghc/misc/examples/io/io006/Main.hs @@ -0,0 +1,4 @@ +main = + hClose stderr >> + hPutStr stderr "junk" `handle` \ (IllegalOperation _) -> putStr "Okay\n" + diff --git a/ghc/misc/examples/io/io007/Main.hs b/ghc/misc/examples/io/io007/Main.hs new file mode 100644 index 0000000000..d6c94d8ef7 --- /dev/null +++ b/ghc/misc/examples/io/io007/Main.hs @@ -0,0 +1,6 @@ +main = + openFile "io007.in" ReadMode >>= \ hIn -> + hPutStr hIn "test" `handle` + \ (IllegalOperation _) -> + hGetContents hIn >>= \ stuff -> + hPutStr stdout stuff diff --git a/ghc/misc/examples/io/io008/Main.hs b/ghc/misc/examples/io/io008/Main.hs new file mode 100644 index 0000000000..51685c9201 --- /dev/null +++ b/ghc/misc/examples/io/io008/Main.hs @@ -0,0 +1,18 @@ +import LibDirectory (removeFile) + +main = + openFile "io008.in" ReadMode >>= \ hIn -> + openFile "io008.out" ReadWriteMode >>= \ hOut -> + removeFile "io008.out" >> + hGetPosn hIn >>= \ bof -> + copy hIn hOut >> + hSetPosn bof >> + copy hIn hOut >> + hSeek hOut AbsoluteSeek 0 >> + hGetContents hOut >>= \ stuff -> + putStr stuff + +copy :: Handle -> Handle -> IO () +copy hIn hOut = + try (hGetChar hIn) >>= + either (\ EOF -> return ()) ( \ x -> hPutChar hOut x >> copy hIn hOut) diff --git a/ghc/misc/examples/io/io009/Main.hs b/ghc/misc/examples/io/io009/Main.hs new file mode 100644 index 0000000000..b1bc0f2dc3 --- /dev/null +++ b/ghc/misc/examples/io/io009/Main.hs @@ -0,0 +1,7 @@ +import LibDirectory (getDirectoryContents) +import QSort (sort) + +main = + getDirectoryContents "." >>= \ names -> + putText (sort names) >> + putChar '\n'
\ No newline at end of file diff --git a/ghc/misc/examples/io/io010/Main.hs b/ghc/misc/examples/io/io010/Main.hs new file mode 100644 index 0000000000..5e5b0c3d16 --- /dev/null +++ b/ghc/misc/examples/io/io010/Main.hs @@ -0,0 +1,20 @@ +import LibDirectory (getCurrentDirectory, setCurrentDirectory, + createDirectory, removeDirectory, getDirectoryContents) + +main = + getCurrentDirectory >>= \ oldpwd -> + createDirectory "foo" >> + setCurrentDirectory "foo" >> + getDirectoryContents "." >>= \ [n1, n2] -> + if dot n1 && dot n2 then + setCurrentDirectory oldpwd >> + removeDirectory "foo" >> + putStr "Okay\n" + else + fail "Oops" + + +dot :: String -> Bool +dot "." = True +dot ".." = True +dot _ = False
\ No newline at end of file diff --git a/ghc/misc/examples/io/io011/Main.hs b/ghc/misc/examples/io/io011/Main.hs new file mode 100644 index 0000000000..2fcbce5cb5 --- /dev/null +++ b/ghc/misc/examples/io/io011/Main.hs @@ -0,0 +1,15 @@ +import LibDirectory + +main = + createDirectory "foo" >> + openFile "foo/bar" WriteMode >>= \ h -> + hPutStr h "Okay\n" >> + hClose h >> + renameFile "foo/bar" "foo/baz" >> + renameDirectory "foo" "bar" >> + openFile "bar/baz" ReadMode >>= \ h -> + hGetContents h >>= \ stuff -> + putStr stuff >> + hClose h >> + removeFile "bar/baz" >> + removeDirectory "bar" diff --git a/ghc/misc/examples/io/io012/Main.hs b/ghc/misc/examples/io/io012/Main.hs new file mode 100644 index 0000000000..9b7fba3925 --- /dev/null +++ b/ghc/misc/examples/io/io012/Main.hs @@ -0,0 +1,16 @@ +import LibCPUTime + +main = + openFile "/dev/null" WriteMode >>= \ h -> + hPutText h (nfib 30) >> + getCPUTime >>= \ t -> + putText t >> + putChar '\n' + +nfib :: Integer -> Integer +nfib n + | n <= 1 = 1 + | otherwise = (n1 + n2 + 1) + where + n1 = nfib (n-1) + n2 = nfib (n-2) diff --git a/ghc/misc/examples/io/io013/Main.hs b/ghc/misc/examples/io/io013/Main.hs new file mode 100644 index 0000000000..39c429e13d --- /dev/null +++ b/ghc/misc/examples/io/io013/Main.hs @@ -0,0 +1,17 @@ +main = + openFile "io013.in" ReadMode >>= \ h -> + hFileSize h >>= \ sz -> + putText sz >> + putChar '\n' >> + hSeek h SeekFromEnd (-3) >> + hGetChar h >>= \ x -> + putStr (x:"\n") >> + hSeek h RelativeSeek (-2) >> + hGetChar h >>= \ w -> + putStr (w:"\n") >> + hIsSeekable h >>= \ True -> + hClose h >> + openFile "/dev/null" ReadMode >>= \ h -> + hIsSeekable h >>= \ False -> + hClose h +
\ No newline at end of file diff --git a/ghc/misc/examples/io/io014/Main.hs b/ghc/misc/examples/io/io014/Main.hs new file mode 100644 index 0000000000..23f62ca748 --- /dev/null +++ b/ghc/misc/examples/io/io014/Main.hs @@ -0,0 +1,22 @@ +main = + accumulate (map hIsOpen [stdin, stdout, stderr]) >>= \ opens -> + putText opens >> + putChar '\n' >> + accumulate (map hIsClosed [stdin, stdout, stderr]) >>= \ closeds -> + putText closeds >> + putChar '\n' >> + accumulate (map hIsReadable [stdin, stdout, stderr]) >>= \ readables -> + putText readables >> + putChar '\n' >> + accumulate (map hIsWritable [stdin, stdout, stderr]) >>= \ writables -> + putText writables >> + putChar '\n' >> + accumulate (map hIsBlockBuffered [stdin, stdout, stderr]) >>= \ buffereds -> + putText buffereds >> + putChar '\n' >> + accumulate (map hIsLineBuffered [stdin, stdout, stderr]) >>= \ buffereds -> + putText buffereds >> + putChar '\n' >> + accumulate (map hIsNotBuffered [stdin, stdout, stderr]) >>= \ buffereds -> + putText buffereds >> + putChar '\n' diff --git a/ghc/misc/examples/io/io015/Main.hs b/ghc/misc/examples/io/io015/Main.hs new file mode 100644 index 0000000000..a58450942c --- /dev/null +++ b/ghc/misc/examples/io/io015/Main.hs @@ -0,0 +1,8 @@ +main = + isEOF >>= \ eof -> + if eof then + return () + else + getChar >>= \ c -> + putChar c >> + main diff --git a/ghc/misc/examples/io/io016/Main.hs b/ghc/misc/examples/io/io016/Main.hs new file mode 100644 index 0000000000..e8df7a93dd --- /dev/null +++ b/ghc/misc/examples/io/io016/Main.hs @@ -0,0 +1,18 @@ +import LibSystem (getArgs) + +main = getArgs >>= \ [f1,f2] -> + openFile f1 ReadMode >>= \ h1 -> + openFile f2 WriteMode >>= \ h2 -> + copyFile h1 h2 >> + hClose h1 >> + hClose h2 + +copyFile h1 h2 = + hIsEOF h1 >>= \ eof -> + if eof then + return () + else + hGetChar h1 >>= \ c -> + hPutChar h2 (toUpper c) >> + copyFile h1 h2 + diff --git a/ghc/misc/examples/io/io017/Main.hs b/ghc/misc/examples/io/io017/Main.hs new file mode 100644 index 0000000000..f0a6d3ef3b --- /dev/null +++ b/ghc/misc/examples/io/io017/Main.hs @@ -0,0 +1,17 @@ +main = + hSetBuffering stdout NoBuffering >> + putStr "Enter an integer: " >> + readLine >>= \ x1 -> + putStr "Enter another integer: " >> + readLine >>= \ x2 -> + putStr ("Their sum is " ++ show (read x1+ read x2) ++ "\n") + + where readLine = isEOF >>= \ eof -> + if eof then return [] + else getChar >>= \ c -> + if c `elem` ['\n','\r'] then + return [] + else + readLine >>= \ cs -> + return (c:cs) + diff --git a/ghc/misc/examples/io/io018/Main.hs b/ghc/misc/examples/io/io018/Main.hs new file mode 100644 index 0000000000..f15c1cb5c1 --- /dev/null +++ b/ghc/misc/examples/io/io018/Main.hs @@ -0,0 +1,23 @@ +import LibSystem(getArgs) + +main = getArgs >>= \ [user,host] -> + let username = (user ++ "@" ++ host) in + openFile username ReadWriteMode >>= \ cd -> + hSetBuffering stdin NoBuffering >> + hSetBuffering stdout NoBuffering >> + hSetBuffering cd NoBuffering >> + hPutStr cd speakString >> + speak cd + +speakString = "Someone wants to speak with you\n" + +speak cd = + (hReady cd >>= \ ready -> + if ready then (hGetChar cd >>= putChar) + else return () >> + + hReady stdin >>= \ ready -> + if ready then (getChar >>= hPutChar cd) + else return ()) >> + + speak cd diff --git a/ghc/misc/examples/io/io019/Main.hs b/ghc/misc/examples/io/io019/Main.hs new file mode 100644 index 0000000000..168a4ac249 --- /dev/null +++ b/ghc/misc/examples/io/io019/Main.hs @@ -0,0 +1,23 @@ +import LibTime + +main = + getClockTime >>= \ time -> + putText time >> + putChar '\n' >> + + let (CalendarTime year month mday hour min sec psec + wday yday timezone gmtoff isdst) = toUTCTime time + in + putStr (wdays !! wday) >> + putStr (' ' : months !! month) >> + putStr (' ' : shows2 mday (' ' : shows2 hour (':' : shows2 min (':' : shows2 sec + (' ' : timezone ++ ' ' : shows year "\n"))))) + + where + wdays = ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"] + months = ["Jan", "Feb", "Mar", "Apr", "May", "Jun", + "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"] + shows2 x = showString (pad2 x) + pad2 x = case show x of + c@[_] -> '0' : c + cs -> cs
\ No newline at end of file diff --git a/ghc/misc/examples/io/io020/Main.hs b/ghc/misc/examples/io/io020/Main.hs new file mode 100644 index 0000000000..ff68bd9f35 --- /dev/null +++ b/ghc/misc/examples/io/io020/Main.hs @@ -0,0 +1,13 @@ +import LibTime + +main = + getClockTime >>= \ time -> + let (CalendarTime year month mday hour min sec psec + wday yday timezone gmtoff isdst) = toUTCTime time + time' = toClockTime (CalendarTime (year - 1) month mday hour min sec psec + wday yday timezone gmtoff isdst) + in + putText time >> + putChar '\n' >> + putText time' >> + putChar '\n' diff --git a/ghc/misc/examples/io/io021/Main.hs b/ghc/misc/examples/io/io021/Main.hs new file mode 100644 index 0000000000..66548f63ee --- /dev/null +++ b/ghc/misc/examples/io/io021/Main.hs @@ -0,0 +1,4 @@ +main = + hSetBuffering stdin NoBuffering >> + hSetBuffering stdout NoBuffering >> + interact id diff --git a/ghc/misc/examples/net001/Main.hs b/ghc/misc/examples/net001/Main.hs new file mode 100644 index 0000000000..121e51d664 --- /dev/null +++ b/ghc/misc/examples/net001/Main.hs @@ -0,0 +1,55 @@ +{- server + +The purpose of this test driver is to test TCP Stream sockets. +All values have been hard coded since the BSD library is not used to +query the databases for the values. In therory this code is thus not +portable but net007/Main.hs provides a portable version using the BSD +module. + +This creates a stream socket bound to port 5000 and waits for incoming +messages it then reads all available data before closing the +connection to that peer. + +No form of error checking is provided other than that already provided +by module SocketPrim. + + +TESTS: + socket + bindSocket + listen + accept + readSocket + sClose + +-} + + +module Main where + +import SocketPrim + + +main = + socket AF_INET Stream 6 >>= \ s -> + bindSocket s (SockAddrInet 5000 iNADDR_ANY) >> + listen s 5 >> + + let + loop = + accept s >>= \ (s',peerAddr) -> + putStr "*** Start of Transfer ***\n" >> + let + read_all = + readSocket s' 4 >>= \ (str, nbytes) -> + if nbytes /= 0 then + putStr str >> + read_all + else + putStr "\n*** End of Transfer ***\n" >> + sClose s' + in + read_all + in + loop + diff --git a/ghc/misc/examples/net002/Main.hs b/ghc/misc/examples/net002/Main.hs new file mode 100644 index 0000000000..7ae6cdc2b6 --- /dev/null +++ b/ghc/misc/examples/net002/Main.hs @@ -0,0 +1,42 @@ +{- client + +Client side to net001/Main.hs. + +Note that the machine IP numbers have been hard coded into this +program so it is unlikely that you will be able to run this test if +you are not at dcs.gla.ac.uk :-( + +The reason for this is to aviod using the BSD module at this stage of +testing. + + +TESTS: + socket + connect + writeSocket + shutdown + inet_addr +-} + + +module Main where + +import SocketPrim + + +starbuck = "130.209.240.81" -- SunOS 4.1.3 1 sun4c +marcus = "130.209.247.2" -- SunOS 4.1.3 6 sun4m +avon = "130.209.247.4" -- OSF1 V2.0 240 alpha +karkar = "130.209.247.3" -- OSF1 V2.0 240 alpha + +message = "Hello World" + + +main = + socket AF_INET Stream 6 >>= \ s -> + connect s (SockAddrInet 5000 (inet_addr avon)) >> + + writeSocket s message >> + shutdown s 2 >> + sClose s + diff --git a/ghc/misc/examples/net003/Main.hs b/ghc/misc/examples/net003/Main.hs new file mode 100644 index 0000000000..85c00e4eba --- /dev/null +++ b/ghc/misc/examples/net003/Main.hs @@ -0,0 +1,43 @@ +{- server + +As for net001 but gets the system to allocate the next free port +number. It also prints out the IP number of the peer. + +TESTS: + getSocketName + inet_ntoa + +-} + +module Main where + +import SocketPrim + + +main = + socket AF_INET Stream 6 >>= \ s -> + bindSocket s (SockAddrInet aNY_PORT iNADDR_ANY) >> + getSocketName s >>= \ (SockAddrInet port _) -> + putStr ("Allocated Port Number: " ++ show port ++ "\n") >> + listen s 5 >> + + + let + loop = + accept s >>= \ (s',(SockAddrInet _ haddr)) -> + putStr ("*** Start of Transfer from: " ++ + (inet_ntoa haddr) ++ "***\n") >> + let + read_all = + readSocket s' 4 >>= \ (str, nbytes) -> + if nbytes /= 0 then + putStr str >> + read_all + else + putStr "\n*** End of Transfer ***\n" >> + sClose s' + in + read_all + in + loop + diff --git a/ghc/misc/examples/net004/Main.hs b/ghc/misc/examples/net004/Main.hs new file mode 100644 index 0000000000..3948707df3 --- /dev/null +++ b/ghc/misc/examples/net004/Main.hs @@ -0,0 +1,33 @@ +{- client + +As for net002 but reads port number and message as arguments. +It also prints out the IP number of the peer machine. + + + +TESTS: + getPeerName +-} + + +module Main where + +import SocketPrim +import LibSystem + + +starbuck = "130.209.240.81" +marcus = "130.209.247.2" + + +main = + getArgs >>= \ [port, message] -> + socket AF_INET Stream 6 >>= \ s -> + connect s (SockAddrInet (read port) (inet_addr starbuck)) >> + + getPeerName s >>= \ (SockAddrInet p haddr) -> + putStr ("Connected to : " ++ (inet_ntoa haddr) ++ "\n") >> + writeSocket s message >> + shutdown s 2 >> + sClose s + diff --git a/ghc/misc/examples/net005/Main.hs b/ghc/misc/examples/net005/Main.hs new file mode 100644 index 0000000000..ec504aa480 --- /dev/null +++ b/ghc/misc/examples/net005/Main.hs @@ -0,0 +1,37 @@ +{- server + +Server as net001 but for Unix Domain Datagram sockets. + +TESTS: + socket + bindSocket + readSocket + +-} + + +module Main where + +import SocketPrim + + +main = + socket AF_UNIX Datagram 0 >>= \ s -> + bindSocket s (SockAddrUnix "sock") >> + + let + loop = + putStr "*** Start of Transfer ***\n" >> + let + read_all = + readSocket s 1024 >>= \ (str, nbytes) -> + if nbytes /= 0 then + putStr str >> + read_all + else + putStr "\n*** End of Transfer ***\n" + in + read_all + in + loop + diff --git a/ghc/misc/examples/net006/Main.hs b/ghc/misc/examples/net006/Main.hs new file mode 100644 index 0000000000..57be04e330 --- /dev/null +++ b/ghc/misc/examples/net006/Main.hs @@ -0,0 +1,27 @@ +{- client + +Client side of net005 + +TESTS: + socket + connect + writeSocket + shutdown + sClose +-} + + +module Main where + +import SocketPrim + +message = "Hello World" + + +main = + socket AF_UNIX Datagram 0 >>= \ s -> + connect s (SockAddrUnix "sock") >> + + writeSocket s message >> + shutdown s 2 >> + sClose s diff --git a/ghc/misc/examples/net007/Main.hs b/ghc/misc/examples/net007/Main.hs new file mode 100644 index 0000000000..fbc9ff04e0 --- /dev/null +++ b/ghc/misc/examples/net007/Main.hs @@ -0,0 +1,44 @@ +{- server + +As net003 but uses the BSD module for portability. Also prints the +common name of the host rather than its IP number. + +TESTS: + getProtocolNumber + getSocketName + getHostByAddr + +-} + +module Main where + +import BSD +import SocketPrim + +main = + getProtocolNumber "tcp" >>= \ proto -> + socket AF_INET Stream proto >>= \ s -> + bindSocket s (SockAddrInet aNY_PORT iNADDR_ANY) >> + getSocketName s >>= \ (SockAddrInet port _) -> + putStr ("Allocated Port Number: " ++ show port ++ "\n") >> + listen s 5 >> + + + let + loop = + accept s >>= \ (s',(SockAddrInet _ haddr)) -> + getHostByAddr AF_INET haddr >>= \ (HostEntry hname _ _ _) -> + putStr ("*** Start of Transfer from: " ++ hname ++ "***\n") >> + let + read_all = + readSocket s' 4 >>= \ (str, nbytes) -> + if nbytes /= 0 then + putStr str >> + read_all + else + putStr "\n*** End of Transfer ***\n" >> + sClose s' + in + read_all + in + loop diff --git a/ghc/misc/examples/net008/Main.hs b/ghc/misc/examples/net008/Main.hs new file mode 100644 index 0000000000..8c339297e2 --- /dev/null +++ b/ghc/misc/examples/net008/Main.hs @@ -0,0 +1,22 @@ +module Main where + +import SocketPrim +import BSD +import LibSystem + + +main = + getArgs >>= \ [host, port, message] -> + getProtocolNumber "tcp" >>= \ proto -> + socket AF_INET Stream proto >>= \ s -> + getHostByName host >>= \ (HostEntry _ _ _ haddrs) -> + connect s (SockAddrInet (read port) + (head haddrs)) >> + + getPeerName s >>= \ (SockAddrInet _ haddr) -> + getHostByAddr AF_INET haddr >>= \ (HostEntry hname _ _ _) -> + putStr ("Connected to : " ++ hname ++ "\n") >> + writeSocket s message >> + shutdown s 2 >> + sClose s + diff --git a/ghc/misc/examples/nfib/nfibD.hs b/ghc/misc/examples/nfib/nfibD.hs new file mode 100644 index 0000000000..373bef36b5 --- /dev/null +++ b/ghc/misc/examples/nfib/nfibD.hs @@ -0,0 +1,10 @@ +module Main where + +main = print (nfib 28) + +nfib :: Double -> Double + +nfib n | n <= 1 = 1 + | otherwise = (n1 + n2 + 1) + where n1 = nfib (n-1) + n2 = nfib (n-2) diff --git a/ghc/misc/examples/nfib/nfibF.hs b/ghc/misc/examples/nfib/nfibF.hs new file mode 100644 index 0000000000..604bcd195a --- /dev/null +++ b/ghc/misc/examples/nfib/nfibF.hs @@ -0,0 +1,10 @@ +module Main where + +main = print (nfib 28) + +nfib :: Float -> Float + +nfib n | n <= 1 = 1 + | otherwise = (n1 + n2 + 1) + where n1 = nfib (n-1) + n2 = nfib (n-2) diff --git a/ghc/misc/examples/nfib/nfibI.hs b/ghc/misc/examples/nfib/nfibI.hs new file mode 100644 index 0000000000..a889a1e948 --- /dev/null +++ b/ghc/misc/examples/nfib/nfibI.hs @@ -0,0 +1,10 @@ +module Main where + +main = print (nfib 30) + +nfib :: Int -> Int + +nfib n | n <= 1 = 1 + | otherwise = (n1 + n2 + 1) + where n1 = nfib (n-1) + n2 = nfib (n-2) diff --git a/ghc/misc/examples/nfib/nfibJ.hs b/ghc/misc/examples/nfib/nfibJ.hs new file mode 100644 index 0000000000..c622e5c6e1 --- /dev/null +++ b/ghc/misc/examples/nfib/nfibJ.hs @@ -0,0 +1,10 @@ +module Main where + +main = print (nfib 28) + +nfib :: Integer -> Integer + +nfib n | n <= 1 = 1 + | otherwise = (n1 + n2 + 1) + where n1 = nfib (n-1) + n2 = nfib (n-2) diff --git a/ghc/misc/examples/nfib/nfibO.hs b/ghc/misc/examples/nfib/nfibO.hs new file mode 100644 index 0000000000..a63c33478d --- /dev/null +++ b/ghc/misc/examples/nfib/nfibO.hs @@ -0,0 +1,10 @@ +module Main where + +main = print (nfib 28) + +nfib :: (Num a, Ord a) => a -> a + +nfib n | n <= 1 = 1 + | otherwise = (n1 + n2 + 1) + where n1 = nfib (n-1) + n2 = nfib (n-2) diff --git a/ghc/misc/examples/nfib/nfibR.hs b/ghc/misc/examples/nfib/nfibR.hs new file mode 100644 index 0000000000..793c16497c --- /dev/null +++ b/ghc/misc/examples/nfib/nfibR.hs @@ -0,0 +1,10 @@ +module Main where + +main = print (nfib 20) + +nfib :: Rational -> Rational + +nfib n | n <= 1 = 1 + | otherwise = (n1 + n2 + 1) + where n1 = nfib (n-1) + n2 = nfib (n-2) diff --git a/ghc/misc/examples/posix/po001/Main.hs b/ghc/misc/examples/posix/po001/Main.hs new file mode 100644 index 0000000000..db10babaa4 --- /dev/null +++ b/ghc/misc/examples/posix/po001/Main.hs @@ -0,0 +1,23 @@ +import LibPosix + +main = + getParentProcessID >>= \ ppid -> + getProcessID >>= \ pid -> + putStr "Parent Process ID: " >> + putText ppid >> + putStr "\nProcess ID: " >> + putText pid >> + putStr "\nforking ps uxww" >> + putText ppid >> + putChar '\n' >> + forkProcess >>= \ child -> + case child of + Nothing -> executeFile "ps" True ["uxww" ++ show ppid] Nothing + Just x -> doParent x pid + +doParent cpid pid = + getProcessStatus True False cpid >> + putStr "\nChild finished. Now exec'ing ps uxww" >> + putText pid >> + putChar '\n' >> + executeFile "ps" True ["uxww" ++ show pid] Nothing diff --git a/ghc/misc/examples/posix/po002/Main.hs b/ghc/misc/examples/posix/po002/Main.hs new file mode 100644 index 0000000000..e646f02839 --- /dev/null +++ b/ghc/misc/examples/posix/po002/Main.hs @@ -0,0 +1,4 @@ +import LibPosix + +main = + executeFile "printenv" True [] (Just [("ONE","1"),("TWO","2")]) diff --git a/ghc/misc/examples/posix/po003/Main.hs b/ghc/misc/examples/posix/po003/Main.hs new file mode 100644 index 0000000000..b05d9cf7f0 --- /dev/null +++ b/ghc/misc/examples/posix/po003/Main.hs @@ -0,0 +1,5 @@ +import LibPosix + +main = + openFile "po003.out" WriteMode >>= \ h -> + runProcess "pwd" [] Nothing (Just "/usr/tmp") Nothing (Just h) Nothing
\ No newline at end of file diff --git a/ghc/misc/examples/posix/po004/Main.hs b/ghc/misc/examples/posix/po004/Main.hs new file mode 100644 index 0000000000..1725dd4e2b --- /dev/null +++ b/ghc/misc/examples/posix/po004/Main.hs @@ -0,0 +1,58 @@ +import LibPosix +import LibSystem(ExitCode(..), exitWith) + +main = + forkProcess >>= \ maybe_pid -> + case maybe_pid of + Nothing -> raiseSignal floatingPointException + _ -> doParent + +doParent = + getAnyProcessStatus True False >>= \ (Just (pid, tc)) -> + case tc of + Terminated sig | sig == floatingPointException -> forkChild2 + _ -> fail "unexpected termination cause" + +forkChild2 = + forkProcess >>= \ maybe_pid -> + case maybe_pid of + Nothing -> exitImmediately (ExitFailure 42) + _ -> doParent2 + +doParent2 = + getAnyProcessStatus True False >>= \ (Just (pid, tc)) -> + case tc of + Exited (ExitFailure 42) -> forkChild3 + _ -> fail "unexpected termination cause (2)" + +forkChild3 = + forkProcess >>= \ maybe_pid -> + case maybe_pid of + Nothing -> exitImmediately (ExitSuccess) + _ -> doParent3 + +doParent3 = + getAnyProcessStatus True False >>= \ (Just (pid, tc)) -> + case tc of + Exited ExitSuccess -> forkChild4 + _ -> fail "unexpected termination cause (3)" + +forkChild4 = + forkProcess >>= \ maybe_pid -> + case maybe_pid of + Nothing -> raiseSignal softwareStop + _ -> doParent4 + +doParent4 = + getAnyProcessStatus True True >>= \ (Just (pid, tc)) -> + case tc of + Stopped sig | sig == softwareStop -> enoughAlready pid + _ -> fail "unexpected termination cause (4)" + +enoughAlready pid = + signalProcess killProcess pid >> + getAnyProcessStatus True True >>= \ (Just (pid, tc)) -> + case tc of + Terminated sig | sig == killProcess -> putStr "I'm happy.\n" + _ -> fail "unexpected termination cause (5)" + diff --git a/ghc/misc/examples/posix/po005/Main.hs b/ghc/misc/examples/posix/po005/Main.hs new file mode 100644 index 0000000000..8ea76255e1 --- /dev/null +++ b/ghc/misc/examples/posix/po005/Main.hs @@ -0,0 +1,30 @@ +import LibPosix + +main = + getEnvVar "TERM" >>= \ term -> + putStr term >> + putChar '\n' >> + setEnvironment [("one","1"),("two","2")] >> + getEnvironment >>= \ env -> + putText env >> + putChar '\n' >> + setEnvVar "foo" "bar" >> + getEnvironment >>= \ env -> + putText env >> + putChar '\n' >> + setEnvVar "foo" "baz" >> + getEnvironment >>= \ env -> + putText env >> + putChar '\n' >> + setEnvVar "fu" "bar" >> + getEnvironment >>= \ env -> + putText env >> + putChar '\n' >> + removeEnvVar "foo" >> + getEnvironment >>= \ env -> + putText env >> + putChar '\n' >> + setEnvironment [] >> + getEnvironment >>= \ env -> + putText env >> + putChar '\n' diff --git a/ghc/misc/examples/posix/po006/Main.hs b/ghc/misc/examples/posix/po006/Main.hs new file mode 100644 index 0000000000..8008a50f2b --- /dev/null +++ b/ghc/misc/examples/posix/po006/Main.hs @@ -0,0 +1,14 @@ +import LibPosix + +main = + epochTime >>= \ start -> + sleep 5 >> + let timeleft = 0 in + epochTime >>= \ finish -> + putStr "Started: " >> + putText start >> + putStr "\nSlept: " >> + putText (5 - timeleft) >> + putStr "\nFinished: " >> + putText finish >> + putChar '\n' diff --git a/ghc/misc/examples/posix/po007/Main.hs b/ghc/misc/examples/posix/po007/Main.hs new file mode 100644 index 0000000000..d70e913e6b --- /dev/null +++ b/ghc/misc/examples/posix/po007/Main.hs @@ -0,0 +1,31 @@ +import LibPosix + +main = + installHandler keyboardSignal (Catch doCtrlC) Nothing >> + getTerminalAttributes stdInput >>= \ ta -> + case (controlChar ta Interrupt) of + Nothing -> fixMe ta + Just x -> continue x + +fixMe ta = + putStr "Oops...no interrupt character?\nI can fix that...\n" >> + setTerminalAttributes stdInput (withCC ta (Interrupt, '\ETX')) Immediately >> + getTerminalAttributes stdInput >>= \ ta -> + case (controlChar ta Interrupt) of + Nothing -> putStr "...Then again, maybe I can't\n" + Just x -> continue x + +continue x = + putStr "Press '" >> + putStr (ccStr x) >> + putStr "'.\n" >> + awaitSignal Nothing >> + putStr "How did I get here?\n" + +doCtrlC = + putStr "Caught an interrupt.\n" + +ccStr '\DEL' = "^?" +ccStr x + | x >= ' ' = [x] + | otherwise = ['^', (chr (ord x + ord '@'))] diff --git a/ghc/misc/examples/posix/po008/Main.hs b/ghc/misc/examples/posix/po008/Main.hs new file mode 100644 index 0000000000..c775064405 --- /dev/null +++ b/ghc/misc/examples/posix/po008/Main.hs @@ -0,0 +1,12 @@ +import LibPosix + +main = + installHandler realTimeAlarm (Catch alarmclock) Nothing >> + putStr "Scheduling an alarm in 5 seconds...\n" >> + scheduleAlarm 5 >> + putStr "Sleeping one minute.\n" >> + sleep 60 >> + putStr "How did I get here?\n" + +alarmclock = + putStr "The alarm went off.\n" diff --git a/ghc/misc/examples/posix/po009/Main.hs b/ghc/misc/examples/posix/po009/Main.hs new file mode 100644 index 0000000000..9707c58747 --- /dev/null +++ b/ghc/misc/examples/posix/po009/Main.hs @@ -0,0 +1,14 @@ +import LibPosix + +main = + putStr "Blocking real time alarms.\n" >> + blockSignals (addSignal realTimeAlarm emptySignalSet) >> + putStr "Scheduling an alarm in 2 seconds...\n" >> + scheduleAlarm 2 >> + putStr "Sleeping 5 seconds.\n" >> + sleep 5 >> + getPendingSignals >>= \ ints -> + putStr "Checking pending interrupts for RealTimeAlarm\n" >> + putText (inSignalSet realTimeAlarm ints) >> + putChar '\n' + diff --git a/ghc/misc/examples/posix/po010/Main.hs b/ghc/misc/examples/posix/po010/Main.hs new file mode 100644 index 0000000000..bfc890941f --- /dev/null +++ b/ghc/misc/examples/posix/po010/Main.hs @@ -0,0 +1,24 @@ +import LibPosix + +main = + getUserEntryForName "mattson" >>= \ mattson -> + getUserEntryForName "partain" >>= \ partain -> + putStr (ue2String mattson) >> + putChar '\n' >> + putStr (ue2String partain) >> + putChar '\n' >> + getUserEntryForID (userID mattson) >>= \ muid -> + getUserEntryForID (userID partain) >>= \ puid -> + putStr (ue2String muid) >> + putChar '\n' >> + putStr (ue2String puid) >> + putChar '\n' + +ue2String ue = + name ++ (':' : (show uid) ++ (':' : (show gid) ++ (':' : home ++ (':' : shell)))) + where + name = userName ue + uid = userID ue + gid = userGroupID ue + home = homeDirectory ue + shell = userShell ue
\ No newline at end of file diff --git a/ghc/misc/examples/posix/po011/Main.hs b/ghc/misc/examples/posix/po011/Main.hs new file mode 100644 index 0000000000..3d78924157 --- /dev/null +++ b/ghc/misc/examples/posix/po011/Main.hs @@ -0,0 +1,22 @@ +import LibPosix + +main = + getGroupEntryForName "grasp" >>= \ grasp -> + getGroupEntryForName "staff" >>= \ staff -> + putStr (ge2String grasp) >> + putChar '\n' >> + putStr (ge2String staff) >> + putChar '\n' >> + getGroupEntryForID (groupID grasp) >>= \ guid -> + getGroupEntryForID (groupID staff) >>= \ suid -> + putStr (ge2String guid) >> + putChar '\n' >> + putStr (ge2String suid) >> + putChar '\n' + +ge2String ge = + name ++ (':' : (show gid) ++ (':' : members)) + where + name = groupName ge + gid = groupID ge + members = foldr (\x y -> x ++ (',' : y)) "" (groupMembers ge)
\ No newline at end of file diff --git a/ghc/misc/examples/posix/po012/Main.hs b/ghc/misc/examples/posix/po012/Main.hs new file mode 100644 index 0000000000..d4eb3841bf --- /dev/null +++ b/ghc/misc/examples/posix/po012/Main.hs @@ -0,0 +1,52 @@ +import LibPosix + +main = + createFile "po012.out" stdFileMode >>= \ fd -> + installHandler processStatusChanged (Catch (reap1 fd)) Nothing >> + ls >> + awaitSignal Nothing + +ls = + runProcess "ls" ["-l","po012.out"] Nothing Nothing Nothing Nothing Nothing + +reap1 fd = + getAnyProcessStatus True False >> + installHandler processStatusChanged (Catch (reap2 fd)) Nothing >> + writeChannel fd (take 666 (repeat 'x')) >> + ls >> + awaitSignal Nothing + +reap2 fd = + getAnyProcessStatus True False >> + installHandler processStatusChanged (Catch (reap3 fd)) Nothing >> + setFileMode "po012.out" + (foldr1 unionFileModes [ownerReadMode,ownerWriteMode,groupReadMode,otherReadMode]) >> + ls >> + awaitSignal Nothing + +reap3 fd = + getAnyProcessStatus True False >> + installHandler processStatusChanged (Catch (reap4 fd)) Nothing >> + setFileTimes "po012.out" 0 0 >> + ls >> + awaitSignal Nothing + +reap4 fd = + getAnyProcessStatus True False >> + installHandler processStatusChanged (Catch (reap5 fd)) Nothing >> + removeLink "po012.out" >> + ls >> + awaitSignal Nothing + +reap5 fd = + getAnyProcessStatus True False >> + seekChannel fd SeekFromEnd 0 >>= \ bytes -> + if bytes == 666 then + seekChannel fd AbsoluteSeek 0 >> + readChannel fd 1024 >>= \ (str, _) -> + if str == (take 666 (repeat 'x')) then + putStr "Okay\n" + else + putStr "Read failed\n" + else + putStr "Seek returned wrong size\n" diff --git a/ghc/misc/spat-analysers/README b/ghc/misc/spat-analysers/README new file mode 100644 index 0000000000..9165665f30 --- /dev/null +++ b/ghc/misc/spat-analysers/README @@ -0,0 +1,22 @@ +This directory (ghc/misc/spat-analysers) includes the source for +"analysers" to use with the SPAT (SPARC Performance Analysis Tools?) +system, which includes "shade", "shadow", and "spixtools". + +The analysers here are no actual use to you unless you have the SPAT +system from Sun. Bob Cmelik was the ringleader at Sun for quite +some time. The current person to contact about it is: + + John Rodriguez + Sun Microsystems Laboratories, Inc. + 2550 Garcia Avenue, MS 29-225 + Mountain View, CA 94043 + (415) 336-1709 + john.rodriguez@sun.com + +We are supplying these analysers so you can see the Cool Things you +can do with them, in the hope that you will be motivated to build upon +our work. + +Will Partain +AQUA Project +95/07/18 diff --git a/ghc/misc/spat-analysers/REGSTATS b/ghc/misc/spat-analysers/REGSTATS new file mode 100644 index 0000000000..8dc860dafe --- /dev/null +++ b/ghc/misc/spat-analysers/REGSTATS @@ -0,0 +1,18 @@ +Final: +SpA 0 0 +SpB 0 0 +Hp 0 0 +HpLim 0 0 +SuA 0 0 +SuB 0 0 +UpdReg 0 0 +RetVecReg 0 0 +TagReg 0 0 +Ret1 0 0 +Ret2 0 0 +Ret3 0 0 +Ret4 0 0 +Ret5 0 0 +Ret6 0 0 +Ret7 0 0 +Ret8 0 0 diff --git a/ghc/misc/spat-analysers/StgRegAddrs.h b/ghc/misc/spat-analysers/StgRegAddrs.h new file mode 100644 index 0000000000..2aa81fc81e --- /dev/null +++ b/ghc/misc/spat-analysers/StgRegAddrs.h @@ -0,0 +1,19 @@ +/* Produced from: nm -n */ + +#define UpdReg 0x00b5098 +#define SpA 0x00b50a0 +#define SuA 0x00b50a8 +#define SuB 0x00b50b0 +#define SpB 0x00b50b8 +#define Ret1 0x00b50e8 +#define Ret2 0x00b50f0 +#define Ret3 0x00b50f8 +#define HpLim 0x00b5100 +#define Hp 0x00b5108 +#define RetVecReg 0x00b5110 +#define TagReg 0x00b5118 +#define Ret5 0x00b5120 +#define Ret4 0x00b5130 +#define Ret6 0x00b5138 +#define Ret7 0x00b5140 +#define Ret8 0x00b5148 diff --git a/ghc/misc/spat-analysers/icount.c b/ghc/misc/spat-analysers/icount.c new file mode 100644 index 0000000000..e47bd11d73 --- /dev/null +++ b/ghc/misc/spat-analysers/icount.c @@ -0,0 +1,91 @@ +#define VERSION "24-Jan-94" +#define PROGNAME "ICount" + +#define SHADE + +#include <stdio.h> + +#include <IHASH.h> +#include <ITYPES.h> +#include <instr.h> +#include <inames.h> + +#include <shade.h> +#define TR_REGS +#include <trace.h> +#include <stdtr.h> +#include <trctl.h> + +static long long info[NIHASH]; + +#define STATS_FILE "ICNT" + +/* fwd decls */ +void print_results(); + +#define CHECKPOINT 1000000 /* reporting frequency */ +static long countdown = CHECKPOINT; + +char *anal_usage = ""; +char *anal_version = VERSION; + +initialize(argc,argv,envp) + int argc; + char **argv, envp; +{ + unsigned i, j; + + /* Setup the trace */ + shade_trctl_trsize(sizeof(Trace)); + + shade_trctl_it (IT_ANY, 1, 0, TC_IH); + + /* init table */ + for (j = 0; j < NIHASH; j++) + info[j] = 0LL; +} + +int analyze(argc,argv,envp) + int argc; + char **argv, envp; +{ + Trace *tr; + int i; + + for (i = 0; tr = shade_step(); i++) { + + info[tr->tr_ih] += 1LL; + + if (countdown-- < 0) { + print_results("Intermediate:"); + countdown = CHECKPOINT; + } + } + return(0); +} + +void +terminate() +{ + print_results("Final:"); +} + +void +print_results(header) + char *header; +{ + int i, j; + static FILE *statf = NULL; + + if ((statf = fopen("ICNT", "w")) == NULL) { + fprintf(stderr, "Cannot open statistics file ICNT\n"); + exit(1); + } + fprintf(statf, "%s\n\n", header); + + for (i = 0; i < NIHASH; i++) { + fprintf(statf, "%8x: %8ld\n", i, (long) info[i]); + } + + fclose(statf); +} diff --git a/ghc/misc/spat-analysers/icount_by_activity.c b/ghc/misc/spat-analysers/icount_by_activity.c new file mode 100644 index 0000000000..84daf6f8a9 --- /dev/null +++ b/ghc/misc/spat-analysers/icount_by_activity.c @@ -0,0 +1,396 @@ +#define VERSION "24-Jan-95" +#define PROGNAME "ICountByActivity" + +#define SHADE + +#include <stdio.h> + +#include <IHASH.h> +#include <ITYPES.h> +#include <instr.h> +#include <inames.h> + +#include <shade.h> +#define TR_REGS +#include <trace.h> +#include <stdtr.h> +#include <trctl.h> + +int shade_run(Trace *, int); + +#define DO_SPAT_PROFILING +#define __STG_USING_ULLONG__ +#include "stgdefs.h" /* GHC ticky-counting stuff */ +#define ACTIVITY_REG I_REG_g5 +#define SpA_REG I_REG_i0 +#define SpB_REG I_REG_i2 +#define Hp_REG I_REG_i4 +#define RET_REG I_REG_l0 +#define NODE_REG I_REG_l1 +#define INFO_REG I_REG_l2 +#define R3_REG I_REG_l3 +#define R7_REG I_REG_l7 + +/* Activity register and current activity */ + +#define EACT_CALL (ACTIVITIES+0) +#define EACT_STKADJ (ACTIVITIES+1) +#define EACT_ASTK (ACTIVITIES+2) +#define EACT_BSTK (ACTIVITIES+3) +#define EACT_RETREG (ACTIVITIES+4) +#define EACT_ARGREGS (ACTIVITIES+5) + +#define EACT_TAILCALL (ACT_TAILCALL - ACT_BASE) /* use the TAILCALL slot */ +#define EACT_OVERHEAD (ACT_OVERHEAD - ACT_BASE) /* only used herein */ + +#define EXTRA_ACTIVITIES 6 + +#define TOTAL_ACTIVITIES (ACTIVITIES+EXTRA_ACTIVITIES) + +static ullong info[TOTAL_ACTIVITIES][NIHASH]; +/*static ullong annulled_insns = 0;*/ + +#define STATS_FILE "ICNT_BY_ACTIVITY" + +/* fwd decls */ +void print_results(char *); +void fprintf_ullong(FILE *, ullong); + +#define CHECKPOINT (1024*1024) /* reporting frequency */ +static long countdown = CHECKPOINT; + +char *anal_usage = ""; +char *anal_version = VERSION; + +void +initialize(argc,argv,envp) + int argc; + char **argv, envp; +{ + unsigned i, j; + + /* Setup the trace */ + shade_trctl_trsize(sizeof(Trace)); + + shade_trctl_it (IT_ANY, 1, 0, TC_I | TC_IH); + shade_trctl_ih (IH_OR, 1, 0, TC_I | TC_IH | TC_RD); + shade_trctl_ih (IH_ADD, 1, 0, TC_I | TC_IH | TC_RD | TC_RS1); + shade_trctl_ih (IH_SETHI, 1, 0, TC_I | TC_IH | TC_RD); + shade_trctl_it (IT_LOAD, 1, 0, TC_I | TC_IH | TC_RD | TC_RS1); + shade_trctl_it (IT_ILOAD, 1, 0, TC_I | TC_IH | TC_RD | TC_RS1); + shade_trctl_it (IT_STORE, 1, 0, TC_I | TC_IH | TC_RD | TC_RS1); + shade_trctl_it (IT_ISTORE,1, 0, TC_I | TC_IH | TC_RD | TC_RS1); + /* trace all non-annulled instructions (... 1, 0, ...); For + them, we want the instruction text (TC_I), and the hashed + opcode (TC_IH). For "or" instructions, we also want the + contents the destination register that was written into + (TC_RD). Etc. + */ + + /* init table */ + for (i = 0; i < TOTAL_ACTIVITIES; i++) + for (j = 0; j < NIHASH; j++) + info[i][j] = 0LL; +} + +int analyze(argc,argv,envp) + int argc; + char **argv, envp; +{ + Trace *tr; + ullong i; + uint16 ih; + int32 rd, rs1; + + unsigned activity = (ACT_UNKNOWN - ACT_BASE); + ullong pending_sethi = 0LL; + ullong pending_or = 0LL; + ullong activity_chgs = 0LL; + int acctd_for; +#define ACCT_FOR() acctd_for = 1 + + for (i = 0LL; tr = shade_step(); i += 1LL) { + acctd_for = 0; + ih = tr->tr_ih; + + if ( ih == IH_OR && tr->tr_i.i_rd == ACTIVITY_REG) { + rd = tr->tr_rd; + + info[EACT_TAILCALL][IH_OR] += pending_or; + if ( pending_sethi ) { + fprintf(stderr, "pending_sethi still set!\n"); + } + + if (activity == (ACT_GC - ACT_BASE)) { /* only GC_STOP will stop it */ + if (rd == ACT_GC_STOP) { + activity = ACT_UNKNOWN - ACT_BASE; + info[EACT_OVERHEAD][IH_OR] += 1LL; + ACCT_FOR(); + } else { + info[activity][IH_OR] += 1LL; + ACCT_FOR(); + } + } else { + if (rd < ACT_BASE || rd >= (ACT_BASE+ACTIVITIES)) { + info[activity][IH_OR] += 1LL; + ACCT_FOR(); + } else { + activity = rd - ACT_BASE; /* reset! */ + info[EACT_OVERHEAD][IH_OR] += 1LL; + ACCT_FOR(); + } + } + activity_chgs += 1LL; + pending_sethi = 0LL; + pending_or = 0LL; + /* reset other things? */ + + } else if ( activity != EACT_TAILCALL ) { /* ordinary instruction */ + info[activity][ih] += 1LL; + ACCT_FOR(); + + } else { /* TAILCALLing */ +/* fprintf(stderr, "op=%d\n", ih); */ + + switch (ih) { + case IH_SETHI: +/* if ( pending_sethi ) { + fprintf(stderr, "pending_sethi already set!\n"); + } +*/ pending_sethi += 1LL; + ACCT_FOR(); + break; + case IH_JMPL: + case IH_CALL: + case IH_NOP: + info[EACT_CALL][ih] += 1LL; + info[EACT_CALL][IH_SETHI] += pending_sethi; /* really mystery? */ + info[EACT_CALL][IH_OR] += pending_or; /* ditto? */ + pending_sethi = 0LL; + pending_or = 0LL; + ACCT_FOR(); + break; + + case IH_ADD: + case IH_ADDCC: + case IH_SUB: + case IH_SUBCC: + rd = tr->tr_i.i_rd; + rs1 = tr->tr_i.i_rs1; + if ( rd == NODE_REG || rd == INFO_REG ) { + info[EACT_CALL][ih] += 1LL; + info[EACT_CALL][IH_SETHI] += pending_sethi; + info[EACT_CALL][IH_OR] += pending_or; + pending_sethi = 0LL; + pending_or = 0LL; + ACCT_FOR(); + + } else if (rd >= R3_REG && rd <= R7_REG) { + info[EACT_ARGREGS][ih] += 1LL; + info[EACT_ARGREGS][IH_SETHI] += pending_sethi; + info[EACT_ARGREGS][IH_OR] += pending_or; + pending_sethi = 0LL; + pending_or = 0LL; + ACCT_FOR(); + + } else { + info[EACT_TAILCALL][IH_SETHI] += pending_sethi; + info[EACT_TAILCALL][IH_OR] += pending_or; + pending_sethi = 0LL; + pending_or = 0LL; + + if ( (rd == SpA_REG && rs1 == SpA_REG) + || (rd == SpB_REG && rs1 == SpB_REG) ) { + info[EACT_STKADJ][ih] += 1LL; + ACCT_FOR(); + + } else if ( rd >= I_REG_o0 && rd <= I_REG_o7 ) { + info[EACT_TAILCALL][ih] += 1LL; + ACCT_FOR(); + + } else if ( rd == I_REG_g0 + && rs1 >= I_REG_o0 && rs1 <= I_REG_o7 ) { + info[EACT_TAILCALL][ih] += 1LL; + ACCT_FOR(); + + } else if ( rd == I_REG_g3 && rs1 == I_REG_g3 ) { + info[EACT_TAILCALL][ih] += 1LL; + ACCT_FOR(); + + } else { + fprintf(stderr, "IH_ADD: mystery op (%d) rd=%d rs1=%d\n", + ih, rd, rs1); + } + } + break; + + case IH_OR: + case IH_ORCC: + rd = tr->tr_i.i_rd; + if ( rd == RET_REG ) { + info[EACT_RETREG][ih] += 1LL + pending_or; + info[EACT_RETREG][IH_SETHI] += pending_sethi; + pending_sethi = 0LL; + pending_or = 0LL; + ACCT_FOR(); + + } else if ( rd == NODE_REG || rd == INFO_REG ) { + info[EACT_CALL][ih] += 1LL + pending_or; + info[EACT_CALL][IH_SETHI] += pending_sethi; + pending_sethi = 0LL; + pending_or = 0LL; + ACCT_FOR(); + + } else { + pending_or += 1LL; + ACCT_FOR(); + } + break; + + case IH_LD: + case IH_LDUB: /* ??? */ + case IH_ST: + rs1 = tr->tr_i.i_rs1; + if ( rs1 == SpA_REG ) { + info[EACT_ASTK][ih] += 1LL; + info[EACT_ASTK][IH_SETHI] += pending_sethi; + info[EACT_ASTK][IH_OR] += pending_or; + pending_sethi = 0LL; + pending_or = 0LL; + ACCT_FOR(); + + } else if ( rs1 == SpB_REG ) { + info[EACT_BSTK][ih] += 1LL; + info[EACT_BSTK][IH_SETHI] += pending_sethi; + info[EACT_BSTK][IH_OR] += pending_or; + pending_sethi = 0LL; + pending_or = 0LL; + ACCT_FOR(); + + } else if ( rs1 == NODE_REG ) { + info[EACT_CALL][ih] += 1LL; + info[EACT_CALL][IH_SETHI] += pending_sethi; + info[EACT_CALL][IH_OR] += pending_or; + pending_sethi = 0LL; + pending_or = 0LL; + ACCT_FOR(); + + } else { /* random ld/st */ + info[EACT_TAILCALL][ih] += 1LL; + info[EACT_TAILCALL][IH_SETHI] += pending_sethi; + info[EACT_TAILCALL][IH_OR] += pending_or; + pending_sethi = 0LL; + pending_or = 0LL; + ACCT_FOR(); + } + break; + + case IH_AND: /* ??? */ + case IH_BA: /* ??? */ + case IH_BAA: + case IH_BCC: + case IH_BCS: + case IH_BE: + case IH_BGE: + case IH_BL: + case IH_BLA: + case IH_BLEU: + case IH_BNE: + case IH_SLL: + case IH_SRL: + case IH_XOR: + info[EACT_TAILCALL][ih] += 1LL; + info[EACT_TAILCALL][IH_SETHI] += pending_sethi; + info[EACT_TAILCALL][IH_OR] += pending_or; + pending_sethi = 0LL; + pending_or = 0LL; + ACCT_FOR(); + break; + + default: + fprintf(stderr, "mystery TAIL op = %d\n", ih); + break; + } + } + + if (countdown-- < 0) { + print_results("Intermediate:"); + countdown = CHECKPOINT; + } + if ( ! acctd_for ) { + fprintf(stderr, "insn op=%d not acctd for!\n", ih); + } + } + fprintf(stderr,"\n"); + fprintf_ullong(stderr,i); + fprintf(stderr," iterations; "); + fprintf_ullong(stderr,activity_chgs); + fprintf(stderr," activity changes\n"); + return(0); +} + +void +terminate() +{ + print_results("Final:"); +} + +void +print_results(header) + char *header; +{ + int i, j; + long total_slots = 0; + ullong total_instrs = 0; + static FILE *statf = NULL; + +/* fprintf(stderr, "Printing %s\n", header); */ + + unlink(STATS_FILE); + if ((statf = fopen(STATS_FILE, "w")) == NULL) { + fprintf(stderr, "Cannot open statistics file %s\n",STATS_FILE); + exit(1); + } + fprintf(statf, "%s\n\n", header); +/* fprintf(statf, "annulled insns = "); + fprintf_ullong(statf, annulled_insns); +*/ fprintf(statf, "\n\n"); + + for (i = 0; i < NIHASH; i++) { + fprintf(statf, "%8d:", i); + for (j = 0; j < TOTAL_ACTIVITIES; j++) { + fprintf(statf, " "); + fprintf_ullong(statf, info[j][i]); + total_slots++; + total_instrs += info[j][i]; + } + fprintf(statf, "\n"); + } + fprintf(statf, "total slots=%ld, total instructions=", total_slots); + fprintf_ullong(statf, total_instrs); + fprintf(statf, "\n"); + + fclose(statf); +} + +void +fprintf_ullong(FILE *filep, ullong x) +{ + if (x < (ullong)1000) + fprintf(filep, "%ld", (I_)x); + else if (x < (ullong)1000000) + fprintf(filep, "%ld%3.3ld", + (I_)((x)/(ullong)1000), + (I_)((x)%(ullong)1000)); + else if (x < (ullong)1000000000) + fprintf(filep, "%ld%3.3ld%3.3ld", + (I_)((x)/(ullong)1000000), + (I_)((x)/(ullong)1000%(ullong)1000), + (I_)((x)%(ullong)1000)); + else + fprintf(filep, "%ld%3.3ld%3.3ld%3.3ld", + (I_)((x)/(ullong)1000000000), + (I_)((x)/(ullong)1000000%(ullong)1000), + (I_)((x)/(ullong)1000%(ullong)1000), + (I_)((x)%(ullong)1000)); +} diff --git a/ghc/misc/spat-analysers/makefile b/ghc/misc/spat-analysers/makefile new file mode 100644 index 0000000000..652f9df04d --- /dev/null +++ b/ghc/misc/spat-analysers/makefile @@ -0,0 +1,19 @@ +# SHADE presumably set by an environment variable +# +SPIX = ${SHADE}/spixtools +# +SHADE_L = ${SHADE}/lib +SPIX_L = ${SPIX}/lib + +SHADE_H = ${SHADE}/src/include +SPIX_H = ${SPIX}/src/include +GHC_H = ${bghc}/includes + +CC=gcc +CFLAGS = -I${GHC_H} -I${SHADE_H} -I${SPIX_H} -g -O -ansi + +.c.o: + ${CC} ${CFLAGS} -c $*.c + +.o: + ${CC} -static -o $* spatmain.o $*.o ${SHADE_L}/libshade.a ${SPIX_L}/libspix.a diff --git a/ghc/misc/spat-analysers/show_icounts b/ghc/misc/spat-analysers/show_icounts new file mode 100644 index 0000000000..faca1f2a22 --- /dev/null +++ b/ghc/misc/spat-analysers/show_icounts @@ -0,0 +1,354 @@ +#! /usr/local/bin/perl +# +%Datum = (); + +&init(); + +$BigTotal = 0; + +while (<>) { + chop; + next if ! /^\s*(\d+): (.*)/; + $op_code = $1; + @num = split(/\s+/, $2); + + $op_category = $Opcode2Cat{$op_code}; + + die "num = $#num\n" if $#num != 21; + + for($i = 0; $i <= $#num; $i++) { + next if $num[$i] == 0; + + $act = $ActivityName[$i]; + + $Datum{"$act/$op_category"} += $num[$i]; + $TotPerCat{$op_category} += $num[$i]; + $BigTotal += $num[$i]; + } +} + +#print a header +printf STDOUT "%12s", ""; +foreach $opcat (@ListOfCats) { printf STDOUT " %11s", $opcat; } +printf STDOUT " %11s %s\n", 'TOTAL', " \%age"; + +# print the collected goods +%tot_for_opcat = (); +foreach $act ( @ListOfActivities ) { + printf STDOUT "%-12s", $act; + $tot_for_act = 0; + + foreach $opcat (@ListOfCats) { + $datum = $Datum{"$act/$opcat"}; + printf STDOUT " %11s", &commas($datum); + $tot_for_act += $datum; + $tot_for_opcat{$opcat} += $datum; + } + printf STDOUT "%12s %5.1f%%\n", &commas($tot_for_act), (($tot_for_act / $BigTotal) * 100.0); +} + +foreach $k ( keys %TotPerCat ) { + die "category ($k) totals don't match: $TotPerCat{$k} != $tot_for_opcat{$k}\n" + if $TotPerCat{$k} != $tot_for_opcat{$k}; +} +foreach $k ( keys %tot_for_opcat ) { + die "category ($k) totals don't match: $TotPerCat{$k} != $tot_for_opcat{$k}\n" + if $TotPerCat{$k} != $tot_for_opcat{$k}; +} + +#print totals by category and percentages +printf STDOUT "\n%-12s", '*Totals*'; +$tot_to_chk = 0; +foreach $opcat (@ListOfCats) { + printf STDOUT " %11s", &commas($TotPerCat{$opcat}); + $tot_to_chk += $TotPerCat{$opcat}; +} + +printf STDOUT "%12s\n%-12s", &commas($BigTotal), ''; + +die "Totals don't match: $tot_to_chk != $BigTotal\n" if $tot_to_chk != $BigTotal; + +foreach $opcat (@ListOfCats) { + printf STDOUT " %10.1f%%", (($TotPerCat{$opcat} / $BigTotal) * 100.0); +} +printf STDOUT "\n"; + +# utils: + +sub commas { # put commas into long integer numbers + local($_) = @_; + + s/^\+//; + + s/(\d)(\d\d\d)$/$1,$2/; + while ( /\d\d\d\d,/ ) { + s/(\d)(\d\d\d)\,/$1,$2,/; + } + $_; +} + +sub init { + # order is important! + @ActivityName = ( 'UNKNOWN', 'GC', 'OTHER_REDN', 'ASTK_STUB', + 'FILL_IN_HEAP', 'HEAP_CHK', 'RETURN', + 'UPDATE', 'PUSH_UPDF', 'ARGS_CHK', 'UPDATE_PAP', + 'INDIRECT', 'XXX_12', 'XXX_13', 'OVERHEAD', 'TAILCALL', + 'CALL', 'STKADJ', 'ASTK', 'BSTK', 'RETREG', 'ARGREGS' ); + + @ListOfActivities = ( # print order + 'ASTK_STUB', 'FILL_IN_HEAP', 'HEAP_CHK', + 'RETURN', 'TAILCALL', 'UPDATE', 'PUSH_UPDF', 'UPDATE_PAP', + 'INDIRECT', 'ARGS_CHK', + 'CALL', 'STKADJ', 'ASTK', 'BSTK', 'RETREG', 'ARGREGS', + 'OTHER_REDN', 'GC', 'UNKNOWN', 'OVERHEAD' ); + + @ListOfCats = ('LD', 'ST', 'ARITH', 'BR', 'SETHI', 'NOP', 'OTHER'); # 'FL-PT', + %Opcode2Cat = (); + + $Opcode2Cat{'0'} = 'ARITH'; # IH_ADD + $Opcode2Cat{'1'} = 'ARITH'; # IH_ADDCC + $Opcode2Cat{'2'} = 'ARITH'; # IH_ADDX + $Opcode2Cat{'3'} = 'ARITH'; # IH_ADDXCC + $Opcode2Cat{'4'} = 'ARITH'; # IH_AND + $Opcode2Cat{'5'} = 'ARITH'; # IH_ANDCC + $Opcode2Cat{'6'} = 'ARITH'; # IH_ANDN + $Opcode2Cat{'7'} = 'ARITH'; # IH_ANDNCC + $Opcode2Cat{'8'} = 'BR'; # IH_BA + $Opcode2Cat{'9'} = 'BR'; # IH_BAA + $Opcode2Cat{'10'} = 'BR'; # IH_BCC + $Opcode2Cat{'11'} = 'BR'; # IH_BCCA + $Opcode2Cat{'12'} = 'BR'; # IH_BCS + $Opcode2Cat{'13'} = 'BR'; # IH_BCSA + $Opcode2Cat{'14'} = 'BR'; # IH_BE + $Opcode2Cat{'15'} = 'BR'; # IH_BEA + $Opcode2Cat{'16'} = 'BR'; # IH_BG + $Opcode2Cat{'17'} = 'BR'; # IH_BGA + $Opcode2Cat{'18'} = 'BR'; # IH_BGE + $Opcode2Cat{'19'} = 'BR'; # IH_BGEA + $Opcode2Cat{'20'} = 'BR'; # IH_BGU + $Opcode2Cat{'21'} = 'BR'; # IH_BGUA + $Opcode2Cat{'22'} = 'BR'; # IH_BL + $Opcode2Cat{'23'} = 'BR'; # IH_BLA + $Opcode2Cat{'24'} = 'BR'; # IH_BLE + $Opcode2Cat{'25'} = 'BR'; # IH_BLEA + $Opcode2Cat{'26'} = 'BR'; # IH_BLEU + $Opcode2Cat{'27'} = 'BR'; # IH_BLEUA + $Opcode2Cat{'28'} = 'BR'; # IH_BN + $Opcode2Cat{'29'} = 'BR'; # IH_BNA + $Opcode2Cat{'30'} = 'BR'; # IH_BNE + $Opcode2Cat{'31'} = 'BR'; # IH_BNEA + $Opcode2Cat{'32'} = 'BR'; # IH_BNEG + $Opcode2Cat{'33'} = 'BR'; # IH_BNEGA + $Opcode2Cat{'34'} = 'BR'; # IH_BPOS + $Opcode2Cat{'35'} = 'BR'; # IH_BPOSA + $Opcode2Cat{'36'} = 'BR'; # IH_BVC + $Opcode2Cat{'37'} = 'BR'; # IH_BVCA + $Opcode2Cat{'38'} = 'BR'; # IH_BVS + $Opcode2Cat{'39'} = 'BR'; # IH_BVSA + $Opcode2Cat{'40'} = 'BR'; # IH_CALL + $Opcode2Cat{'41'} = 'OTHER'; # IH_CB0 + $Opcode2Cat{'42'} = 'OTHER'; # IH_CB0A + $Opcode2Cat{'43'} = 'OTHER'; # IH_CB01 + $Opcode2Cat{'44'} = 'OTHER'; # IH_CB01A + $Opcode2Cat{'45'} = 'OTHER'; # IH_CB012 + $Opcode2Cat{'46'} = 'OTHER'; # IH_CB012A + $Opcode2Cat{'47'} = 'OTHER'; # IH_CB013 + $Opcode2Cat{'48'} = 'OTHER'; # IH_CB013A + $Opcode2Cat{'49'} = 'OTHER'; # IH_CB02 + $Opcode2Cat{'50'} = 'OTHER'; # IH_CB02A + $Opcode2Cat{'51'} = 'OTHER'; # IH_CB023 + $Opcode2Cat{'52'} = 'OTHER'; # IH_CB023A + $Opcode2Cat{'53'} = 'OTHER'; # IH_CB03 + $Opcode2Cat{'54'} = 'OTHER'; # IH_CB03A + $Opcode2Cat{'55'} = 'OTHER'; # IH_CB1 + $Opcode2Cat{'56'} = 'OTHER'; # IH_CB1A + $Opcode2Cat{'57'} = 'OTHER'; # IH_CB12 + $Opcode2Cat{'58'} = 'OTHER'; # IH_CB12A + $Opcode2Cat{'59'} = 'OTHER'; # IH_CB123 + $Opcode2Cat{'60'} = 'OTHER'; # IH_CB123A + $Opcode2Cat{'61'} = 'OTHER'; # IH_CB13 + $Opcode2Cat{'62'} = 'OTHER'; # IH_CB13A + $Opcode2Cat{'63'} = 'OTHER'; # IH_CB2 + $Opcode2Cat{'64'} = 'OTHER'; # IH_CB2A + $Opcode2Cat{'65'} = 'OTHER'; # IH_CB23 + $Opcode2Cat{'66'} = 'OTHER'; # IH_CB23A + $Opcode2Cat{'67'} = 'OTHER'; # IH_CB3 + $Opcode2Cat{'68'} = 'OTHER'; # IH_CB3A + $Opcode2Cat{'69'} = 'OTHER'; # IH_CBA + $Opcode2Cat{'70'} = 'OTHER'; # IH_CBAA + $Opcode2Cat{'71'} = 'OTHER'; # IH_CBN + $Opcode2Cat{'72'} = 'OTHER'; # IH_CBNA + $Opcode2Cat{'73'} = 'OTHER'; # IH_CPOP1 + $Opcode2Cat{'74'} = 'OTHER'; # IH_CPOP2 + $Opcode2Cat{'75'} = 'OTHER'; # 'FL-PT'; # IH_FABSS + $Opcode2Cat{'76'} = 'OTHER'; # 'FL-PT'; # IH_FADDD + $Opcode2Cat{'77'} = 'OTHER'; # 'FL-PT'; # IH_FADDQ + $Opcode2Cat{'78'} = 'OTHER'; # 'FL-PT'; # IH_FADDS + $Opcode2Cat{'79'} = 'OTHER'; # 'FL-PT'; # IH_FBA + $Opcode2Cat{'80'} = 'OTHER'; # 'FL-PT'; # IH_FBAA + $Opcode2Cat{'81'} = 'OTHER'; # 'FL-PT'; # IH_FBE + $Opcode2Cat{'82'} = 'OTHER'; # 'FL-PT'; # IH_FBEA + $Opcode2Cat{'83'} = 'OTHER'; # 'FL-PT'; # IH_FBG + $Opcode2Cat{'84'} = 'OTHER'; # 'FL-PT'; # IH_FBGA + $Opcode2Cat{'85'} = 'OTHER'; # 'FL-PT'; # IH_FBGE + $Opcode2Cat{'86'} = 'OTHER'; # 'FL-PT'; # IH_FBGEA + $Opcode2Cat{'87'} = 'OTHER'; # 'FL-PT'; # IH_FBL + $Opcode2Cat{'88'} = 'OTHER'; # 'FL-PT'; # IH_FBLA + $Opcode2Cat{'89'} = 'OTHER'; # 'FL-PT'; # IH_FBLE + $Opcode2Cat{'90'} = 'OTHER'; # 'FL-PT'; # IH_FBLEA + $Opcode2Cat{'91'} = 'OTHER'; # 'FL-PT'; # IH_FBLG + $Opcode2Cat{'92'} = 'OTHER'; # 'FL-PT'; # IH_FBLGA + $Opcode2Cat{'93'} = 'OTHER'; # 'FL-PT'; # IH_FBN + $Opcode2Cat{'94'} = 'OTHER'; # 'FL-PT'; # IH_FBNA + $Opcode2Cat{'95'} = 'OTHER'; # 'FL-PT'; # IH_FBNE + $Opcode2Cat{'96'} = 'OTHER'; # 'FL-PT'; # IH_FBNEA + $Opcode2Cat{'97'} = 'OTHER'; # 'FL-PT'; # IH_FBO + $Opcode2Cat{'98'} = 'OTHER'; # 'FL-PT'; # IH_FBOA + $Opcode2Cat{'99'} = 'OTHER'; # 'FL-PT'; # IH_FBU + $Opcode2Cat{'100'} = 'OTHER'; # 'FL-PT'; # IH_FBUA + $Opcode2Cat{'101'} = 'OTHER'; # 'FL-PT'; # IH_FBUE + $Opcode2Cat{'102'} = 'OTHER'; # 'FL-PT'; # IH_FBUEA + $Opcode2Cat{'103'} = 'OTHER'; # 'FL-PT'; # IH_FBUG + $Opcode2Cat{'104'} = 'OTHER'; # 'FL-PT'; # IH_FBUGA + $Opcode2Cat{'105'} = 'OTHER'; # 'FL-PT'; # IH_FBUGE + $Opcode2Cat{'106'} = 'OTHER'; # 'FL-PT'; # IH_FBUGEA + $Opcode2Cat{'107'} = 'OTHER'; # 'FL-PT'; # IH_FBUL + $Opcode2Cat{'108'} = 'OTHER'; # 'FL-PT'; # IH_FBULA + $Opcode2Cat{'109'} = 'OTHER'; # 'FL-PT'; # IH_FBULE + $Opcode2Cat{'110'} = 'OTHER'; # 'FL-PT'; # IH_FBULEA + $Opcode2Cat{'111'} = 'OTHER'; # 'FL-PT'; # IH_FCMPD + $Opcode2Cat{'112'} = 'OTHER'; # 'FL-PT'; # IH_FCMPED + $Opcode2Cat{'113'} = 'OTHER'; # 'FL-PT'; # IH_FCMPEQ + $Opcode2Cat{'114'} = 'OTHER'; # 'FL-PT'; # IH_FCMPES + $Opcode2Cat{'115'} = 'OTHER'; # 'FL-PT'; # IH_FCMPQ + $Opcode2Cat{'116'} = 'OTHER'; # 'FL-PT'; # IH_FCMPS + $Opcode2Cat{'117'} = 'OTHER'; # 'FL-PT'; # IH_FDIVD + $Opcode2Cat{'118'} = 'OTHER'; # 'FL-PT'; # IH_FDIVQ + $Opcode2Cat{'119'} = 'OTHER'; # 'FL-PT'; # IH_FDIVS + $Opcode2Cat{'120'} = 'OTHER'; # 'FL-PT'; # IH_FDMULQ + $Opcode2Cat{'121'} = 'OTHER'; # 'FL-PT'; # IH_FDTOI + $Opcode2Cat{'122'} = 'OTHER'; # 'FL-PT'; # IH_FDTOQ + $Opcode2Cat{'123'} = 'OTHER'; # 'FL-PT'; # IH_FDTOS + $Opcode2Cat{'124'} = 'OTHER'; # 'FL-PT'; # IH_FITOD + $Opcode2Cat{'125'} = 'OTHER'; # 'FL-PT'; # IH_FITOQ + $Opcode2Cat{'126'} = 'OTHER'; # 'FL-PT'; # IH_FITOS + $Opcode2Cat{'127'} = 'OTHER'; # IH_FLUSH + $Opcode2Cat{'128'} = 'OTHER'; # 'FL-PT'; # IH_FMOVS + $Opcode2Cat{'129'} = 'OTHER'; # 'FL-PT'; # IH_FMULD + $Opcode2Cat{'130'} = 'OTHER'; # 'FL-PT'; # IH_FMULQ + $Opcode2Cat{'131'} = 'OTHER'; # 'FL-PT'; # IH_FMULS + $Opcode2Cat{'132'} = 'OTHER'; # 'FL-PT'; # IH_FNEGS + $Opcode2Cat{'133'} = 'OTHER'; # 'FL-PT'; # IH_FQTOD + $Opcode2Cat{'134'} = 'OTHER'; # 'FL-PT'; # IH_FQTOI + $Opcode2Cat{'135'} = 'OTHER'; # 'FL-PT'; # IH_FQTOS + $Opcode2Cat{'136'} = 'OTHER'; # 'FL-PT'; # IH_FSMULD + $Opcode2Cat{'137'} = 'OTHER'; # 'FL-PT'; # IH_FSQRTD + $Opcode2Cat{'138'} = 'OTHER'; # 'FL-PT'; # IH_FSQRTQ + $Opcode2Cat{'139'} = 'OTHER'; # 'FL-PT'; # IH_FSQRTS + $Opcode2Cat{'140'} = 'OTHER'; # 'FL-PT'; # IH_FSTOD + $Opcode2Cat{'141'} = 'OTHER'; # 'FL-PT'; # IH_FSTOI + $Opcode2Cat{'142'} = 'OTHER'; # 'FL-PT'; # IH_FSTOQ + $Opcode2Cat{'143'} = 'OTHER'; # 'FL-PT'; # IH_FSUBD + $Opcode2Cat{'144'} = 'OTHER'; # 'FL-PT'; # IH_FSUBQ + $Opcode2Cat{'145'} = 'OTHER'; # 'FL-PT'; # IH_FSUBS + $Opcode2Cat{'146'} = 'BR'; # IH_JMPL + $Opcode2Cat{'147'} = 'LD'; # IH_LD + $Opcode2Cat{'148'} = 'LD'; # IH_LDA + $Opcode2Cat{'149'} = 'LD'; # IH_LDC + $Opcode2Cat{'150'} = 'LD'; # IH_LDCSR + $Opcode2Cat{'151'} = 'LD'; # IH_LDD + $Opcode2Cat{'152'} = 'LD'; # IH_LDDA + $Opcode2Cat{'153'} = 'LD'; # IH_LDDC + $Opcode2Cat{'154'} = 'LD'; # IH_LDDF + $Opcode2Cat{'155'} = 'LD'; # IH_LDF + $Opcode2Cat{'156'} = 'LD'; # IH_LDFSR + $Opcode2Cat{'157'} = 'LD'; # IH_LDSB + $Opcode2Cat{'158'} = 'LD'; # IH_LDSBA + $Opcode2Cat{'159'} = 'LD'; # IH_LDSH + $Opcode2Cat{'160'} = 'LD'; # IH_LDSHA + $Opcode2Cat{'161'} = 'LD'; # IH_LDSTUB + $Opcode2Cat{'162'} = 'LD'; # IH_LDSTUBA + $Opcode2Cat{'163'} = 'LD'; # IH_LDUB + $Opcode2Cat{'164'} = 'LD'; # IH_LDUBA + $Opcode2Cat{'165'} = 'LD'; # IH_LDUH + $Opcode2Cat{'166'} = 'LD'; # IH_LDUHA + $Opcode2Cat{'167'} = 'ARITH'; # IH_MULSCC + $Opcode2Cat{'168'} = 'NOP'; # IH_NOP + $Opcode2Cat{'169'} = 'ARITH'; # IH_OR + $Opcode2Cat{'170'} = 'ARITH'; # IH_ORCC + $Opcode2Cat{'171'} = 'ARITH'; # IH_ORN + $Opcode2Cat{'172'} = 'ARITH'; # IH_ORNCC + $Opcode2Cat{'173'} = 'OTHER'; # IH_RDASR + $Opcode2Cat{'174'} = 'OTHER'; # IH_RDPSR + $Opcode2Cat{'175'} = 'OTHER'; # IH_RDTBR + $Opcode2Cat{'176'} = 'OTHER'; # IH_RDWIM + $Opcode2Cat{'177'} = 'OTHER'; # IH_RDY + $Opcode2Cat{'178'} = 'OTHER'; # IH_RESTORE + $Opcode2Cat{'179'} = 'OTHER'; # IH_RETT + $Opcode2Cat{'180'} = 'OTHER'; # IH_SAVE + $Opcode2Cat{'181'} = 'ARITH'; # IH_SDIV + $Opcode2Cat{'182'} = 'ARITH'; # IH_SDIVCC + $Opcode2Cat{'183'} = 'SETHI'; # IH_SETHI + $Opcode2Cat{'184'} = 'ARITH'; # IH_SLL + $Opcode2Cat{'185'} = 'ARITH'; # IH_SMUL + $Opcode2Cat{'186'} = 'ARITH'; # IH_SMULCC + $Opcode2Cat{'187'} = 'ARITH'; # IH_SRA + $Opcode2Cat{'188'} = 'ARITH'; # IH_SRL + $Opcode2Cat{'189'} = 'ST'; # IH_ST + $Opcode2Cat{'190'} = 'ST'; # IH_STA + $Opcode2Cat{'191'} = 'ST'; # IH_STB + $Opcode2Cat{'192'} = 'ST'; # IH_STBA + $Opcode2Cat{'193'} = 'ST'; # IH_STBAR + $Opcode2Cat{'194'} = 'ST'; # IH_STC + $Opcode2Cat{'195'} = 'ST'; # IH_STCSR + $Opcode2Cat{'196'} = 'ST'; # IH_STD + $Opcode2Cat{'197'} = 'ST'; # IH_STDA + $Opcode2Cat{'198'} = 'ST'; # IH_STDC + $Opcode2Cat{'199'} = 'ST'; # IH_STDCQ + $Opcode2Cat{'200'} = 'ST'; # IH_STDF + $Opcode2Cat{'201'} = 'ST'; # IH_STDFQ + $Opcode2Cat{'202'} = 'ST'; # IH_STF + $Opcode2Cat{'203'} = 'ST'; # IH_STFSR + $Opcode2Cat{'204'} = 'ST'; # IH_STH + $Opcode2Cat{'205'} = 'ST'; # IH_STHA + $Opcode2Cat{'206'} = 'ARITH'; # IH_SUB + $Opcode2Cat{'207'} = 'ARITH'; # IH_SUBCC + $Opcode2Cat{'208'} = 'ARITH'; # IH_SUBX + $Opcode2Cat{'209'} = 'ARITH'; # IH_SUBXCC + $Opcode2Cat{'210'} = 'OTHER'; # IH_SWAP + $Opcode2Cat{'211'} = 'OTHER'; # IH_SWAPA + $Opcode2Cat{'212'} = 'OTHER'; # IH_TA + $Opcode2Cat{'213'} = 'OTHER'; # IH_TADDCC + $Opcode2Cat{'214'} = 'OTHER'; # IH_TADDCCTV + $Opcode2Cat{'215'} = 'OTHER'; # IH_TCC + $Opcode2Cat{'216'} = 'OTHER'; # IH_TCS + $Opcode2Cat{'217'} = 'OTHER'; # IH_TE + $Opcode2Cat{'218'} = 'OTHER'; # IH_TG + $Opcode2Cat{'219'} = 'OTHER'; # IH_TGE + $Opcode2Cat{'220'} = 'OTHER'; # IH_TGU + $Opcode2Cat{'221'} = 'OTHER'; # IH_TL + $Opcode2Cat{'222'} = 'OTHER'; # IH_TLE + $Opcode2Cat{'223'} = 'OTHER'; # IH_TLEU + $Opcode2Cat{'224'} = 'OTHER'; # IH_TN + $Opcode2Cat{'225'} = 'OTHER'; # IH_TNE + $Opcode2Cat{'226'} = 'OTHER'; # IH_TNEG + $Opcode2Cat{'227'} = 'OTHER'; # IH_TPOS + $Opcode2Cat{'228'} = 'OTHER'; # IH_TSUBCC + $Opcode2Cat{'229'} = 'OTHER'; # IH_TSUBCCTV + $Opcode2Cat{'230'} = 'OTHER'; # IH_TVC + $Opcode2Cat{'231'} = 'OTHER'; # IH_TVS + $Opcode2Cat{'232'} = 'ARITH'; # IH_UDIV + $Opcode2Cat{'233'} = 'ARITH'; # IH_UDIVCC + $Opcode2Cat{'234'} = 'ARITH'; # IH_UMUL + $Opcode2Cat{'235'} = 'ARITH'; # IH_UMULCC + $Opcode2Cat{'236'} = 'OTHER'; # IH_UNIMP + $Opcode2Cat{'237'} = 'OTHER'; # IH_WRASR + $Opcode2Cat{'238'} = 'OTHER'; # IH_WRPSR + $Opcode2Cat{'239'} = 'OTHER'; # IH_WRTBR + $Opcode2Cat{'240'} = 'OTHER'; # IH_WRWIM + $Opcode2Cat{'241'} = 'OTHER'; # IH_WRY + $Opcode2Cat{'242'} = 'ARITH'; # IH_XNOR + $Opcode2Cat{'243'} = 'ARITH'; # IH_XNORCC + $Opcode2Cat{'244'} = 'ARITH'; # IH_XOR + $Opcode2Cat{'245'} = 'ARITH'; # IH_XORCC +} diff --git a/ghc/misc/spat-analysers/spatmain.c b/ghc/misc/spat-analysers/spatmain.c new file mode 100644 index 0000000000..2c6ec1912a --- /dev/null +++ b/ghc/misc/spat-analysers/spatmain.c @@ -0,0 +1,243 @@ +#include <stdio.h> +#include <varargs.h> +#include <sys/time.h> +#include <sys/resource.h> + +#define TVTIME(tv) ((tv).tv_sec + (tv).tv_usec / 1e6) + + +extern char *anal_usage, *anal_version, + *shade_bench_path, *shade_ego, *shade_version, + *shade_argtrange(); + +extern char *ctime(); +extern int analyze(); +extern long time(); +extern void exit(), initialize(), terminate(); + + +FILE *statsfp; /* output stats file */ +double nina; /* # non-annulled instructions executed */ + + +static double usr, sys, real; +static int t_flag, + main_stats_analyze(); +static void main_stats_start(), + main_stats_stop(); + + +int +shade_main (argc, argv, envp) + int argc; + char **argv, **envp; +{ + int aargc, ec, i, j, pid = getpid(); + char **aargv, *cmd = 0, *x; + + argc = shade_splitargs (argv, &aargv, &aargc); + + for (i = j = 1; i < argc; i++) + if (argv[i][0] == '-' || + argv[i][0] == '+' && argv[i][1] == 't') + switch (argv[i][1]) { + case 'c': + if (cmd) + usage ("too many -c options"); + if (aargc > 0) + usage ("-c not allowed with --"); + if (argv[i][2] || ++i >= argc) + usage + ("-c: missing/misplaced command"); + cmd = argv[i]; + break; + case 'o': + if (statsfp) + shade_fatal ("too many -o's"); + if (argv[i][2] || ++i >= argc) + usage + ("-o: missing/misplaced file name"); + statsfp = fopen (argv[i], "w"); + if (!statsfp) + usage ("%s: can't open", argv[i]); + break; + case 't': + if (!t_flag++) + (void) shade_argtrange (argv[i][0] == + '-' ? "+t," : "-t,"); + if (x = shade_argtrange (argv[i])) + usage ("%s: %s", argv[i], x); + /* should print tranges */ + break; + case 'U': + usage (""); + return (0); + case 'V': + fprintf (stderr, "%s: version: %s\n", + argv[0], anal_version); + fprintf (stderr, "shade version: %s\n", + shade_version); + return (0); + default: + argv[j++] = argv[i]; + break; + } + else argv[j++] = argv[i]; + + if (!statsfp) + statsfp = stdout; + + argv[argc = j] = 0; + initialize (argc, argv, envp); + + main_stats_start(); + + if (cmd) + ec = shade_sshell (cmd, main_stats_analyze); + else if (aargc <= 0) + ec = shade_shell (main_stats_analyze); + else if (0 > shade_loadp (*aargv, aargv, envp)) + ec = 1; + else ec = main_stats_analyze (aargc, aargv, envp, (char **) 0); + + if (pid == getpid()) { + main_stats_stop(); + terminate(); + } + return (ec); +} + + +usage (va_alist) + va_dcl +{ + char *fmt; + va_list ap; + + va_start (ap); + fmt = va_arg (ap, char *); + if (fmt && *fmt) { + fprintf (stderr, "%s: ", shade_ego); + vfprintf (stderr, fmt, ap); + fprintf (stderr, "\n\n"); + } + va_end (ap); + + fprintf (stderr, "usage: %s [-U] [-V] [-o outfile] [+/-t[from],[to]] ", + shade_ego); + if (anal_usage && *anal_usage) + fprintf (stderr, "\\\n\t%s ", anal_usage); + fprintf (stderr, "\\\n\t[-c \"command\" | -- bench benchargs]\n"); + + exit (1); +} + + +static void +getcputime (usr, sys) + double *usr, *sys; +{ + struct rusage ru; + + if (-1 == getrusage (RUSAGE_SELF, &ru)) + *usr = *sys = 0.0; + else { + *usr = TVTIME (ru.ru_utime) - *usr; + *sys = TVTIME (ru.ru_stime) - *sys; + } +} + + +static void +getrealtime (real) + double *real; +{ + struct timeval tv; + struct timezone tz; + + tz.tz_dsttime = DST_NONE; + tz.tz_minuteswest = 0; + + (void) gettimeofday (&tv, &tz); + + *real = TVTIME (tv) - *real; +} + + +static void +main_stats_start() +{ + long start; + + if (statsfp == 0) + return; + + fprintf (statsfp, "Analyzer: %s\n", shade_ego); + fprintf (statsfp, "Version: %s (shade version: %s)\n", + anal_version, shade_version); + + { + char host[64]; + + if (-1 != gethostname (host, sizeof host)) + fprintf (statsfp, "Hostname: %s\n", host); + } + + (void) time (&start); + getrealtime (&real); + getcputime (&usr, &sys); + + fprintf (statsfp, "Start: %s", ctime (&start)); + fflush (statsfp); +} + + +static int +main_stats_analyze (argc, argv, envp, iov) + int argc; + char **argv, **envp, **iov; +{ + int i; + + /* BUG: if t_flag, shouldn't change application program */ + + if (statsfp) { + fprintf (statsfp, "Application: %s", shade_bench_path); + for (i = 1; i < argc; i++) + fprintf (statsfp, " %s", argv[i]); + if (iov) + for (i = 0; iov[i]; i += 2) { + fprintf (statsfp, " %s", iov[i]); + if (iov[i+1]) + fprintf (statsfp, " %s", iov[i+1]); + } + fprintf (statsfp, "\n"); + fflush (statsfp); + } + + return (analyze()); +} + + +static void +main_stats_stop() +{ + long stop; + + if (statsfp == 0) + return; + + (void) time (&stop); + getcputime (&usr, &sys); + getrealtime (&real); + + fprintf (statsfp, "Stop: %s", ctime (&stop)); + if (nina > 0) + fprintf (statsfp, "Instructions: %.0f\n", nina); + fprintf (statsfp, "Time: %.3f usr %.3f sys %.3f real %.3f%%\n", + usr, sys, real, + real > 0 ? 100. * (usr + sys) / real : 100.); + if (usr + sys > 0 && nina > 0) + fprintf (statsfp, "Speed: %.3f KIPS\n", + nina / (usr + sys) / 1000.); +} diff --git a/ghc/misc/spat-analysers/stgregs.c b/ghc/misc/spat-analysers/stgregs.c new file mode 100644 index 0000000000..61d6204132 --- /dev/null +++ b/ghc/misc/spat-analysers/stgregs.c @@ -0,0 +1,121 @@ +#include <stdio.h> +#include <sparc.h> + +#include "StgRegAddrs.h" + +#define CHECKPOINT 1000000 /* reporting frequency */ +static int countdown = CHECKPOINT; + +struct regcount { + char *str; + int load; + int store; +} info[] = { + {"SpA", 0, 0}, + {"SpB", 0, 0}, + {"Hp", 0, 0}, + {"HpLim", 0, 0}, + {"SuA", 0, 0}, + {"SuB", 0, 0}, + {"UpdReg", 0, 0}, + {"RetVecReg", 0, 0}, + {"TagReg", 0, 0}, + {"Ret1", 0, 0}, + {"Ret2", 0, 0}, + {"Ret3", 0, 0}, + {"Ret4", 0, 0}, + {"Ret5", 0, 0}, + {"Ret6", 0, 0}, + {"Ret7", 0, 0}, + {"Ret8", 0, 0}, + {0, 0, 0} +}; + +void +printregs(msg) +char *msg; +{ + FILE *output; + int i; + if ((output = fopen("REGSTATS", "w")) == 0) + syserr("cannot open statistics file REGSTATS\n"); + + fprintf(output, "%s\n", msg); + for (i = 0; info[i].str; i++) { + fprintf(output, "%-16.16s %8d %8d\n", + info[i].str, info[i].load, info[i].store); + } + fclose(output); +} + +#define RECORD(i) \ + if ( (OP3(t->iw)&014) == 004) { \ + info[i].store++; \ + } else { \ + info[i].load++; \ + } \ + /* fprintf(stderr, "%s\n", info[i].str); */ \ + break + +void +analyze (t, tend) + TRACE *t, *tend; +{ + countdown -= tend-t; + + for (; t < tend; t++) { + if (OP(t->iw) == 3 && /* Load/store; (OP3(t->iw)&014)==004) => store */ + !(t->flags & ANNULLED)) { + unsigned a = (unsigned)t->ea; + switch (a) { + case SpA: + RECORD(0); + case SpB: + RECORD(1); + case Hp: + RECORD(2); + case HpLim: + RECORD(3); + case SuA: + RECORD(4); + case SuB: + RECORD(5); + case UpdReg: + RECORD(6); + case RetVecReg: + RECORD(7); + case TagReg: + RECORD(8); + case Ret1: + RECORD(9); + case Ret2: + RECORD(10); + case Ret3: + RECORD(11); + case Ret4: + RECORD(12); + case Ret5: + RECORD(13); + case Ret6: + RECORD(14); + case Ret7: + RECORD(15); + case Ret8: + RECORD(16); + deafualt: + break; + } + } + } + + if (countdown <= 0) { + printregs("Intermediate:"); + countdown = CHECKPOINT; + } +} + +void +terminate() +{ + printregs("Final:"); +} diff --git a/ghc/misc/test-arch.c b/ghc/misc/test-arch.c new file mode 100644 index 0000000000..d0e9666b96 --- /dev/null +++ b/ghc/misc/test-arch.c @@ -0,0 +1,37 @@ +/* + Compile this with GCC on a new platform, to learn various + things about argument-passing, return-returning, stack + layout, etc. WDP 95/05 +*/ + +extern long int foo (long int, double, void *, char *, double, long int, char, long int); +extern double bar (char, float, long int, long int, char *, char **); + +long int +foo (long int a, double b, void *c, char *d, double e, long int f, char g, long int h) +{ + __asm__ volatile ("--- BEGIN ---"); + bar(*d, (float) b, a, f, d, (char **) d); + __asm__ volatile ("--- END ---"); +} + +double +bar (char a, float b, long int c, long int d, char *e, char **f) +{ + __asm__ volatile ("--- BEGIN ---"); + foo(c, (double) b, (void *) 0, e, 0.0, d, a, d); + __asm__ volatile ("--- END ---"); +} + +double +baz(w) + int w; +{ + int x[1000]; + int y; + + for(y = 0; y < 1000; y++) + w += x[y]; + + return ((double) w); +} |