Main.hs 26.7 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
-}

Ian Lynagh's avatar
Ian Lynagh committed
336
logHeaders :: [String] -> HtmlTable
337
logHeaders ss
338
  = besides (map (\s -> (td <! [align "right", width "100"] << bold << s)) ss)
339

Ian Lynagh's avatar
Ian Lynagh committed
340
mkTable :: HtmlTable -> Html
341
mkTable t = table <! [cellspacing 0, cellpadding 0, border 0] << t
342

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

Ian Lynagh's avatar
Ian Lynagh committed
348
multiTabHeader :: [String] -> HtmlTable
349
multiTabHeader ss
350
351
352
  =   (td <! [align "left", width "100"] << bold << "Program")
  <-> (td <! [align "left", width "100"] << bold << "Module")
  <-> logHeaders ss
353
354
355
356
357

-- 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
Ian Lynagh committed
358
            | otherwise = "#0000" ++ (showHex blue 2 "")
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
359
360
        where red  = p * 255 `div` 100
              blue = (-p) * 255 `div` 100
361
362
363
364
365

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
366
         | otherwise = chr (i + ord '0')
367

368
369
370
-----------------------------------------------------------------------------
-- LaTeX table generation (just the summary for now)

371
latexOutput results args summary_spec summary_rows =
372
   (if (length results == 2)
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
373
374
375
        then ascii_summary_table True results summary_spec summary_rows
            . str "\n\n"
        else id) ""
376
377


378
379
380
-----------------------------------------------------------------------------
-- ASCII page generation

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

393
asciiGenProgTable results args (SpecP title _ anc get_result get_status result_ok)
Ian Lynagh's avatar
Ian Lynagh committed
394
  = str title
395
396
397
398
  . 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
399
  = str title
400
401
402
  . str "\n"
  . ascii_show_multi_results results args get_result result_ok

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

ascii_show_results
   :: Result a
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
412
413
414
415
416
417
        => [ResultTable]
        -> [String]
        -> (Results -> Maybe a)
        -> (Results -> Status)
        -> (a -> Bool)
        -> ShowS
418
419

ascii_show_results (r:rs) ss f stat result_ok
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
420
421
        = ascii_header fIELD_WIDTH ss
        . interleave "\n" (map show_per_prog_results results_per_prog)
422
423
        . if nodevs then id
                    else   str "\n"
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
424
425
426
427
428
                         . 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)
429
 where
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
430
431
        -- 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
432

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
433
        results_per_run  = transpose (map snd results_per_prog)
434
        (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
435

436
437
-- 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
438
ascii_summary_table
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
439
440
441
442
443
        :: Bool                         -- generate a LaTeX table?
        -> [ResultTable]
        -> [PerProgTableSpec]
        -> Maybe [String]
        -> ShowS
444
ascii_summary_table latex (r1:r2:_) specs mb_restrict
445
  | latex     = makeLatexTable (rows ++ TableLine : av_rows)
Ian Lynagh's avatar
Ian Lynagh committed
446
  | otherwise =
447
       makeTable (table_layout (length specs) width)
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
448
          (TableLine : TableRow header : TableLine : rows ++ TableLine : av_rows)
449
  where
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
450
        header = BoxString "Program" : map BoxString headings
451

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

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
458
        rows1 = restrictRows mb_restrict rows0
459

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
460
461
        rows | latex     = mungeForLaTeX rows1
             | otherwise = rows1
462

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
463
464
        av_rows = map TableRow (zipWith (:) av_heads (transpose av_cols))
        width   = 10
465

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
466
467
468
469
470
471
472
        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
473

474
475
476
477
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
478
479
        keep_it TableLine = True
        keep_it _ = False
480

481
482
483
mungeForLaTeX :: [TableRow] -> [TableRow]
mungeForLaTeX = map transrow
   where
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
484
485
        transrow (TableRow boxes) = TableRow (map transbox boxes)
        transrow row = row
486

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
487
488
        transbox (BoxString s) = BoxString (foldr transchar "" s)
        transbox box = box
489

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
490
491
        transchar '_' s = '\\':'_':s
        transchar c s = c:s
492
493

table_layout n width =
Ian Lynagh's avatar
Ian Lynagh committed
494
  (str . rjustify 15) :
495
496
497
  (\s -> str (space 5) . str (rjustify width s)) :
  replicate (n-1) (str . rjustify width)

498
499
ascii_show_multi_results
   :: Result a
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
500
501
502
503
504
        => [ResultTable]
        -> [String]
        -> (Results -> Map String a)
        -> (a -> Bool)
        -> ShowS
505
506

ascii_show_multi_results (r:rs) ss f result_ok
Ian Lynagh's avatar
Ian Lynagh committed
507
        = ascii_header fIELD_WIDTH ss
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
508
509
        . interleave "\n" (map show_results_for_prog results_per_prog_mod_run)
        . str "\n"
510
511
        . if nodevs then id
                    else   str "\n"
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
512
513
514
515
516
                         . 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)
517
  where
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
518
        base_results = Map.toList r :: [(String,Results)]
519

520
521
        -- results_per_prog_mod_run :: [(String,[(String,[BoxValue a])])]
        results_per_prog_mod_run = map get_results_for_prog base_results
522

523
        -- get_results_for_prog :: (String,Results) -> (String,[BoxValue a])
524
        get_results_for_prog (prog,r) = (prog, map get_results_for_mod (Map.toList (f r)))
525

526
           where fms = map get_run_results rs
527

528
529
                 get_run_results fm = case Map.lookup prog fm of
                                        Nothing  -> Map.empty
530
531
532
533
534
535
                                        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
536
537
538
539
540
              str ("\n"++prog++"\n")
            . (if null mrs then
                   str "(no modules compiled)\n"
                 else
                   interleave "\n" (map show_per_prog_results mrs))
541
542
543
544

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


547
548
show_per_prog_results :: (String, [BoxValue]) -> ShowS
show_per_prog_results = show_per_prog_results_width fIELD_WIDTH
549

550
show_per_prog_results_width width (prog,results)
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
551
552
553
        = str (rjustify 15 prog)
        . str (space 5)
        . foldr (.) id (map (str . rjustify width . showBox) results)
554

555
556
-- ---------------------------------------------------------------------------
-- Generic stuff for results generation
557
558

-- calc_result is a nice exercise in higher-order programming...
Ian Lynagh's avatar
Ian Lynagh committed
559
calc_result
560
  :: Result a
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
561
562
563
564
565
566
        => [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])
567
568

calc_result rts get_maybe_a get_stat result_ok (prog,base_r) =
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
        (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'
           )))
584
 where
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
585
586
        baseline  = get_maybe_a base_r
        base_stat = get_stat base_r
587

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
588
        just_result Nothing  s = RunFailed s
589
        just_result (Just a) _ = toBox a
590

591
592
        percentage Nothing   s _    = RunFailed s
        percentage (Just a)  _ base = Percentage
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
593
                                         (convert_to_percentage base a)
594
-----------------------------------------------------------------------------
595
-- Calculating geometric means and standard deviations
596
597
598

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

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
601
        (a1 * .... * an) ^ 1/n
602
603
604

which is equivalent to

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
605
        e ^ ( (log a1 + ... + log an) / n )
606
607

where log is the natural logarithm function.
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623

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.

624
625
-}

626
calc_gmsd :: [BoxValue] -> (BoxValue, BoxValue, BoxValue)
Ian Lynagh's avatar
Ian Lynagh committed
627
calc_gmsd xs
628
629
  | null percentages = (RunFailed NotDone, RunFailed NotDone, RunFailed NotDone)
  | otherwise        = let sqr x = x * x
630
                           len   = fromIntegral (length percentages)
631
632
633
634
635
636
637
638
639
640
                           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))
641
 where
642
  percentages = [ if f < 5 then 5 else f | Percentage f <- xs ]
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
643
        -- can't do log(0.0), so exclude zeros
644
        -- small values have inordinate effects so cap at -95%.
645

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


655
-----------------------------------------------------------------------------
656
657
658
-- Show the Results

class Num a => Result a where
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
659
660
        toBox :: a -> BoxValue
        convert_to_percentage :: a -> a -> Float
661
662
663
664

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

instance Result Int where
665
666
667
    convert_to_percentage 0    _    = 100
    convert_to_percentage base size
        = (fromIntegral size / fromIntegral base) * 100
668

669
    toBox = BoxInt
670
671

instance Result Integer where
672
673
674
675
    convert_to_percentage 0    _    = 100
    convert_to_percentage base size
        = (fromInteger size / fromInteger base) * 100
    toBox = BoxInteger
676
677

instance Result Float where
678
679
    convert_to_percentage 0.0  _    = 100.0
    convert_to_percentage base size = size / base * 100
680

681
    toBox = BoxFloat
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696

-- -----------------------------------------------------------------------------
-- 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
697
showBox (Percentage f)   = printf "%+.1f%%" (f-100)
698
showBox (BoxFloat f)     = printf "%.2f" f
699
700
701
702
showBox (BoxInt n)       = show (n `div` 1024) ++ "k"
showBox (BoxInteger n)   = show (n `div` 1024) ++ "k"
showBox (BoxString s)    = s

703
704
instance Show BoxValue where
    show = showBox
705

706
show_stat :: Status -> String
707
708
709
710
711
712
713
714
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     = "-----"

715
716
717
718
719
720
721
722
723
724
725
726
-- -----------------------------------------------------------------------------
-- 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
727
        do_row TableLine = str (take 80 (repeat '-'))
728
729
730
731

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

latexTableLayout :: Layout
737
738
739
latexTableLayout = box : repeat (box . (" & "++))
  where box s = str (foldr transchar "" s)

Ian Lynagh's avatar
Detab    
Ian Lynagh committed
740
741
        transchar '%' s = s  -- leave out the percentage signs
        transchar c   s = c : s
742
743

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

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

750
751
split :: Char -> String -> [String]
split c s = case rest of
Ian Lynagh's avatar
Ian Lynagh committed
752
                []     -> [chunk]
Ian Lynagh's avatar
Detab    
Ian Lynagh committed
753
                _:rest -> chunk : split c rest
754
755
  where (chunk, rest) = break (==c) s

756
757
str = showString

Ian Lynagh's avatar
Ian Lynagh committed
758
interleave s = foldr1 (\a b -> a . str s . b)
759
760
761
762

fIELD_WIDTH = 16 :: Int

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