Verified Commit 88204a1c authored by Camil Staps's avatar Camil Staps 🚀

Initial commit

parents
*.abc
*.o
profile2html
body {
font-family: sans-serif;
}
.function {
font-family: monospace;
}
.toggler {
cursor: pointer;
}
.progress {
background-color: #e0e0e0;
border: 1px solid #6cb4ef;
box-sizing: border-box;
display: inline-block;
height: 1.2em;
position: relative;
width: 12em;
}
.progress::before {
content: attr(title);
font-size: 80%;
left: 0;
line-height: 1.5em;
position: absolute;
right: 0;
text-align: center;
top: 0;
}
.progress .bar {
background-color: #6cb4ef;
display: inline-block;
height: 100%;
}
.entry {
clear: both;
}
.entry::after {
clear: both;
content: '';
display: table;
}
.entry > .entry {
background-color: rgba(0,0,0,0.05);
margin-left: 1em;
}
.entry-header {
margin-bottom: 1px;
width: 100%;
}
.entry-header:hover {
background-color: #ee8;
}
.entry-header > * {
float: right;
margin-left: 1ex;
}
.entry-content, .toggler {
float: left;
}
.entry-data {
text-align: right;
width: 7em;
}
.header > * {
float: right;
font-weight: bold;
margin-left: 1ex;
}
.header > *:first-child {
float: left;
text-align: left;
}
.progress-header {
width: 12em;
}
"use strict";
function toggle () {
let toggler=this;
let entry=toggler.parentNode.parentNode;
var display='block';
if (toggler.classList.contains ('open')) {
display='none';
toggler.innerHTML='⊞';
} else {
toggler.innerHTML='⊟';
}
toggler.classList.toggle ('open');
toggler.classList.toggle ('closed');
let children=entry.children;
for (var i=1; i<children.length; i++)
children[i].style.display=display;
}
let elems=document.getElementsByClassName ('toggler');
for (var i=0; i<elems.length; i++) {
elems[i].onclick=toggle;
elems[i].onclick();
}
module profile2html
import StdEnv
import StdMaybe
import Data.Error
import Data.Func
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
}
:: Stack =
{ file :: !String
, function :: !String
, ccalls :: !Int
, lcalls :: !Int
, scalls :: !Int
, words :: !Int
, ticks :: !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
}
defaultOptions =
{ input = ""
, output = ""
}
Start w
# ([prog:args],w) = getCommandLine w
# args = parseOptions option_description args defaultOptions
| isError args
= exit (join "\n" (fromError args)) w
# args = fromOk args
| args.input==""
= 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 = fromJust input
input & profile = compute_sums_and_sort (lift_garbage_collector input.profile)
# (ok,f,w) = fopen args.output FWriteText w
| not ok
= exit "Could not open output file" w
# f = f <<< input
# (_,w) = fclose f w
= w
where
option_description = WithHelp True $ Options
[ Shorthand "-i" "--input" $ Option "--input"
(\ip opts -> Ok {opts & input=ip})
"INPUT"
"The input file"
, Shorthand "-o" "--output" $ Option "--output"
(\op opts -> Ok {opts & output=op})
"OUTPUT"
"The output file"
]
exit err w
# (_,w) = fclose (stderr <<< err <<< '\n') w
= setReturnCode -1 w
lift_garbage_collector :: !Stack -> Stack
lift_garbage_collector 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 = []
, cumulative_ticks = Just ticks
, cumulative_words = Just 0
}
where
walk :: !Stack !Int !Int -> (!Stack, !(!Int,!Int))
walk s ticks calls
| is_gc s
= (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"
compute_sums_and_sort :: !Stack -> Stack
compute_sums_and_sort s
# s & children = reverse (sort (map compute_sums_and_sort s.children))
s & cumulative_ticks = Just (s.ticks + sum [t \\ {cumulative_ticks=Just t} <- s.children])
s & cumulative_words = Just (s.words + sum [w \\ {cumulative_words=Just w} <- s.children])
= s
instance < Stack
where
< a b
| a.children=:[] && b.children=:[_:_]
= True
| a.children=:[_:_] && b.children=:[]
= False
= fromJust a.cumulative_ticks < fromJust b.cumulative_ticks
instance <<< Profile
where
<<< f p =
f <<< "<!DOCTYPE html>"
<<< "<html lang=\"en\">"
<<< "<head>"
<<< "<title>Profile</title>"
<<< "<meta charset=\"utf-8\">"
<<< "<link rel=\"stylesheet\" type=\"text/css\" href=\"profile.css\">"
<<< "</head>"
<<< "<body>"
<<< "<div class=\"header\">"
<<< "<span class=\"entry-data\">Function</span>"
<<< "<span class=\"progress-header\">Words</span>"
<<< "<span class=\"progress-header\">Ticks</span>"
<<< "<span class=\"entry-data\">Curried calls</span>"
<<< "<span class=\"entry-data\">Lazy calls</span>"
<<< "<span class=\"entry-data\">Strict calls</span>"
<<< "</div>"
<<< p.profile
<<< "<script defer=\"defer\" src=\"profile.js\"></script>"
<<< "</body>"
<<< "</html>"
instance <<< Stack
where
<<< f s = write (fromJust s.cumulative_ticks) (fromJust s.cumulative_words) s f
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>"
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)
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