Verified Commit 8d8c6bf1 authored by Camil Staps's avatar Camil Staps 🚀

Read binary profile format

parent 416012f7
module profile2html
import StdEnv
import StdMaybe
import Data._Array
import Data.Error
import Data.Func
import Data.Maybe
import qualified Data.Set
import System.CommandLine
import System.File
import System.FilePath
import System.Options
from Text import class Text(concat,join), instance Text String, <+
import Text.GenJSON
import qualified Text.HTML
:: Profile =
{ profile :: !Stack
{ modules :: !.{#String}
, cost_centres :: !.{#CostCentre}
, profile :: !Stack
}
:: CostCentre =
{ cc_module :: !Int
, cc_name :: !String
}
:: Stack =
{ file :: !String
, function :: !String
, ccalls :: !Int
, lcalls :: !Int
, scalls :: !Int
, words :: !Int
, ticks :: !Int
, children :: ![Stack]
{ cost_centre :: !Int
, ticks :: !Int
, words :: !Int
, scalls :: !Int
, lcalls :: !Int
, ccalls :: !Int
, children :: ![Stack]
, cumulative_ticks :: !Maybe Int // Filled in by this application
, cumulative_words :: !Maybe Int // Filled in by this application
}
derive JSONDecode Profile, Stack
:: Options =
{ input :: !FilePath
, output :: !FilePath
......@@ -56,17 +60,18 @@ Start w
= exit "Specify an input file with -i/--input" w
| args.output==""
= exit "Specify an output file with -o/--output" w
# (input,w) = readFile args.input w
| isError input
= exit ("Error while reading input: " <+ fromError input) w
# input = fromJSON (fromString (fromOk input))
| isNothing input
= exit "Could not parse input" w
# input = prepare args.min_cumulative_ticks args.exclude (fromJust input)
# (ok,input,w) = fopen args.input FReadData w
| not ok
= exit "Could not open input file" w
# (profile,input) = read_profile input
# (_,w) = fclose input w
| isError profile
= exit ("Could not parse input: "+++fromError profile) w
# profile = prepare args.min_cumulative_ticks args.exclude (fromOk profile)
# (ok,f,w) = fopen args.output FWriteText w
| not ok
= exit "Could not open output file" w
# f = f <<< input
# f = f <<< profile
# (_,w) = fclose f w
= w
where
......@@ -99,61 +104,175 @@ where
# (_,w) = fclose (stderr <<< err <<< '\n') w
= setReturnCode -1 w
read_profile :: !*File -> (!MaybeError String Profile, !*File)
read_profile f
# (header,f) = freads f 4
| header <> "prof" = (Error "invalid header",f)
# (ok,version,f) = freadi f
| not ok = (unexpected_eof,f)
| version <> 1 = (Error "invalid version number",f)
# (ok,n_modules,f) = freadi f
| not ok = (unexpected_eof,f)
# (ok,n_cost_centres,f) = freadi f
| not ok = (unexpected_eof,f)
# (modules,f) = read_modules 0 n_modules (unsafeCreateArray n_modules) f
| isError modules = (Error (fromError modules),f)
# (cost_centres,f) = read_cost_centres 0 n_cost_centres (unsafeCreateArray n_cost_centres) f
| isError cost_centres = (Error (fromError cost_centres),f)
# (profile,f) = read_profile_stack f
| isError profile = (Error (fromError profile),f)
# profile =
{ modules = fromOk modules
, cost_centres = fromOk cost_centres
, profile = fromOk profile
}
= (Ok profile,f)
where
unexpected_eof :: .MaybeError String .a
unexpected_eof = Error "unexpected end of file"
read_modules :: !Int !Int !*{#String} !*File -> (!MaybeError String *{#String}, !*File)
read_modules i n arr f
| i==n
= (Ok arr,f)
# (name,f) = read_nul_terminated_string [] f
| isError name
= (Error (fromError name),f)
= read_modules (i+1) n {arr & [i]=fromOk name} f
read_cost_centres :: !Int !Int !*{#CostCentre} !*File -> (!MaybeError String *{#CostCentre}, !*File)
read_cost_centres i n arr f
| i==n
= (Ok arr,f)
# (ok,module_id,f) = freadi f
| not ok = (unexpected_eof,f)
# (name,f) = read_nul_terminated_string [] f
| isError name
= (Error (fromError name),f)
= read_cost_centres (i+1) n {arr & [i]={cc_module=module_id-1,cc_name=fromOk name}} f
read_profile_stack :: !*File -> (!MaybeError String Stack, !*File)
read_profile_stack f
# (ok,cost_centre,f) = freadi f
| not ok = (unexpected_eof,f)
# (ok,ticks,f) = freadi f
| not ok = (unexpected_eof,f)
# (ok,words,f) = freadi f
| not ok = (unexpected_eof,f)
# (ok,scalls,f) = freadi f
| not ok = (unexpected_eof,f)
# (ok,lcalls,f) = freadi f
| not ok = (unexpected_eof,f)
# (ok,ccalls,f) = freadi f
| not ok = (unexpected_eof,f)
# (ok,n_children,f) = freadi f
| not ok = (unexpected_eof,f)
# (children,f) = read_profile_stacks n_children [] f
| isError children = (Error (fromError children),f)
# profile =
{ cost_centre = cost_centre-1
, ticks = ticks
, words = words
, scalls = scalls
, lcalls = lcalls
, ccalls = ccalls
, children = fromOk children
, cumulative_ticks = Nothing
, cumulative_words = Nothing
}
= (Ok profile,f)
where
read_profile_stacks :: !Int ![Stack] !*File -> (!MaybeError String [Stack], !*File)
read_profile_stacks 0 ss f
= (Ok ss,f)
read_profile_stacks i ss f
# (stack,f) = read_profile_stack f
| isError stack
= (Error (fromError stack),f)
= read_profile_stacks (i-1) [fromOk stack:ss] f
read_nul_terminated_string :: ![Char] !*File -> (!MaybeError String {#Char},!*File)
read_nul_terminated_string cs f
# (ok,c,f) = freadc f
| not ok
= (unexpected_eof,f)
| c=='\0'
= (Ok {c \\ c <- reverse cs},f)
= read_nul_terminated_string [c:cs] f
prepare :: !Int !('Data.Set'.Set String) !Profile -> Profile
prepare min_cumulative_ticks excluded p =
{ p
& profile =
compute_sums_prune_and_sort min_cumulative_ticks $
lift_garbage_collector $
(if ('Data.Set'.size excluded==0) id (remove_excluded_functions excluded))
compute_sums_prune_and_sort (fromMaybe -1 gc_id) min_cumulative_ticks $
(case gc_id of
Nothing -> id
Just id -> lift_garbage_collector id) $
(if ('Data.Set'.size excluded==0) id (remove_excluded_functions excluded_ids))
p.profile
}
where
gc_id =
case
[ i \\ c <-: p.cost_centres & i <- [0..]
| c.cc_name=="garbage_collector"
&& p.modules.[c.cc_module]=="System"]
of
[id:_]
-> Just id
-> Nothing
remove_excluded_functions :: !('Data.Set'.Set String) !Stack -> Stack
excluded_ids = 'Data.Set'.fromList
[ i \\ c <-: p.cost_centres & i <- [0..]
| 'Data.Set'.member (concat [p.modules.[c.cc_module],":",c.cc_name]) excluded
]
remove_excluded_functions :: !('Data.Set'.Set Int) !Stack -> Stack
remove_excluded_functions excluded s =
{ s
& children =
[ remove_excluded_functions excluded c
\\ c <- s.children
| not ('Data.Set'.member (concat [c.file,":",c.function]) excluded)
| not ('Data.Set'.member c.cost_centre excluded)
]
}
lift_garbage_collector :: !Stack -> Stack
lift_garbage_collector s
lift_garbage_collector :: !Int !Stack -> Stack
lift_garbage_collector cost_centre_id s
# (s,(ticks,calls)) = walk s 0 0
| calls==0
= s
= {s & children=[gc:s.children]}
with
gc =
{ file = "System"
, function = "garbage_collector"
, ccalls = 0
, lcalls = 0
, scalls = calls
, words = 0
, ticks = ticks
, children = []
{ cost_centre = cost_centre_id
, ccalls = 0
, lcalls = 0
, scalls = calls
, words = 0
, ticks = ticks
, children = []
, cumulative_ticks = Just ticks
, cumulative_words = Just 0
}
where
walk :: !Stack !Int !Int -> (!Stack, !(!Int,!Int))
walk s ticks calls
| is_gc s
| s.cost_centre==cost_centre_id
= (s, (ticks+s.ticks, calls+s.scalls))
# (children,counts) = mapSt (\c (ts,cs) -> walk c ts cs) s.children (ticks,calls)
= ({s & children=[c \\ c <- children | not (is_gc c)]}, counts)
where
is_gc s = s.file=="System" && s.function=="garbage_collector"
= ({s & children=[c \\ c <- children | c.cost_centre <> cost_centre_id]}, counts)
compute_sums_prune_and_sort :: !Int !Stack -> Stack
compute_sums_prune_and_sort min_cumulative_ticks s
# children = reverse (sort (map (compute_sums_prune_and_sort min_cumulative_ticks) s.children))
compute_sums_prune_and_sort :: !Int !Int !Stack -> Stack
compute_sums_prune_and_sort gc_id min_cumulative_ticks s
# children = reverse (sort [compute_sums_prune_and_sort gc_id min_cumulative_ticks c \\ c <- s.children])
s & cumulative_ticks = Just (s.ticks + sum [t \\ {cumulative_ticks=Just t} <- children])
s & cumulative_words = Just (s.words + sum [w \\ {cumulative_words=Just w} <- children])
s & children = [c \\ c <- children | fromJust c.cumulative_ticks >= min_cumulative_ticks]
s & children =
[ c \\ c <- children
| fromJust c.cumulative_ticks >= min_cumulative_ticks
|| c.cost_centre==gc_id
]
= s
instance < Stack
......@@ -162,8 +281,8 @@ where
instance <<< Profile
where
<<< f p =
f <<< "<!DOCTYPE html>"
<<< f p
# f = f <<< "<!DOCTYPE html>"
<<< "<html lang=\"en\">"
<<< "<head>"
<<< "<title>Profile</title>"
......@@ -179,60 +298,62 @@ where
<<< "<span class=\"entry-data\">Lazy calls</span>"
<<< "<span class=\"entry-data\">Strict calls</span>"
<<< "</div>"
<<< p.profile
# f = write_stack p p.profile f
= f
<<< "<script defer=\"defer\" src=\"profile.js\"></script>"
<<< "</body>"
<<< "</html>"
instance <<< Stack
write_stack :: !Profile !Stack !*File -> *File
write_stack p s f = write (fromJust s.cumulative_ticks) (fromJust s.cumulative_words) s f
where
<<< f s = write (fromJust s.cumulative_ticks) (fromJust s.cumulative_words) s f
write :: !Int !Int !Stack !*File -> *File
write parent_ticks parent_words s f
# f = f <<< "<div class=\"entry\">"
<<< "<div class=\"entry-header\">"
<<< if (isEmpty s.children) "" "<span class=\"toggler open\">&#x229f;</span>"
<<< "<span class=\"entry-content\">" <<< 'Text.HTML'.escapeStr p.modules.[cost_centre.cc_module]
<<< ": <span class=\"function\">" <<< 'Text.HTML'.escapeStr cost_centre.cc_name <<< "</span></span>"
<<< "&nbsp;"
<<< "<span class=\"progress words\" title=\"" <<< words <<< "\">"
<<< if (parent_words==0) "" (concat ["<span class=\"bar\" style=\"",words_width,"\"></span>"])
<<< "</span>"
<<< "<span class=\"progress ticks\" title=\"" <<< ticks <<< "\">"
<<< if (parent_ticks==0) "" (concat ["<span class=\"bar\" style=\"",ticks_width,"\"></span>"])
<<< "</span>"
<<< "<span class=\"entry-data\">" <<< if (s.ccalls==0) "&nbsp;" (toString s.ccalls) <<< "</span>"
<<< "<span class=\"entry-data\">" <<< if (s.lcalls==0) "&nbsp;" (toString s.lcalls) <<< "</span>"
<<< "<span class=\"entry-data\">" <<< if (s.scalls==0) "&nbsp;" (toString s.scalls) <<< "</span>"
<<< "</div>"
# f = foldl (\f c -> write cumulative_ticks cumulative_words c f) f s.children
= f <<< "</div>"
where
write :: !Int !Int !Stack !*File -> *File
write parent_ticks parent_words s f
# f = f <<< "<div class=\"entry\">"
<<< "<div class=\"entry-header\">"
<<< if (isEmpty s.children) "" "<span class=\"toggler open\">&#x229f;</span>"
<<< "<span class=\"entry-content\">" <<< 'Text.HTML'.escapeStr s.file
<<< ": <span class=\"function\">" <<< 'Text.HTML'.escapeStr s.function <<< "</span></span>"
<<< "&nbsp;"
<<< "<span class=\"progress words\" title=\"" <<< words <<< "\">"
<<< if (parent_words==0) "" (concat ["<span class=\"bar\" style=\"",words_width,"\"></span>"])
<<< "</span>"
<<< "<span class=\"progress ticks\" title=\"" <<< ticks <<< "\">"
<<< if (parent_ticks==0) "" (concat ["<span class=\"bar\" style=\"",ticks_width,"\"></span>"])
<<< "</span>"
<<< "<span class=\"entry-data\">" <<< if (s.ccalls==0) "&nbsp;" (toString s.ccalls) <<< "</span>"
<<< "<span class=\"entry-data\">" <<< if (s.lcalls==0) "&nbsp;" (toString s.lcalls) <<< "</span>"
<<< "<span class=\"entry-data\">" <<< if (s.scalls==0) "&nbsp;" (toString s.scalls) <<< "</span>"
<<< "</div>"
# f = foldl (\f c -> write cumulative_ticks cumulative_words c f) f s.children
= f <<< "</div>"
cost_centre = p.cost_centres.[s.cost_centre]
cumulative_ticks = fromJust s.cumulative_ticks
ticks = if (isEmpty s.children)
(toString s.ticks)
(concat [toString cumulative_ticks," (",toString s.ticks,")"])
ticks_width = toWidth (toReal cumulative_ticks / toReal parent_ticks)
cumulative_words = fromJust s.cumulative_words
words = if (isEmpty s.children)
(toString s.words)
(concat [toString cumulative_words," (",toString s.words,")"])
words_width = toWidth (toReal cumulative_words / toReal parent_words)
toWidth :: !Real -> String
toWidth w
| wi>=10000
= "width:100%;"
=
{ 'w','i','d','t','h',':'
, toChar (wi/1000)+'0'
, toChar ((wi rem 1000)/100)+'0'
, '.'
, toChar ((wi rem 100)/10)+'0'
, toChar (wi rem 10)+'0'
, '%',';'
}
where
cumulative_ticks = fromJust s.cumulative_ticks
ticks = if (isEmpty s.children)
(toString s.ticks)
(concat [toString cumulative_ticks," (",toString s.ticks,")"])
ticks_width = toWidth (toReal cumulative_ticks / toReal parent_ticks)
cumulative_words = fromJust s.cumulative_words
words = if (isEmpty s.children)
(toString s.words)
(concat [toString cumulative_words," (",toString s.words,")"])
words_width = toWidth (toReal cumulative_words / toReal parent_words)
toWidth :: !Real -> String
toWidth w
| wi>=10000
= "width:100%;"
=
{ 'w','i','d','t','h',':'
, toChar (wi/1000)+'0'
, toChar ((wi rem 1000)/100)+'0'
, '.'
, toChar ((wi rem 100)/10)+'0'
, toChar (wi rem 10)+'0'
, '%',';'
}
where
wi = toInt (w * 10000.0)
wi = toInt (w * 10000.0)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment