Main.hs 26.5 KB
Newer Older
1
-----------------------------------------------------------------------------
2
-- $Id: Main.hs,v 1.10 2005/06/07 10:58:31 simonmar Exp $
3

4
-- (c) Simon Marlow 1997-2005
5
6
7
8
9
10
11
12
-----------------------------------------------------------------------------

module Main where

import GenUtils
import Slurp
import CmdLine

13
import Text.Printf
Ian Lynagh's avatar
Ian Lynagh committed
14
import Text.Html hiding (cols, rows, (!))
15
import qualified Text.Html as Html ((!))
16
17
import qualified Data.Map as Map
import Data.Map (Map)
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
18
import System.Exit      ( exitWith, ExitCode(..) )
19

Ian Lynagh's avatar
Ian Lynagh committed
20
import Control.Monad
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
21
import Data.Maybe       ( isNothing )
22
23
24
import Data.Char
import System.IO
import Data.List
25

26
27
(<!) = (Html.!)

28
29
30
31
32
33
-----------------------------------------------------------------------------
-- Top level stuff

die :: String -> IO a
die s = hPutStr stderr s >> exitWith (ExitFailure 1)

Ian Lynagh's avatar
Ian Lynagh committed
34
main :: IO ()
35
36
main = do

Ian Lynagh's avatar
Ian Lynagh committed
37
 when (not (null cmdline_errors) || OptHelp `elem` flags) $
Ian Lynagh's avatar
Ian Lynagh committed
38
      die (concat cmdline_errors ++ usage)
39

Ian Lynagh's avatar
Ian Lynagh committed
40
 let { html  = OptHTMLOutput  `elem` flags;
41
       latex = OptLaTeXOutput `elem` flags;
42
43
44
       ascii = OptASCIIOutput `elem` flags
     }

Ian Lynagh's avatar
Ian Lynagh committed
45
46
 when (ascii && html)  $ die "Can't produce both ASCII and HTML"
 when (devs && nodevs) $ die "Can't both display and hide deviations"
47

48
49
 results <- parse_logs other_args

50
 summary_spec <- case [ cols | OptColumns cols <- flags ] of
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
51
52
                        []       -> return (pickSummary results)
                        (cols:_) -> namedColumns (split ',' cols)
53
54

 let summary_rows = case [ rows | OptRows rows <- flags ] of
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
55
56
                        [] -> Nothing
                        rows -> Just (split ',' (last rows))
57

58
59
 let column_headings = map (reverse . takeWhile (/= '/') . reverse) other_args

60
 -- sanity check
Ian Lynagh's avatar
Ian Lynagh committed
61
62
 sequence_ [ checkTimes prog res | result_table <- results,
                                   (prog,res) <- Map.toList result_table ]
63

64
 case () of
Ian Lynagh's avatar
Ian Lynagh committed
65
   _ | html      ->
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
66
        putStr (renderHtml (htmlPage results column_headings))
Ian Lynagh's avatar
Ian Lynagh committed
67
   _ | latex     ->
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
68
        putStr (latexOutput results column_headings summary_spec summary_rows)
Ian Lynagh's avatar
Ian Lynagh committed
69
   _ | otherwise ->
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
70
        putStr (asciiPage results column_headings summary_spec summary_rows)
71
72
73
74


parse_logs :: [String] -> IO [ResultTable]
parse_logs [] = do
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
75
76
        f <- hGetContents stdin
        return [parse_log f]
77
parse_logs log_files =
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
78
79
80
        mapM (\f -> do h <- openFile f ReadMode
                       c <- hGetContents h
                       return (parse_log c)) log_files
81
82
83
84
85

-----------------------------------------------------------------------------
-- List of tables we're going to generate

data PerProgTableSpec =
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
86
        forall a . Result a =>
Ian Lynagh's avatar
Ian Lynagh committed
87
           SpecP
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
88
89
90
91
92
93
                String                  -- Name of the table
                String                  -- Short name (for column heading)
                String                  -- HTML tag for the table
                (Results -> Maybe a)    -- How to get the result
                (Results -> Status)     -- How to get the status of this result
                (a -> Bool)             -- Result within reasonable limits?
94
95

data PerModuleTableSpec =
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
96
        forall a . Result a =>
Ian Lynagh's avatar
Ian Lynagh committed
97
           SpecM
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
98
99
100
101
                String                  -- Name of the table
                String                  -- HTML tag for the table
                (Results -> Map String a)       -- get the module map
                (a -> Bool)             -- Result within reasonable limits?
102

103
-- The various per-program aspects of execution that we can generate results for.
Ian Lynagh's avatar
Ian Lynagh committed
104
105
106
size_spec, alloc_spec, runtime_spec, muttime_spec, gctime_spec,
    gcwork_spec, instrs_spec, mreads_spec, mwrite_spec, cmiss_spec
        :: PerProgTableSpec
107
108
109
110
111
112
113
114
115
116
117
size_spec    = SpecP "Binary Sizes" "Size" "binary-sizes" binary_size compile_status always_ok
alloc_spec   = SpecP "Allocations" "Allocs" "allocations" allocs run_status always_ok
runtime_spec = SpecP "Run Time" "Runtime" "run-times" (mean run_time) run_status time_ok
muttime_spec = SpecP "Mutator Time" "MutTime" "mutator-time" (mean mut_time) run_status time_ok
gctime_spec  = SpecP "GC Time" "GCTime" "gc-time" (mean gc_time) run_status time_ok
gcwork_spec  = SpecP "GC Work" "GCWork" "gc-work" gc_work run_status always_ok
instrs_spec  = SpecP "Instructions" "Instrs" "instrs" instrs run_status always_ok
mreads_spec  = SpecP "Memory Reads" "Reads" "mem-reads" mem_reads run_status always_ok
mwrite_spec  = SpecP "Memory Writes" "Writes" "mem-writes" mem_writes run_status always_ok
cmiss_spec   = SpecP "Cache Misses" "Misses" "cache-misses" cache_misses run_status always_ok

Ian Lynagh's avatar
Ian Lynagh committed
118
all_specs :: [PerProgTableSpec]
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
all_specs = [
  size_spec,
  alloc_spec,
  runtime_spec,
  muttime_spec,
  gctime_spec,
  gcwork_spec,
  instrs_spec,
  mreads_spec,
  mwrite_spec,
  cmiss_spec
  ]

namedColumns :: [String] -> IO [PerProgTableSpec]
namedColumns ss = mapM findSpec ss
Ian Lynagh's avatar
Ian Lynagh committed
134
  where findSpec s =
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
135
136
137
138
           case [ spec | spec@(SpecP _ short_name _ _ _ _) <- all_specs,
                         short_name == s ] of
                [] -> die ("unknown column: " ++ s)
                (spec:_) -> return spec
139

140
141
142
mean :: (Results -> [Float]) -> Results -> Maybe Float
mean f results = go (f results)
  where go [] = Nothing
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
143
        go fs = Just (foldl' (+) 0 fs / fromIntegral (length fs))
144

145
146
147
148
149
150
151
152
-- Look for bogus-looking times: On Linux we occasionally get timing results
-- that are bizarrely low, and skew the average.
checkTimes :: String -> Results -> IO ()
checkTimes prog results = do
  check "run time" (run_time results)
  check "mut time" (mut_time results)
  check "GC time" (gc_time results)
  where
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
153
        check kind ts
Ian Lynagh's avatar
Ian Lynagh committed
154
           | any strange ts =
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
155
156
157
158
159
160
161
                hPutStrLn stderr ("warning: dubious " ++ kind
                                   ++ " results for " ++ prog
                                   ++ ": " ++ show ts)
           | otherwise = return ()
           where strange t = any (\r -> time_ok r && r / t > 1.4) ts
                        -- looks for times that are >40% smaller than
                        -- any other.
162
163


164
-- These are the per-prog tables we want to generate
Ian Lynagh's avatar
Ian Lynagh committed
165
per_prog_result_tab :: [PerProgTableSpec]
166
per_prog_result_tab =
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
167
168
        [ size_spec, alloc_spec, runtime_spec, muttime_spec, gctime_spec,
          gcwork_spec, instrs_spec, mreads_spec, mwrite_spec, cmiss_spec ]
169
170
171

-- A single summary table, giving comparison figures for a number of
-- aspects, each in its own column.  Only works when comparing two runs.
Ian Lynagh's avatar
Ian Lynagh committed
172
normal_summary_specs :: [PerProgTableSpec]
173
normal_summary_specs =
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
174
        [ size_spec, alloc_spec, runtime_spec ]
Ian Lynagh's avatar
Ian Lynagh committed
175

Ian Lynagh's avatar
Ian Lynagh committed
176
cachegrind_summary_specs :: [PerProgTableSpec]
177
cachegrind_summary_specs =
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
178
        [ size_spec, alloc_spec, instrs_spec, mreads_spec, mwrite_spec ]
Ian Lynagh's avatar
Ian Lynagh committed
179

180
181
182
183
-- Pick an appropriate summary table: if we're cachegrinding, then
-- we're probably not interested in the runtime, but we are interested
-- in instructions, mem reads and mem writes (and vice-versa).
pickSummary :: [ResultTable] -> [PerProgTableSpec]
Ian Lynagh's avatar
Ian Lynagh committed
184
pickSummary rs
185
  | isNothing (instrs (head (Map.elems (head rs)))) = normal_summary_specs
186
  | otherwise = cachegrind_summary_specs
187

Ian Lynagh's avatar
Ian Lynagh committed
188
per_module_result_tab :: [PerModuleTableSpec]
189
per_module_result_tab =
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
190
191
192
        [ SpecM "Module Sizes"  "mod-sizes"     module_size  always_ok
        , SpecM "Compile Times" "compile-time"  compile_time time_ok
        ]
193
194
195
196
197
198
199
200
201
202

always_ok :: a -> Bool
always_ok = const True

time_ok :: Float -> Bool
time_ok t = t > tooquick_threshold

-----------------------------------------------------------------------------
-- HTML page generation

Ian Lynagh's avatar
Ian Lynagh committed
203
htmlPage :: [ResultTable] -> [String] -> Html
204
htmlPage results args
205
   =  header << thetitle << reportTitle
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
206
          +++ hr
207
          +++ h1 << reportTitle
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
208
209
210
          +++ gen_menu
          +++ hr
          +++ body (gen_tables results args)
211

212
gen_menu = unordList (map (prog_menu_item) per_prog_result_tab
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
213
                      ++ map (module_menu_item) per_module_result_tab)
214

215
prog_menu_item (SpecP name _ anc _ _ _) = anchor <! [href ('#':anc)] << name
216
module_menu_item (SpecM name anc _ _) = anchor <! [href ('#':anc)] << name
217
218
219
220
221

gen_tables results args =
  foldr1 (+++) (map (htmlGenProgTable results args) per_prog_result_tab)
  +++ foldr1 (+++) (map (htmlGenModTable results args) per_module_result_tab)

222
htmlGenProgTable results args (SpecP title _ anc get_result get_status result_ok)
223
  =   sectHeading title anc
224
  +++ font <! [size "1"]
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
225
        << mkTable (htmlShowResults results args get_result get_status result_ok)
226
  +++ hr
227
228

htmlGenModTable results args (SpecM title anc get_result result_ok)
Ian Lynagh's avatar
Ian Lynagh committed
229
230
  =   sectHeading title anc
  +++ font <![size "1"]
231
232
        << mkTable (htmlShowMultiResults results args get_result result_ok)
  +++ hr
233
234

sectHeading :: String -> String -> Html
235
sectHeading s nm = h2 << anchor <! [name nm] << s
236

Ian Lynagh's avatar
Ian Lynagh committed
237
htmlShowResults
238
    :: Result a
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
239
240
241
242
243
244
        => [ResultTable]
        -> [String]
        -> (Results -> Maybe a)
        -> (Results -> Status)
        -> (a -> Bool)
        -> HtmlTable
245
246
247

htmlShowResults (r:rs) ss f stat result_ok
  =   tabHeader ss
248
249
250
251
  </> aboves (zipWith tableRow [1..] results_per_prog)
  </> aboves ((if nodevs then []
                         else [tableRow (-1) ("-1 s.d.", lows),
                               tableRow (-1) ("+1 s.d.", highs)])
252
                    ++ [tableRow (-1) ("Average", gms)])
253
 where
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
254
255
        -- results_per_prog :: [ (String,[BoxValue a]) ]
        results_per_prog = map (calc_result rs f stat result_ok) (Map.toList r)
Ian Lynagh's avatar
Ian Lynagh committed
256

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
257
258
        results_per_run  = transpose (map snd results_per_prog)
        (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
259
260
261

htmlShowMultiResults
    :: Result a
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
262
263
264
265
266
        => [ResultTable]
        -> [String]
        -> (Results -> Map String a)
        -> (a -> Bool)
        -> HtmlTable
267
268

htmlShowMultiResults (r:rs) ss f result_ok =
Ian Lynagh's avatar
Ian Lynagh committed
269
        multiTabHeader ss
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
270
         </> aboves (map show_results_for_prog results_per_prog_mod_run)
271
272
273
274
275
276
277
         </> aboves ((if nodevs then []
                                      else [td << bold << "-1 s.d."
                                            <-> tableRow (-1) ("", lows),
                                            td << bold << "+1 s.d."
                                            <-> tableRow (-1) ("", highs)])
                           ++ [td << bold << "Average"
                               <-> tableRow (-1) ("", gms)])
278

279
  where
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
280
        base_results = Map.toList r :: [(String,Results)]
281

282
283
284
285
        -- results_per_prog_mod_run :: [(String,[(String,[BoxValue a])])]
        results_per_prog_mod_run = map get_results_for_prog base_results

        -- get_results_for_prog :: (String,Results) -> (String,[BoxValue a])
286
        get_results_for_prog (prog,r) = (prog, map get_results_for_mod (Map.toList (f r)))
287
288
289

           where fms = map get_run_results rs

290
291
                 get_run_results fm = case Map.lookup prog fm of
                                        Nothing  -> Map.empty
292
293
294
295
296
297
                                        Just res -> f res

                 get_results_for_mod (id,attr) = calc_result fms Just (const Success)
                                                             result_ok (id,attr)

        show_results_for_prog (prog,mrs) =
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
298
299
300
301
302
            td <! [valign "top"] << bold << prog
            <-> (if null mrs then
                   td << "(no modules compiled)"
                 else
                   toHtml (aboves (map (tableRow 0) mrs)))
303

304
305
306
        results_per_run  = transpose [xs | (_,mods) <- results_per_prog_mod_run,
                                           (_,xs) <- mods]
        (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
307

308
tableRow :: Int -> (String, [BoxValue]) -> HtmlTable
309
tableRow row_no (prog, results)
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
310
        =   td <! [bgcolor left_column_color] << prog
Ian Lynagh's avatar
Ian Lynagh committed
311
        <-> besides (map (\s -> td <! [align "right", clr] << showBox s)
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
312
                                results)
313
  where clr | row_no < 0  = bgcolor average_row_color
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
314
315
            | even row_no = bgcolor even_row_color
            | otherwise   = bgcolor odd_row_color
316
317
318
319
320
321
322
323
324
325
326

left_column_color = "#d0d0ff"  -- light blue
odd_row_color     = "#d0d0ff"  -- light blue
even_row_color    = "#f0f0ff"  -- v. light blue
average_row_color = "#ffd0d0"  -- light red

{-
findBest :: Result a => [BoxValue a] -> [(Bool,BoxValue a)]
findBest stuff@(Result base : rest)
  = map (\a -> (a==base, a))
  where
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
327
        best = snd (minimumBy (\a b -> fst a < fst b) no_pcnt_stuff
328

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
329
        no_pcnt_stuff = map unPcnt stuff
330

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
331
332
333
        unPcnt (r@(Percentage f) : rest) = (base * f/100, r) : unPcnt rest
        unPcnt (r@(Result a) : rest)     = (a, r) : unPcnt rest
        unPcnt (_ : rest)                = unPcnt rest
334
335
336
-}

logHeaders ss
337
  = besides (map (\s -> (td <! [align "right", width "100"] << bold << s)) ss)
338

339
mkTable t = table <! [cellspacing 0, cellpadding 0, border 0] << t
340
341

tabHeader ss
Ian Lynagh's avatar
Ian Lynagh committed
342
  =   (td <! [align "left", width "100"] << bold << "Program")
343
  <-> logHeaders ss
344
345

multiTabHeader ss
346
347
348
  =   (td <! [align "left", width "100"] << bold << "Program")
  <-> (td <! [align "left", width "100"] << bold << "Module")
  <-> logHeaders ss
349
350
351
352
353

-- Calculate a color ranging from bright blue for -100% to bright red for +100%.

calcColor :: Int -> String
calcColor p | p >= 0    = "#"     ++ (showHex red 2 "0000")
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
354
355
356
              | otherwise = "#0000" ++ (showHex blue 2 "")
        where red  = p * 255 `div` 100
              blue = (-p) * 255 `div` 100
357
358
359
360
361

showHex 0 f s = if f > 0 then take f (repeat '0') ++ s else s
showHex i f s = showHex (i `div` 16) (f-1) (hexDig (i `mod` 16) : s)

hexDig i | i > 10 = chr (i-10 + ord 'a')
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
362
         | otherwise = chr (i + ord '0')
363

364
365
366
-----------------------------------------------------------------------------
-- LaTeX table generation (just the summary for now)

367
latexOutput results args summary_spec summary_rows =
368
   (if (length results == 2)
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
369
370
371
        then ascii_summary_table True results summary_spec summary_rows
            . str "\n\n"
        else id) ""
372
373


374
375
376
-----------------------------------------------------------------------------
-- ASCII page generation

377
asciiPage results args summary_spec summary_rows =
378
379
  ( str reportTitle
  . str "\n\n"
380
381
     -- only show the summary table if we're comparing two runs
  . (if (length results == 2)
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
382
383
        then ascii_summary_table False results summary_spec summary_rows . str "\n\n"
        else id)
384
  . interleave "\n\n" (map (asciiGenProgTable results args) per_prog_result_tab)
385
386
387
388
  . str "\n"
  . interleave "\n\n" (map (asciiGenModTable results args)  per_module_result_tab)
  ) "\n"

389
asciiGenProgTable results args (SpecP title _ anc get_result get_status result_ok)
Ian Lynagh's avatar
Ian Lynagh committed
390
  = str title
391
392
393
394
  . str "\n"
  . ascii_show_results results args get_result get_status result_ok

asciiGenModTable results args (SpecM title anc get_result result_ok)
Ian Lynagh's avatar
Ian Lynagh committed
395
  = str title
396
397
398
  . str "\n"
  . ascii_show_multi_results results args get_result result_ok

399
ascii_header width ss
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
400
401
402
403
404
        = str "\n-------------------------------------------------------------------------------\n"
        . str (rjustify 15 "Program")
        . str (space 5)
        . foldr (.) id (map (str . rjustify width) ss)
        . str "\n-------------------------------------------------------------------------------\n"
405
406
407

ascii_show_results
   :: Result a
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
408
409
410
411
412
413
        => [ResultTable]
        -> [String]
        -> (Results -> Maybe a)
        -> (Results -> Status)
        -> (a -> Bool)
        -> ShowS
414
415

ascii_show_results (r:rs) ss f stat result_ok
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
416
417
        = ascii_header fIELD_WIDTH ss
        . interleave "\n" (map show_per_prog_results results_per_prog)
418
419
        . if nodevs then id
                    else   str "\n"
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
420
421
422
423
424
                         . show_per_prog_results ("-1 s.d.",lows)
                         . str "\n"
                         . show_per_prog_results ("+1 s.d.",highs)
        . str "\n"
        . show_per_prog_results ("Average",gms)
425
 where
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
426
427
        -- results_per_prog :: [ (String,[BoxValue a]) ]
        results_per_prog = map (calc_result rs f stat result_ok) (Map.toList r)
Ian Lynagh's avatar
Ian Lynagh committed
428

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
429
        results_per_run  = transpose (map snd results_per_prog)
430
        (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
431

432
433
-- A summary table, useful only when we are comparing two runs.  This table
-- shows a number of different result categories, one per column.
Ian Lynagh's avatar
Ian Lynagh committed
434
ascii_summary_table
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
435
436
437
438
439
        :: Bool                         -- generate a LaTeX table?
        -> [ResultTable]
        -> [PerProgTableSpec]
        -> Maybe [String]
        -> ShowS
440
ascii_summary_table latex (r1:r2:_) specs mb_restrict
441
  | latex     = makeLatexTable (rows ++ TableLine : av_rows)
Ian Lynagh's avatar
Ian Lynagh committed
442
  | otherwise =
443
       makeTable (table_layout (length specs) width)
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
444
          (TableLine : TableRow header : TableLine : rows ++ TableLine : av_rows)
445
  where
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
446
        header = BoxString "Program" : map BoxString headings
447

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
448
        (headings, columns, av_cols) = unzip3 (map calc_col specs)
449
        av_heads = [BoxString "Min", BoxString "Max", BoxString "Geometric Mean"]
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
450
451
452
        baseline = Map.toList r1
        progs   = map BoxString (Map.keys r1)
        rows0   = map TableRow (zipWith (:) progs (transpose columns))
453

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
454
        rows1 = restrictRows mb_restrict rows0
455

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
456
457
        rows | latex     = mungeForLaTeX rows1
             | otherwise = rows1
458

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
459
460
        av_rows = map TableRow (zipWith (:) av_heads (transpose av_cols))
        width   = 10
461

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
462
463
464
465
466
467
468
        calc_col (SpecP _ heading _ getr gets ok)
          = (heading, column, [min,max,mean]) -- throw away the baseline result
          where (_, boxes) = unzip (map calc_one_result baseline)
                calc_one_result = calc_result [r2] getr gets ok
                column = map (\(_:b:_) -> b) boxes
                (_,mean,_) = calc_gmsd column
                (min,max) = calc_minmax column
469

470
471
472
473
restrictRows :: Maybe [String] -> [TableRow] -> [TableRow]
restrictRows Nothing rows = rows
restrictRows (Just these) rows = filter keep_it rows
  where keep_it (TableRow (BoxString s: _)) = s `elem` these
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
474
475
        keep_it TableLine = True
        keep_it _ = False
476

477
478
479
mungeForLaTeX :: [TableRow] -> [TableRow]
mungeForLaTeX = map transrow
   where
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
480
481
        transrow (TableRow boxes) = TableRow (map transbox boxes)
        transrow row = row
482

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
483
484
        transbox (BoxString s) = BoxString (foldr transchar "" s)
        transbox box = box
485

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
486
487
        transchar '_' s = '\\':'_':s
        transchar c s = c:s
488
489

table_layout n width =
Ian Lynagh's avatar
Ian Lynagh committed
490
  (str . rjustify 15) :
491
492
493
  (\s -> str (space 5) . str (rjustify width s)) :
  replicate (n-1) (str . rjustify width)

494
495
ascii_show_multi_results
   :: Result a
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
496
497
498
499
500
        => [ResultTable]
        -> [String]
        -> (Results -> Map String a)
        -> (a -> Bool)
        -> ShowS
501
502

ascii_show_multi_results (r:rs) ss f result_ok
Ian Lynagh's avatar
Ian Lynagh committed
503
        = ascii_header fIELD_WIDTH ss
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
504
505
        . interleave "\n" (map show_results_for_prog results_per_prog_mod_run)
        . str "\n"
506
507
        . if nodevs then id
                    else   str "\n"
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
508
509
510
511
512
                         . show_per_prog_results ("-1 s.d.",lows)
                         . str "\n"
                         . show_per_prog_results ("+1 s.d.",highs)
        . str "\n"
        . show_per_prog_results ("Average",gms)
513
  where
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
514
        base_results = Map.toList r :: [(String,Results)]
515

516
517
        -- results_per_prog_mod_run :: [(String,[(String,[BoxValue a])])]
        results_per_prog_mod_run = map get_results_for_prog base_results
518

519
        -- get_results_for_prog :: (String,Results) -> (String,[BoxValue a])
520
        get_results_for_prog (prog,r) = (prog, map get_results_for_mod (Map.toList (f r)))
521

522
           where fms = map get_run_results rs
523

524
525
                 get_run_results fm = case Map.lookup prog fm of
                                        Nothing  -> Map.empty
526
527
528
529
530
531
                                        Just res -> f res

                 get_results_for_mod (id,attr) = calc_result fms Just (const Success)
                                                             result_ok (id,attr)

        show_results_for_prog (prog,mrs) =
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
532
533
534
535
536
              str ("\n"++prog++"\n")
            . (if null mrs then
                   str "(no modules compiled)\n"
                 else
                   interleave "\n" (map show_per_prog_results mrs))
537
538
539
540

        results_per_run  = transpose [xs | (_,mods) <- results_per_prog_mod_run,
                                           (_,xs) <- mods]
        (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
541
542


543
544
show_per_prog_results :: (String, [BoxValue]) -> ShowS
show_per_prog_results = show_per_prog_results_width fIELD_WIDTH
545

546
show_per_prog_results_width width (prog,results)
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
547
548
549
        = str (rjustify 15 prog)
        . str (space 5)
        . foldr (.) id (map (str . rjustify width . showBox) results)
550

551
552
-- ---------------------------------------------------------------------------
-- Generic stuff for results generation
553
554

-- calc_result is a nice exercise in higher-order programming...
Ian Lynagh's avatar
Ian Lynagh committed
555
calc_result
556
  :: Result a
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
557
558
559
560
561
562
        => [Map String b]               -- accumulated results
        -> (b -> Maybe a)               -- get a result from the b
        -> (b -> Status)                -- get a status from the b
        -> (a -> Bool)                  -- is this result ok?
        -> (String,b)                   -- the baseline result
        -> (String,[BoxValue])
563
564

calc_result rts get_maybe_a get_stat result_ok (prog,base_r) =
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
        (prog, (just_result baseline base_stat :

          let
                rts' = map (\rt -> get_stuff (Map.lookup prog rt)) rts

                get_stuff Nothing  = (Nothing, NotDone)
                get_stuff (Just r) = (get_maybe_a r, get_stat r)
          in
          (
          case baseline of
                Just base | result_ok base
                   -> map (\(r,s) -> percentage  r s base) rts'
                _other
                   -> map (\(r,s) -> just_result r s) rts'
           )))
580
 where
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
581
582
        baseline  = get_maybe_a base_r
        base_stat = get_stat base_r
583

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
584
        just_result Nothing  s = RunFailed s
585
        just_result (Just a) _ = toBox a
586

587
588
        percentage Nothing   s _    = RunFailed s
        percentage (Just a)  _ base = Percentage
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
589
                                         (convert_to_percentage base a)
590
-----------------------------------------------------------------------------
591
-- Calculating geometric means and standard deviations
592
593
594

{-
This is done using the log method, to avoid needing really large
Ian Lynagh's avatar
Ian Lynagh committed
595
intermediate results.  The formula for a geometric mean is
596

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
597
        (a1 * .... * an) ^ 1/n
598
599
600

which is equivalent to

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
601
        e ^ ( (log a1 + ... + log an) / n )
602
603

where log is the natural logarithm function.
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619

Similarly, to compute the geometric standard deviation we compute the
deviation of each log, take the root-mean-square, and take the
exponential again:

        e ^ sqrt( ( sqr(log a1 - lbar) + ... + sqr(log an - lbar) ) / n )

where lbar is the mean log,

        (log a1 + ... + log an) / n

This is a *factor*: i.e., the 1 s.d. points are (gm/sdf,gm*sdf); do
not subtract 100 from gm before performing this calculation.

We therefore return a (low, mean, high) triple.

620
621
-}

622
calc_gmsd :: [BoxValue] -> (BoxValue, BoxValue, BoxValue)
Ian Lynagh's avatar
Ian Lynagh committed
623
calc_gmsd xs
624
625
  | null percentages = (RunFailed NotDone, RunFailed NotDone, RunFailed NotDone)
  | otherwise        = let sqr x = x * x
626
                           len   = fromIntegral (length percentages)
627
628
629
630
631
632
633
634
635
636
                           logs  = map log percentages
                           lbar  = sum logs / len
                           devs  = map (sqr . (lbar-)) logs
                           dbar  = sum devs / len
                           gm    = exp lbar
                           sdf   = exp (sqrt dbar)
                       in
                       (Percentage (gm/sdf),
                        Percentage gm,
                        Percentage (gm*sdf))
637
 where
638
  percentages = [ if f < 5 then 5 else f | Percentage f <- xs ]
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
639
        -- can't do log(0.0), so exclude zeros
640
        -- small values have inordinate effects so cap at -95%.
641

642
643
644
calc_minmax :: [BoxValue] -> (BoxValue, BoxValue)
calc_minmax xs
 | null percentages = (RunFailed NotDone, RunFailed NotDone)
Ian Lynagh's avatar
Ian Lynagh committed
645
 | otherwise = (Percentage (minimum percentages),
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
646
                Percentage (maximum percentages))
647
648
649
650
 where
  percentages = [ if f < 5 then 5 else f | Percentage f <- xs ]


651
-----------------------------------------------------------------------------
652
653
654
-- Show the Results

class Num a => Result a where
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
655
656
        toBox :: a -> BoxValue
        convert_to_percentage :: a -> a -> Float
657
658
659
660

-- We assume an Int is a size, and print it in kilobytes.

instance Result Int where
661
662
663
    convert_to_percentage 0    _    = 100
    convert_to_percentage base size
        = (fromIntegral size / fromIntegral base) * 100
664

665
    toBox = BoxInt
666
667

instance Result Integer where
668
669
670
671
    convert_to_percentage 0    _    = 100
    convert_to_percentage base size
        = (fromInteger size / fromInteger base) * 100
    toBox = BoxInteger
672
673

instance Result Float where
674
675
    convert_to_percentage 0.0  _    = 100.0
    convert_to_percentage base size = size / base * 100
676

677
    toBox = BoxFloat
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692

-- -----------------------------------------------------------------------------
-- BoxValues

-- The contents of a box in a table
data BoxValue
  = RunFailed Status
  | Percentage Float
  | BoxFloat Float
  | BoxInt Int
  | BoxInteger Integer
  | BoxString String

showBox :: BoxValue -> String
showBox (RunFailed stat) = show_stat stat
693
showBox (Percentage f)   = printf "%+.1f%%" (f-100)
694
showBox (BoxFloat f)     = printf "%.2f" f
695
696
697
698
showBox (BoxInt n)       = show (n `div` 1024) ++ "k"
showBox (BoxInteger n)   = show (n `div` 1024) ++ "k"
showBox (BoxString s)    = s

699
700
instance Show BoxValue where
    show = showBox
701

702
show_stat :: Status -> String
703
704
705
706
707
708
709
710
show_stat Success     = "(no result)"
show_stat WrongStdout = "(stdout)"
show_stat WrongStderr = "(stderr)"
show_stat (Exit x)    = "exit(" ++ show x ++")"
show_stat OutOfHeap   = "(heap)"
show_stat OutOfStack  = "(stack)"
show_stat NotDone     = "-----"

711
712
713
714
715
716
717
718
719
720
721
722
-- -----------------------------------------------------------------------------
-- Table layout

data TableRow
  = TableRow [BoxValue]
  | TableLine

type Layout = [String -> ShowS]

makeTable :: Layout -> [TableRow] -> ShowS
makeTable p = interleave "\n" . map do_row
  where do_row (TableRow boxes) = applyLayout p boxes
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
723
        do_row TableLine = str (take 80 (repeat '-'))
724
725
726
727

makeLatexTable :: [TableRow] -> ShowS
makeLatexTable = foldr (.) id . map do_row
  where do_row (TableRow boxes)
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
728
729
730
           = applyLayout latexTableLayout boxes . str "\\\\\n"
        do_row TableLine
           = str "\\hline\n"
731
732

latexTableLayout :: Layout
733
734
735
latexTableLayout = box : repeat (box . (" & "++))
  where box s = str (foldr transchar "" s)

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
736
737
        transchar '%' s = s  -- leave out the percentage signs
        transchar c   s = c : s
738
739

applyLayout :: Layout -> [BoxValue] -> ShowS
Ian Lynagh's avatar
Ian Lynagh committed
740
applyLayout layout values =
741
742
743
744
745
 foldr (.) id [ f (show val) | (val,f) <- zip values layout ]

-- -----------------------------------------------------------------------------
-- General Utils

746
747
split :: Char -> String -> [String]
split c s = case rest of
Ian Lynagh's avatar
Ian Lynagh committed
748
                []     -> [chunk]
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
749
                _:rest -> chunk : split c rest
750
751
  where (chunk, rest) = break (==c) s

752
753
str = showString

Ian Lynagh's avatar
Ian Lynagh committed
754
interleave s = foldr1 (\a b -> a . str s . b)
755
756
757
758

fIELD_WIDTH = 16 :: Int

-----------------------------------------------------------------------------