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

Read binary profile format

parent 416012f7
module profile2html module profile2html
import StdEnv import StdEnv
import StdMaybe
import Data._Array
import Data.Error import Data.Error
import Data.Func import Data.Func
import Data.Maybe
import qualified Data.Set import qualified Data.Set
import System.CommandLine import System.CommandLine
import System.File import System.File
import System.FilePath import System.FilePath
import System.Options import System.Options
from Text import class Text(concat,join), instance Text String, <+ from Text import class Text(concat,join), instance Text String, <+
import Text.GenJSON
import qualified Text.HTML import qualified Text.HTML
:: Profile = :: Profile =
{ profile :: !Stack { modules :: !.{#String}
, cost_centres :: !.{#CostCentre}
, profile :: !Stack
}
:: CostCentre =
{ cc_module :: !Int
, cc_name :: !String
} }
:: Stack = :: Stack =
{ file :: !String { cost_centre :: !Int
, function :: !String , ticks :: !Int
, ccalls :: !Int , words :: !Int
, lcalls :: !Int , scalls :: !Int
, scalls :: !Int , lcalls :: !Int
, words :: !Int , ccalls :: !Int
, ticks :: !Int , children :: ![Stack]
, children :: ![Stack]
, cumulative_ticks :: !Maybe Int // Filled in by this application , cumulative_ticks :: !Maybe Int // Filled in by this application
, cumulative_words :: !Maybe Int // Filled in by this application , cumulative_words :: !Maybe Int // Filled in by this application
} }
derive JSONDecode Profile, Stack
:: Options = :: Options =
{ input :: !FilePath { input :: !FilePath
, output :: !FilePath , output :: !FilePath
...@@ -56,17 +60,18 @@ Start w ...@@ -56,17 +60,18 @@ Start w
= exit "Specify an input file with -i/--input" w = exit "Specify an input file with -i/--input" w
| args.output=="" | args.output==""
= exit "Specify an output file with -o/--output" w = exit "Specify an output file with -o/--output" w
# (input,w) = readFile args.input w # (ok,input,w) = fopen args.input FReadData w
| isError input | not ok
= exit ("Error while reading input: " <+ fromError input) w = exit "Could not open input file" w
# input = fromJSON (fromString (fromOk input)) # (profile,input) = read_profile input
| isNothing input # (_,w) = fclose input w
= exit "Could not parse input" w | isError profile
# input = prepare args.min_cumulative_ticks args.exclude (fromJust input) = 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 # (ok,f,w) = fopen args.output FWriteText w
| not ok | not ok
= exit "Could not open output file" w = exit "Could not open output file" w
# f = f <<< input # f = f <<< profile
# (_,w) = fclose f w # (_,w) = fclose f w
= w = w
where where
...@@ -99,61 +104,175 @@ where ...@@ -99,61 +104,175 @@ where
# (_,w) = fclose (stderr <<< err <<< '\n') w # (_,w) = fclose (stderr <<< err <<< '\n') w
= setReturnCode -1 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 :: !Int !('Data.Set'.Set String) !Profile -> Profile
prepare min_cumulative_ticks excluded p = prepare min_cumulative_ticks excluded p =
{ p { p
& profile = & profile =
compute_sums_prune_and_sort min_cumulative_ticks $ compute_sums_prune_and_sort (fromMaybe -1 gc_id) min_cumulative_ticks $
lift_garbage_collector $ (case gc_id of
(if ('Data.Set'.size excluded==0) id (remove_excluded_functions excluded)) Nothing -> id
Just id -> lift_garbage_collector id) $
(if ('Data.Set'.size excluded==0) id (remove_excluded_functions excluded_ids))
p.profile 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 = remove_excluded_functions excluded s =
{ s { s
& children = & children =
[ remove_excluded_functions excluded c [ remove_excluded_functions excluded c
\\ c <- s.children \\ 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 :: !Int !Stack -> Stack
lift_garbage_collector s lift_garbage_collector cost_centre_id s
# (s,(ticks,calls)) = walk s 0 0 # (s,(ticks,calls)) = walk s 0 0
| calls==0 | calls==0
= s = s
= {s & children=[gc:s.children]} = {s & children=[gc:s.children]}
with with
gc = gc =
{ file = "System" { cost_centre = cost_centre_id
, function = "garbage_collector" , ccalls = 0
, ccalls = 0 , lcalls = 0
, lcalls = 0 , scalls = calls
, scalls = calls , words = 0
, words = 0 , ticks = ticks
, ticks = ticks , children = []
, children = []
, cumulative_ticks = Just ticks , cumulative_ticks = Just ticks
, cumulative_words = Just 0 , cumulative_words = Just 0
} }
where where
walk :: !Stack !Int !Int -> (!Stack, !(!Int,!Int)) walk :: !Stack !Int !Int -> (!Stack, !(!Int,!Int))
walk s ticks calls walk s ticks calls
| is_gc s | s.cost_centre==cost_centre_id
= (s, (ticks+s.ticks, calls+s.scalls)) = (s, (ticks+s.ticks, calls+s.scalls))
# (children,counts) = mapSt (\c (ts,cs) -> walk c ts cs) s.children (ticks,calls) # (children,counts) = mapSt (\c (ts,cs) -> walk c ts cs) s.children (ticks,calls)
= ({s & children=[c \\ c <- children | not (is_gc c)]}, counts) = ({s & children=[c \\ c <- children | c.cost_centre <> cost_centre_id]}, counts)
where
is_gc s = s.file=="System" && s.function=="garbage_collector"
compute_sums_prune_and_sort :: !Int !Stack -> Stack compute_sums_prune_and_sort :: !Int !Int !Stack -> Stack
compute_sums_prune_and_sort min_cumulative_ticks s compute_sums_prune_and_sort gc_id min_cumulative_ticks s
# children = reverse (sort (map (compute_sums_prune_and_sort min_cumulative_ticks) s.children)) # 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_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 & 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 = s
instance < Stack instance < Stack
...@@ -162,8 +281,8 @@ where ...@@ -162,8 +281,8 @@ where
instance <<< Profile instance <<< Profile
where where
<<< f p = <<< f p
f <<< "<!DOCTYPE html>" # f = f <<< "<!DOCTYPE html>"
<<< "<html lang=\"en\">" <<< "<html lang=\"en\">"
<<< "<head>" <<< "<head>"
<<< "<title>Profile</title>" <<< "<title>Profile</title>"
...@@ -179,60 +298,62 @@ where ...@@ -179,60 +298,62 @@ where
<<< "<span class=\"entry-data\">Lazy calls</span>" <<< "<span class=\"entry-data\">Lazy calls</span>"
<<< "<span class=\"entry-data\">Strict calls</span>" <<< "<span class=\"entry-data\">Strict calls</span>"
<<< "</div>" <<< "</div>"
<<< p.profile # f = write_stack p p.profile f
= f
<<< "<script defer=\"defer\" src=\"profile.js\"></script>" <<< "<script defer=\"defer\" src=\"profile.js\"></script>"
<<< "</body>" <<< "</body>"
<<< "</html>" <<< "</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 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 where
write :: !Int !Int !Stack !*File -> *File cost_centre = p.cost_centres.[s.cost_centre]
write parent_ticks parent_words s f
# f = f <<< "<div class=\"entry\">" cumulative_ticks = fromJust s.cumulative_ticks
<<< "<div class=\"entry-header\">" ticks = if (isEmpty s.children)
<<< if (isEmpty s.children) "" "<span class=\"toggler open\">&#x229f;</span>" (toString s.ticks)
<<< "<span class=\"entry-content\">" <<< 'Text.HTML'.escapeStr s.file (concat [toString cumulative_ticks," (",toString s.ticks,")"])
<<< ": <span class=\"function\">" <<< 'Text.HTML'.escapeStr s.function <<< "</span></span>" ticks_width = toWidth (toReal cumulative_ticks / toReal parent_ticks)
<<< "&nbsp;"
<<< "<span class=\"progress words\" title=\"" <<< words <<< "\">" cumulative_words = fromJust s.cumulative_words
<<< if (parent_words==0) "" (concat ["<span class=\"bar\" style=\"",words_width,"\"></span>"]) words = if (isEmpty s.children)
<<< "</span>" (toString s.words)
<<< "<span class=\"progress ticks\" title=\"" <<< ticks <<< "\">" (concat [toString cumulative_words," (",toString s.words,")"])
<<< if (parent_ticks==0) "" (concat ["<span class=\"bar\" style=\"",ticks_width,"\"></span>"]) words_width = toWidth (toReal cumulative_words / toReal parent_words)
<<< "</span>"
<<< "<span class=\"entry-data\">" <<< if (s.ccalls==0) "&nbsp;" (toString s.ccalls) <<< "</span>" toWidth :: !Real -> String
<<< "<span class=\"entry-data\">" <<< if (s.lcalls==0) "&nbsp;" (toString s.lcalls) <<< "</span>" toWidth w
<<< "<span class=\"entry-data\">" <<< if (s.scalls==0) "&nbsp;" (toString s.scalls) <<< "</span>" | wi>=10000
<<< "</div>" = "width:100%;"
# f = foldl (\f c -> write cumulative_ticks cumulative_words c f) f s.children =
= f <<< "</div>" { '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 where
cumulative_ticks = fromJust s.cumulative_ticks wi = toInt (w * 10000.0)
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)
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