diff --git a/hls-graph.cabal b/hls-graph.cabal --- a/hls-graph.cabal +++ b/hls-graph.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-graph -version: 1.4.0.0 +version: 1.5.1.0 synopsis: Haskell Language Server internal graph API description: Please see the README on GitHub at @@ -14,12 +14,20 @@ copyright: The Haskell IDE Team category: Development build-type: Simple +data-files: + html/profile.html + html/shake.js flag pedantic description: Enable -Werror default: False manual: True +flag embed-files + default: False + manual: True + description: Embed data files into the shake library + source-repository head type: git location: https://github.com/haskell/haskell-language-server @@ -30,18 +38,45 @@ Development.IDE.Graph.Classes Development.IDE.Graph.Database Development.IDE.Graph.Rule - - other-modules: Development.IDE.Graph.Internal.Action Development.IDE.Graph.Internal.Options Development.IDE.Graph.Internal.Rules + Development.IDE.Graph.Internal.Database + Development.IDE.Graph.Internal.Ids + Development.IDE.Graph.Internal.Intern + Development.IDE.Graph.Internal.Paths + Development.IDE.Graph.Internal.Profile + Development.IDE.Graph.Internal.Types + Paths_hls_graph + autogen-modules: Paths_hls_graph + hs-source-dirs: src build-depends: + , aeson + , async , base >=4.12 && <5 , bytestring - , shake >= 0.19.4 + , containers + , deepseq + , directory + , exceptions + , extra + , filepath + , hashable + , js-dgtable + , js-flot + , js-jquery + , primitive + , time + , transformers , unordered-containers + + if flag(embed-files) + cpp-options: -DFILE_EMBED + build-depends: + file-embed >= 0.0.11, + template-haskell ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing diff --git a/html/profile.html b/html/profile.html new file mode 100644 --- /dev/null +++ b/html/profile.html @@ -0,0 +1,211 @@ + + + + + +Shake report + + + + + + + + + + + + + + + + + + Loading... + + diff --git a/html/shake.js b/html/shake.js new file mode 100644 --- /dev/null +++ b/html/shake.js @@ -0,0 +1,1058 @@ +"use strict"; +function bindPlot(element, data, options) { + const redraw = () => { + if ($(element).is(":visible")) + $.plot($(element), data.get(), options); + }; + window.setTimeout(redraw, 1); + $(window).on("resize", redraw); + data.event(redraw); +} +function varLink(name) { + return React.createElement("a", { href: "https://hackage.haskell.org/package/shake/docs/Development-Shake.html#v:" + name }, + React.createElement("tt", null, name)); +} +function newTable(columns, data, sortColumn, sortDescend) { + const f = (x) => ({ name: x.field, label: x.label, width: x.width, cellClasses: x.alignRight ? "right" : "" }); + const formatters = {}; + for (const c of columns) + formatters[c.field] = c.show || ((x) => x); + const table = new DGTable({ + adjustColumnWidthForSortArrow: false, + cellFormatter: (val, colname) => formatters[colname](val), + columns: columns.map(f), + width: DGTable.Width.SCROLL + }); + $(table.el).css("height", "100%"); + window.setTimeout(() => { + table.render(); + table.tableHeightChanged(); + if (sortColumn) + table.sort(sortColumn, sortDescend); + table.setRows(data.get(), true); + }, 1); + let toRender = false; + data.event(xs => { + table.setRows(xs, true); + if ($(table.el).is(":visible")) + table.render(); + else + toRender = true; + }); + $(window).on("resize", () => { + if ($(table.el).is(":visible")) { + table.tableHeightChanged(); + if (toRender) { + table.render(); + toRender = false; + } + } + }); + return React.createElement("div", { style: "height:100%;width:100%;" }, table.el); +} +// These are global variables mutated/queried by query execution +let environmentAll; // All the profiles +let environmentThis; // The specific profile under test +let environmentGroup; // The group produced as a result +function group(x) { + environmentGroup.push(x); + return true; +} +function leaf() { + return environmentThis.depends.length === 0; +} +function run(i) { + if (i === undefined) + return environmentThis.built; + else + return environmentThis.built === i; +} +function changed() { + return environmentThis.changed === environmentThis.built; +} +function visited(i) { + if (i === undefined) + return environmentThis.visited; + else + return environmentThis.visited === i; +} +function unchanged() { + return !unchanged(); +} +function named(r, groupName) { + if (r === undefined) + return environmentThis.name; + const res = execRegExp(r, environmentThis.name); + if (res === null) { + if (groupName === undefined) + return false; + else { + group(groupName); + return true; + } + } + if (res.length !== 1) { + for (let i = 1; i < res.length; i++) + group(res[i]); + } + return true; +} +function command(r, groupName) { + const n = (environmentThis.traces || []).length; + if (r === undefined) + return n === 0 ? "" : environmentThis.traces[0].command; + for (const t of environmentThis.traces) { + const res = execRegExp(r, t.command); + if (res === null) + continue; + if (res.length !== 1) { + for (let j = 1; j < res.length; j++) + group(res[j]); + } + return true; + } + if (groupName === undefined) + return false; + else { + group(groupName); + return true; + } +} +function profileLoaded(profileRaw, buildRaw) { + $(document.body).empty().append(profileRoot(unraw(profileRaw), unrawBuild(buildRaw))); +} +function unraw(xs) { + const ans = xs.map((x, i) => ({ + index: i, + name: x[0], + execution: x[1], + built: x[2], + changed: x[3], + visited: x[4], + depends: x.length > 5 ? x[5] : [], + rdepends: [], + traces: [] + })); + for (const p of ans) + for (const ds of p.depends) + for (const d of ds) + ans[d].rdepends.push(p.index); + return ans; +} +function unrawBuild(b) { + return { dirtyKeys: b.length > 0 ? b[0] : null }; +} +function profileRoot(profile, build) { + const [s, search] = createSearch(profile); + const t = createTabs([["Summary", () => reportSummary(profile, build)], + ["Rules", () => reportRuleTable(profile, search)], + ["Parallelizability", () => reportParallelism(profile)], + ["Details", () => reportDetails(profile, search)] + // , ["Why rebuild", () => reportRebuild(profile, search)] + ]); + return React.createElement("table", { class: "fill" }, + React.createElement("tr", null, + React.createElement("td", { style: "padding-top: 8px; padding-bottom: 8px;" }, + React.createElement("a", { href: "https://shakebuild.com/", style: "font-size: 20px; text-decoration: none; color: #3131a7; font-weight: bold;" }, "Shake profile report"), + React.createElement("span", { style: "color:gray;white-space:pre;" }, + " - generated at ", + generated, + " by hls-graph v", + version))), + React.createElement("tr", null, + React.createElement("td", null, s)), + React.createElement("tr", null, + React.createElement("td", { height: "100%" }, t))); +} +function createTabs(xs) { + const bodies = xs.map(x => { + const el = React.createElement("div", { style: "padding:5px;width:100%;height:100%;min-width:150px;min-height:150px;overflow:auto;display:none;" }); + const upd = lazy(() => $(el).append(x[1]())); + return pair(el, upd); + }); + let lbls = []; + const f = (i) => () => { + bodies[i][1](); + lbls.map((x, j) => $(x).toggleClass("active", i === j)); + bodies.map((x, j) => $(x[0]).toggle(i === j)); + $(window).trigger("resize"); + }; + lbls = xs.map((x, i) => React.createElement("a", { onclick: f(i) }, x[0])); + f(0)(); + return React.createElement("table", { class: "fill" }, + React.createElement("tr", null, + React.createElement("td", null, + React.createElement("table", { width: "100%", style: "border-spacing:0px;" }, + React.createElement("tr", { class: "tabstrip" }, + React.createElement("td", { width: "20", class: "bottom" }, "\u00A0"), + React.createElement("td", { style: "padding:0px;" }, lbls), + React.createElement("td", { width: "100%", class: "bottom" }, "\u00A0"))))), + React.createElement("tr", { height: "100%" }, + React.createElement("td", { style: "background-color:white;" }, bodies.map(fst)))); +} +// A mapping from names (rule names or those matched from rule parts) +// to the indicies in profiles. +class Search { + profile; + mapping; + constructor(profile, mapping) { + this.profile = profile; + if (mapping !== undefined) + this.mapping = mapping; + else { + this.mapping = {}; + for (const p of profile) + this.mapping[p.name] = [p.index]; + } + } + forEachProfiles(f) { + for (const s in this.mapping) + f(this.mapping[s].map(i => this.profile[i]), s); + } + forEachProfile(f) { + this.forEachProfiles((ps, group) => ps.forEach(p => f(p, group))); + } + mapProfiles(f) { + const res = []; + this.forEachProfiles((ps, group) => res.push(f(ps, group))); + return res; + } + mapProfile(f) { + const res = []; + this.forEachProfile((p, group) => res.push(f(p, group))); + return res; + } +} +function createSearch(profile) { + const caption = React.createElement("div", null, + "Found ", + profile.length, + " entries, not filtered or grouped."); + const input = React.createElement("input", { id: "search", type: "text", value: "", placeholder: "Filter and group", style: "width: 100%; font-size: 16px; border-radius: 8px; padding: 5px 10px; border: 2px solid #999;" }); + const res = new Prop(new Search(profile)); + $(input).on("change keyup paste", () => { + const s = $(input).val(); + if (s === "") { + res.set(new Search(profile)); + $(caption).text("Found " + profile.length + " entries, not filtered or grouped."); + } + else if (s.indexOf("(") === -1) { + const mapping = {}; + let found = 0; + for (const p of profile) { + if (p.name.indexOf(s) !== -1) { + found++; + mapping[p.name] = [p.index]; + } + } + res.set(new Search(profile, mapping)); + $(caption).text("Substring filtered to " + found + " / " + profile.length + " entries, not grouped."); + } + else { + let f; + try { + f = new Function("return " + s); + } + catch (e) { + $(caption).text("Error compiling function, " + e); + return; + } + const mapping = {}; + let groups = 0; + let found = 0; + environmentAll = profile; + for (const p of profile) { + environmentThis = p; + environmentGroup = []; + let bool; + try { + bool = f(); + } + catch (e) { + $(caption).text("Error running function, " + e); + return; + } + if (bool) { + found++; + const name = environmentGroup.length === 0 ? p.name : environmentGroup.join(" "); + if (name in mapping) + mapping[name].push(p.index); + else { + groups++; + mapping[name] = [p.index]; + } + } + } + res.set(new Search(profile, mapping)); + $(caption).text("Function filtered to " + found + " / " + profile.length + " entries, " + + (groups === found ? "not grouped." : groups + " groups.")); + } + }); + const body = React.createElement("table", { width: "100%", style: "padding-bottom: 17px;" }, + React.createElement("tr", null, + React.createElement("td", { width: "100%" }, input), + React.createElement("td", { style: "padding-left:6px;padding-right: 6px;" }, searchHelp(input))), + React.createElement("tr", null, + React.createElement("td", null, caption))); + return [body, res]; +} +function searchHelp(input) { + const examples = [["Only the last run", "run(0)"], + ["Only the last visited", "visited(0)"], + ["Named 'Main'", "named(\"Main\")"], + ["Group by file extension", "named(/(\\.[_0-9a-z]+)$/)"], + ["No dependencies (an input)", "leaf()"], + ["Didn't change when it last rebuilt", "unchanged()"], + ["Ran 'gcc'", "command(\"gcc\")"] + ]; + const f = (code) => () => { + $(input).val((i, x) => x + (x === "" ? "" : " && ") + code); + $(input).trigger("change"); + }; + const dropdown = React.createElement("div", { class: "dropdown", style: "display:none;" }, + React.createElement("ul", { style: "padding-left:30px;" }, examples.map(([desc, code]) => React.createElement("li", null, + React.createElement("a", { onclick: f(code) }, + React.createElement("tt", null, code)), + " ", + React.createElement("span", { class: "note" }, desc))))); + const arrow_down = React.createElement("span", { style: "vertical-align:middle;font-size:80%;" }, "\u25BC"); + const arrow_up = React.createElement("span", { style: "vertical-align:middle;font-size:80%;display:none;" }, "\u25B2"); + const show_inner = () => { $(dropdown).toggle(); $(arrow_up).toggle(); $(arrow_down).toggle(); }; + return React.createElement("div", null, + React.createElement("button", { style: "white-space:nowrap;padding-top:5px;padding-bottom:5px;", onclick: show_inner }, + React.createElement("b", { style: "font-size:150%;vertical-align:middle;" }, "+"), + "\u00A0 Filter and Group \u00A0", + arrow_down, + arrow_up), + dropdown); +} +function initProgress() { + $(function () { + $(".version").html("Generated by Shake " + version + "."); + $("#output").html(""); + for (const x of progress) { + var actual = []; + var ideal = []; + // Start at t = 5 seconds, since the early progress jumps a lot + for (var t = 5; t < x.values.length; t++) { + var y = x.values[t]; + actual.push([y.idealSecs, y.actualSecs]); + ideal.push([y.idealSecs, y.idealSecs]); + } + var ys = [{ data: ideal, color: "gray" }, { label: x.name, data: actual, color: "red" }]; + var div = $("
"); + $("#output").append(div); + $.plot(div, ys, { + xaxis: { + transform: function (v) { return -v; }, + inverseTransform: function (v) { return -v; } + } + }); + } + }); +} +// Stuff that Shake generates and injects in +function untraced(p) { + return Math.max(0, p.execution - p.traces.map(t => t.stop - t.start).sum()); +} +///////////////////////////////////////////////////////////////////// +// BASIC UI TOOLKIT +class Prop { + val; + callback; + constructor(val) { this.val = val; this.callback = () => { return; }; } + get() { return this.val; } + set(val) { + this.val = val; + this.callback(val); + } + event(next) { + const old = this.callback; + this.callback = val => { old(val); next(val); }; + next(this.val); + } + map(f) { + const res = new Prop(f(this.get())); + this.event(a => res.set(f(a))); + return res; + } +} +jQuery.fn.enable = function (x) { + // Set the values to enabled/disabled + return this.each(function () { + if (x) + $(this).removeAttr("disabled"); + else + $(this).attr("disabled", "disabled"); + }); +}; +///////////////////////////////////////////////////////////////////// +// BROWSER HELPER METHODS +// Given "?foo=bar&baz=1" returns {foo:"bar",baz:"1"} +function uriQueryParameters(s) { + // From https://stackoverflow.com/questions/901115/get-querystring-values-with-jquery/3867610#3867610 + const params = {}; + const a = /\+/g; // Regex for replacing addition symbol with a space + const r = /([^&=]+)=?([^&]*)/g; + const d = (x) => decodeURIComponent(x.replace(a, " ")); + const q = s.substring(1); + while (true) { + const e = r.exec(q); + if (!e) + break; + params[d(e[1])] = d(e[2]); + } + return params; +} +///////////////////////////////////////////////////////////////////// +// STRING FORMATTING +function showTime(x) { + function digits(x) { const s = String(x); return s.length === 1 ? "0" + s : s; } + if (x >= 3600) { + x = Math.round(x / 60); + return Math.floor(x / 60) + "h" + digits(x % 60) + "m"; + } + else if (x >= 60) { + x = Math.round(x); + return Math.floor(x / 60) + "m" + digits(x % 60) + "s"; + } + else + return x.toFixed(2) + "s"; +} +function showPerc(x) { + return (x * 100).toFixed(2) + "%"; +} +function showInt(x) { + // From https://stackoverflow.com/questions/2901102/how-to-print-a-number-with-commas-as-thousands-separators-in-javascript + // Show, with commas + return x.toString().replace(/\B(?=(\d{3})+(?!\d))/g, ","); +} +function showRun(run) { + return run === 0 ? "Latest run" : run + " run" + plural(run) + " ago"; +} +function plural(n, not1 = "s", is1 = "") { + return n === 1 ? is1 : not1; +} +///////////////////////////////////////////////////////////////////// +// MISC +function compareFst(a, b) { + return a[0] - b[0]; +} +function compareSnd(a, b) { + return a[1] - b[1]; +} +function compareSndRev(a, b) { + return b[1] - a[1]; +} +function pair(a, b) { + return [a, b]; +} +function triple(a, b, c) { + return [a, b, c]; +} +function fst([x, _]) { + return x; +} +function snd([_, x]) { + return x; +} +function execRegExp(r, s) { + if (typeof r === "string") + return s.indexOf(r) === -1 ? null : []; + else + return r.exec(s); +} +function cache(key, op) { + const store = {}; + return k => { + const s = key(k); + if (!(s in store)) + store[s] = op(k); + return store[s]; + }; +} +function lazy(thunk) { + let store = null; + let done = false; + return () => { + if (!done) { + store = thunk(); + done = true; + } + return store; + }; +} +Array.prototype.sum = function () { + let res = 0; + for (const x of this) + res += x; + return res; +}; +Array.prototype.insertSorted = function (x, compare) { + let start = 0; + let stop = this.length - 1; + let middle = 0; + while (start <= stop) { + middle = Math.floor((start + stop) / 2); + if (compare(this[middle], x) > 0) + stop = middle - 1; + else + start = middle + 1; + } + this.splice(start, 0, x); + return this; +}; +Array.prototype.concatLength = function () { + let res = 0; + for (const x of this) + res += x.length; + return res; +}; +Array.prototype.sortOn = function (f) { + return this.map(x => pair(f(x), x)).sort(compareFst).map(snd); +}; +Array.prototype.last = function () { + return this[this.length - 1]; +}; +Array.prototype.maximum = function (def) { + if (this.length === 0) + return def; + let res = this[0]; + for (let i = 1; i < this.length; i++) + res = Math.max(res, this[i]); + return res; +}; +Array.prototype.minimum = function (def) { + if (this.length === 0) + return def; + let res = this[0]; + for (let i = 1; i < this.length; i++) + res = Math.min(res, this[i]); + return res; +}; +// Use JSX with el instead of React.createElement +// Originally from https://gist.github.com/sergiodxa/a493c98b7884128081bb9a281952ef33 +// our element factory +function createElement(type, props, ...children) { + const element = document.createElement(type); + for (const name in props || {}) { + if (name.substr(0, 2) === "on") + element.addEventListener(name.substr(2), props[name]); + else + element.setAttribute(name, props[name]); + } + for (const child of children.flat(10)) { + const c = typeof child === "object" ? child : document.createTextNode(child.toString()); + element.appendChild(c); + } + return element; +} +// How .tsx gets desugared +const React = { createElement }; +function reportCmdPlot(profile) { + // first find the end point + const runs = findRuns(profile); + if (runs.length === 0) { + return React.createElement("div", null, + React.createElement("h2", null, "No data found"), + React.createElement("p", null, "The Shake database contains no rules which ran traced commands."), + React.createElement("p", null, + "You can populate this information by using ", + varLink("cmd"), + " or wrapping your ", + React.createElement("tt", null, "IO"), + " actions in ", + varLink("traced"), + ".")); + } + const combo = React.createElement("select", null, + runs.map(([run, time], i) => React.createElement("option", null, + showRun(run) + " (" + showTime(time) + ") ", + i === 0 ? "" : " - may be incomplete")), + ";"); + const warning = React.createElement("i", null); + const plot = React.createElement("div", { style: "width:100%; height:100%;" }); + const plotData = new Prop([]); + bindPlot(plot, plotData, { + legend: { show: true, position: "nw", sorted: "reverse" }, + series: { stack: true, lines: { fill: 1, lineWidth: 0 } }, + yaxis: { min: 0 }, + xaxis: { tickFormatter: showTime } + }); + function setPlotData(runsIndex) { + const [run, end] = runs[runsIndex]; + const profileRun = profile.filter(p => p.built === run); + // Make sure we max(0,) every step in the process, in case one does parallelism of threads + const missing = profileRun.map(untraced).sum(); + $(warning).text(missing < 1 ? "" : "Warning: " + showTime(missing) + " of execution was not traced."); + const series = calcPlotData(end, profileRun, 100); + const res = []; + for (const s in series) + res.push({ label: s, data: series[s].map((x, i) => pair(end * i / 100, x)) }); + plotData.set(res); + } + setPlotData(0); + $(combo).change(() => setPlotData(combo.selectedIndex)); + return React.createElement("table", { class: "fill" }, + React.createElement("tr", null, + React.createElement("td", { width: "100%", style: "text-align:center;" }, + React.createElement("h2", null, "Number of commands executing over time")), + React.createElement("td", null, combo)), + React.createElement("tr", null, + React.createElement("td", { height: "100%", colspan: "2" }, plot)), + React.createElement("tr", null, + React.createElement("td", { colspan: "2", style: "text-align:center;" }, + "Time since the start of building. ", + warning))); +} +// Find which runs had traced commands and when the last stopped, sort so most recent first +function findRuns(profile) { + const runs = {}; + for (const p of profile) { + if (p.traces.length > 0) { + if (p.traces.length === 1 && p.traces[0].command === "") + continue; // the fake end command + const old = runs[p.built]; + const end = p.traces.last().stop; + runs[p.built] = old === undefined ? end : Math.max(old, end); + } + } + const runsList = []; + for (const i in runs) + runsList.push(pair(Number(i), runs[i])); + runsList.sort(compareFst); + return runsList; +} +function calcPlotData(end, profile, buckets) { + const ans = {}; + for (const p of profile) { + for (const t of p.traces) { + let xs; + if (t.command in ans) + xs = ans[t.command]; + else { + xs = []; + for (let i = 0; i < buckets; i++) + xs.push(0); // fill with 1 more element, but the last bucket will always be 0 + ans[t.command] = xs; + } + const start = t.start * buckets / end; + const stop = t.stop * buckets / end; + if (Math.floor(start) === Math.floor(stop)) + xs[Math.floor(start)] += stop - start; + else { + for (let j = Math.ceil(start); j < Math.floor(stop); j++) + xs[j]++; + xs[Math.floor(start)] += Math.ceil(start) - start; + xs[Math.floor(stop)] += stop - Math.floor(stop); + } + } + } + return ans; +} +function reportCmdTable(profile, search) { + const columns = [{ field: "name", label: "Name", width: 200 }, + { field: "count", label: "Count", width: 65, alignRight: true, show: showInt }, + { field: "total", label: "Total", width: 75, alignRight: true, show: showTime }, + { field: "average", label: "Average", width: 75, alignRight: true, show: showTime }, + { field: "max", label: "Max", width: 75, alignRight: true, show: showTime } + ]; + return newTable(columns, search.map(cmdData), "total", true); +} +function cmdData(search) { + const res = {}; + search.forEachProfile(p => { + for (const t of p.traces) { + const time = t.stop - t.start; + if (t.command === "") + continue; // do nothing + else if (!(t.command in res)) + res[t.command] = { count: 1, total: time, max: time }; + else { + const ans = res[t.command]; + ans.count++; + ans.total += time; + ans.max = Math.max(ans.max, time); + } + } + }); + const res2 = []; + for (const i in res) + res2.push({ name: i, average: res[i].total / res[i].count, ...res[i] }); + return res2; +} +function reportDetails(profile, search) { + const result = React.createElement("div", { class: "details" }); + const self = new Prop(0); + search.event(xs => self.set(xs.mapProfile((p, _) => p.index).maximum())); + const f = (i) => React.createElement("a", { onclick: () => self.set(i) }, profile[i].name); + self.event(i => { + const p = profile[i]; + const content = React.createElement("ul", null, + React.createElement("li", null, + React.createElement("b", null, "Name:"), + " ", + p.name), + React.createElement("li", null, + React.createElement("b", null, "Built:"), + " ", + showRun(p.built)), + React.createElement("li", null, + React.createElement("b", null, "Changed:"), + " ", + showRun(p.changed)), + React.createElement("li", null, + React.createElement("b", null, "Execution time:"), + showTime(p.execution)), + React.createElement("li", null, + React.createElement("b", null, "Traced commands:"), + React.createElement("ol", null, p.traces.map(t => React.createElement("li", null, + t.command, + " took ", + showTime(t.stop - t.start))))), + React.createElement("li", null, + React.createElement("b", null, "Dependencies:"), + React.createElement("ol", null, p.depends.map(ds => React.createElement("li", null, + React.createElement("ul", null, ds.map(d => React.createElement("li", null, f(d)))))))), + React.createElement("li", null, + React.createElement("b", null, "Things that depend on me:"), + React.createElement("ul", null, p.rdepends.map(d => React.createElement("li", null, f(d)))))); + $(result).empty().append(content); + }); + return result; +} +function reportParallelism(profile) { + // now simulate for -j1 .. -j24 + const plotData = [{ label: "Realistic (based on current dependencies)", data: [], color: "#3131a7" }, + { label: "Ideal (if no dependencies and perfect speedup)", data: [], color: "green" }, + { label: "Gap", data: [], color: "orange" } + ]; + let threads1; + for (let threads = 1; threads <= 24; threads++) { + const taken = simulateThreads(profile, threads)[0]; + if (threads === 1) + threads1 = taken; + plotData[0].data.push([threads, taken]); + plotData[1].data.push([threads, threads1 / threads]); + plotData[2].data.push([threads, Math.max(0, taken - (threads1 / threads))]); + } + const plot = React.createElement("div", { style: "width:100%; height:100%;" }); + bindPlot(plot, new Prop(plotData), { + xaxis: { tickDecimals: 0 }, + yaxis: { min: 0, tickFormatter: showTime } + }); + return React.createElement("table", { class: "fill" }, + React.createElement("tr", null, + React.createElement("td", { style: "text-align:center;" }, + React.createElement("h2", null, "Time to build at different number of threads"))), + React.createElement("tr", null, + React.createElement("td", { height: "100%" }, plot)), + React.createElement("tr", null, + React.createElement("td", { style: "text-align:center;" }, "Number of threads available."))); +} +// Simulate running N threads over the profile, return: +// [total time take, point at which each entry kicked off] +function simulateThreads(profile, threads) { + // How far are we through this simulation + let timestamp = 0; + // Who is currently running, with the highest seconds FIRST + const running = []; + const started = []; + // Things that are done + const ready = profile.filter(x => x.depends.length === 0); + const waiting = profile.map(x => x.depends.concatLength()); // number I am waiting on before I am done + function runningWait() { + const [ind, time] = running.pop(); + timestamp = time; + for (const d of profile[ind].rdepends) { + waiting[d]--; + if (waiting[d] === 0) + ready.push(profile[d]); + } + } + while (true) { + // Queue up as many people as we can + while (running.length < threads && ready.length > 0) { + const p = ready.pop(); + started[p.index] = timestamp; + running.insertSorted([p.index, timestamp + p.execution], compareSndRev); + } + if (running.length === 0) { + if (waiting.maximum(0) > 0) + throw new Error("Failed to run all tasks"); + return [timestamp, started]; + } + runningWait(); + } +} +function reportRebuild(profile, search) { + const depth = []; + for (const p of profile) { + depth[p.index] = p.depends.flat().map(d => depth[d] + 1).maximum(0); + } + const ind = search.get().mapProfile((p, _) => p.index).sortOn(i => -depth[i])[0]; + const p = profile[ind]; + function f(p) { + const res = []; + while (p.depends.length !== 0) { + const ds = p.depends.flat().sortOn(i => -depth[i]); + res.push(React.createElement("li", null, + React.createElement("select", { style: "width:400px;" }, ds.slice(0, 1).map(x => React.createElement("option", null, profile[x].name))))); + p = profile[ds[0]]; + } + return res; + } + return React.createElement("div", null, + React.createElement("h2", null, "Why did it rebuild?"), + React.createElement("p", null, + "Rule ", + p.name + " " + (p.built === 0 ? "rebuild in the last run" : "did not rebuild")), + React.createElement("ul", null, f(p))); +} +function reportRuleTable(profile, search) { + const [etimes, wtimes] = calcEWTimes(profile, 24); + const columns = [{ field: "name", label: "Name", width: 400 }, + { field: "count", label: "Count", width: 65, alignRight: true, show: showInt }, + { field: "leaf", label: "Leaf", width: 60, alignRight: true }, + { field: "visited", label: "Visit", width: 50, alignRight: true }, + { field: "run", label: "Run", width: 50, alignRight: true }, + { field: "changed", label: "Change", width: 60, alignRight: true }, + { field: "time", label: "Time", width: 75, alignRight: true, show: showTime }, + { field: "etime", label: "ETime", width: 75, alignRight: true, show: showTime }, + { field: "wtime", label: "WTime", width: 75, alignRight: true, show: showTime } + ]; + return newTable(columns, search.map(s => ruleData(etimes, wtimes, s)), "time", true); +} +// Calculate the exclusive time of each rule at some number of threads +function calcEWTimes(profile, threads) { + const [_, started] = simulateThreads(profile, threads); + const starts = started.map((s, i) => pair(i, s)).sort(compareSnd); + const costs = starts.map(([ind, start], i) => { + // find out who else runs before I finish + const execution = profile[ind].execution; + const end = start + execution; + let overlap = 0; // how much time I am overlapped for + let exclusive = 0; // how much time I am the only runner + let finisher = start; // the first overlapping person to finish + for (let j = i + 1; j < starts.length; j++) { + const [jInd, jStarts] = starts[j]; + if (jStarts > end) + break; + overlap += Math.min(end - jStarts, profile[jInd].execution); + exclusive += Math.max(0, Math.min(jStarts, end) - finisher); + finisher = Math.max(finisher, jStarts + profile[jInd].execution); + } + exclusive += Math.max(0, end - finisher); + return triple(ind, execution === 0 ? 0 : execution * (execution / (execution + overlap)), exclusive); + }); + const etimes = []; + const wtimes = []; + for (const [ind, etime, wtime] of costs) { + etimes[ind] = etime; + wtimes[ind] = wtime; + } + return [etimes, wtimes]; +} +function ruleData(etimes, wtimes, search) { + return search.mapProfiles((ps, name) => ({ + name, + count: ps.length, + leaf: ps.every(p => p.depends.length === 0), + run: ps.map(p => p.built).minimum(), + visited: ps.map(p => p.visited).minimum(), + changed: ps.some(p => p.built === p.changed), + time: ps.map(p => p.execution).sum(), + etime: ps.map(p => etimes[p.index]).sum(), + wtime: ps.map(p => wtimes[p.index]).sum(), + })); +} +function reportSummary(profile, build) { + let countLast = 0; // number of rules run in the last run + let visitedLast = 0; // number of rules visited in the last run + let highestRun = 0; // highest run you have seen (add 1 to get the count of runs) + let sumExecution = 0; // build time in total + let sumExecutionLast = 0; // build time in total + let countTrace = -1; + let countTraceLast = -1; // traced commands run + // start both are -1 because the end command will have run in the previous step + let maxTraceStopLast = 0; // time the last traced command stopped + for (const p of profile) { + sumExecution += p.execution; + highestRun = Math.max(highestRun, p.changed); // changed is always greater or equal to built + countTrace += p.traces.length; + if (p.built === 0) { + sumExecutionLast += p.execution; + countLast++; + countTraceLast += p.traces.length; + if (p.traces.length > 0) + maxTraceStopLast = Math.max(maxTraceStopLast, p.traces.last().stop); + } + if (p.visited === 0) { + visitedLast++; + } + } + return React.createElement("div", null, + React.createElement("h2", null, "Totals"), + React.createElement("ul", null, + React.createElement("li", null, + React.createElement("b", null, "Runs:"), + " ", + showInt(highestRun + 1), + " ", + React.createElement("span", { class: "note" }, "total number of runs so far.")), + React.createElement("li", null, + React.createElement("b", null, "Rules:"), + " ", + showInt(profile.length), + " (", + showInt(countLast), + " in last run) ", + React.createElement("span", { class: "note" }, "number of defined build rules."))), + React.createElement("h2", null, "Performance"), + React.createElement("ul", null, + React.createElement("li", null, + React.createElement("b", null, "Build time:"), + " ", + showTime(sumExecution), + " ", + React.createElement("span", { class: "note" }, "how long a complete build would take single threaded.")), + React.createElement("li", null, + React.createElement("b", null, "Last build time:"), + " ", + showTime(maxTraceStopLast), + " ", + React.createElement("span", { class: "note" }, "how long the last build take.")), + React.createElement("li", null, + React.createElement("b", null, "Parallelism:"), + " ", + (maxTraceStopLast === 0 ? 0 : sumExecutionLast / maxTraceStopLast).toFixed(2), + " ", + React.createElement("span", { class: "note" }, "average number of commands executing simultaneously in the last build.")), + React.createElement("li", null, + React.createElement("b", null, "Speculative critical path:"), + " ", + showTime(speculativeCriticalPath(profile)), + " ", + React.createElement("span", { class: "note" }, "how long it would take on infinite CPUs.")), + React.createElement("li", null, + React.createElement("b", null, "Precise critical path:"), + " ", + showTime(preciseCriticalPath(profile)), + " ", + React.createElement("span", { class: "note" }, "critical path not speculatively executing."))), + React.createElement("h2", null, "This run"), + React.createElement("ul", null, + React.createElement("li", null, + React.createElement("b", null, "Rules built:"), + " ", + showInt(countLast), + " ", + React.createElement("span", { class: "note" }, "Total number of rules built in this run")), + React.createElement("li", null, + React.createElement("b", null, "Rules visited:"), + " ", + showInt(visitedLast - countLast), + " ", + React.createElement("span", { class: "note" }, "Total number of rules looked up from the values store in this run")), + React.createElement("li", null, + React.createElement("b", null, "Dirty set:"), + renderDirtySet(build, profile)))); +} +function renderDirtySet(build, profile) { + if (build.dirtyKeys === null) { + return "ALL"; + } + else { + return React.createElement("ul", null, build.dirtyKeys.map(d => { return React.createElement("li", null, profile[d - 1].name); })); + } +} +function speculativeCriticalPath(profile) { + const criticalPath = []; // the critical path to any element + let maxCriticalPath = 0; + for (const p of profile) { + let cost = 0; + for (const ds of p.depends) + for (const d of ds) + cost = Math.max(cost, criticalPath[d]); + cost += p.execution; + maxCriticalPath = Math.max(cost, maxCriticalPath); + criticalPath[p.index] = cost; + } + return maxCriticalPath; +} +/* +Calculating a precise critical path, taking into account the deep dependeny structure, is non-obvious. +Dependencies have the type [{X}], e.g: + + X = [{a,b},{c,d}] + +That is r builds a and b, then after those both complete (assuming they don't change), it builds c and d, +then it is finished. Importantly, r doesn't start building c/d until after a and b have finished. This +detail extends the critical path. + +To calculate the precise critical path, we simulate with the notion of demand and waiting. +*/ +function preciseCriticalPath(profile) { + const waiting = profile.map(x => x.depends.concatLength()); // number I am waiting on before I am done + const demanded = []; // I have been demanded by someone + const oncomplete = []; // Completion functions + const complete = []; // Who is complete already + const running = []; + let timestamp = 0; + // demand dependency set N of a rule + function demandN(p, round) { + for (; round < p.depends.length; round++) { + let todo = p.depends[round].length; // Number before we continue + const step = () => { + todo--; + if (todo === 0) + demandN(p, round + 1); + }; + for (const d of p.depends[round]) { + if (complete[d]) + todo--; + else { + const old = oncomplete[d]; + oncomplete[d] = !old ? step : () => { old(); step(); }; + demand(profile[d]); + } + } + if (todo !== 0) + break; + // todo === 0, so continue (equivalent to calling step but tail recursive) + } + } + // demand a particular rule + function demand(p) { + if (demanded[p.index]) + return; + demanded[p.index] = true; + if (waiting[p.index] === 0) + running.insertSorted([p.index, timestamp + p.execution], compareSndRev); + else + demandN(p, 0); + } + // We don't know the targets we ask for, so we approximate by saying the ones which nothing depends on + for (const p of profile) { + if (p.rdepends.length === 0) + demand(p); + } + while (running.length > 0) { + const [ind, time] = running.pop(); + timestamp = time; + complete[ind] = true; + if (oncomplete[ind]) { + oncomplete[ind](); + delete oncomplete[ind]; + } + for (const d of profile[ind].rdepends) { + waiting[d]--; + if (waiting[d] === 0 && demanded[d]) + running.insertSorted([d, timestamp + profile[d].execution], compareSndRev); + } + } + for (let i = 0; i < profile.length; i++) + if (!complete[i]) + throw new Error("Failed to run all tasks"); + return timestamp; +} diff --git a/src/Development/IDE/Graph.hs b/src/Development/IDE/Graph.hs --- a/src/Development/IDE/Graph.hs +++ b/src/Development/IDE/Graph.hs @@ -4,22 +4,26 @@ shakeOptions, Rules, Action, action, - actionFinally, actionBracket, actionCatch, - Shake.ShakeException(..), + Key(..), + actionFinally, actionBracket, actionCatch, actionFork, -- * Configuration ShakeOptions(shakeAllowRedefineRules, shakeThreads, shakeFiles, shakeExtra), getShakeExtra, getShakeExtraRules, newShakeExtra, -- * Explicit parallelism parallel, -- * Oracle rules - Shake.ShakeValue, Shake.RuleResult, + ShakeValue, RuleResult, -- * Special rules alwaysRerun, -- * Batching reschedule, + -- * Actions for inspecting the keys in the database + getDirtySet, + getKeysAndVisitedAge, ) where +import Development.IDE.Graph.Database import Development.IDE.Graph.Internal.Action import Development.IDE.Graph.Internal.Options import Development.IDE.Graph.Internal.Rules -import qualified Development.Shake as Shake +import Development.IDE.Graph.Internal.Types diff --git a/src/Development/IDE/Graph/Classes.hs b/src/Development/IDE/Graph/Classes.hs --- a/src/Development/IDE/Graph/Classes.hs +++ b/src/Development/IDE/Graph/Classes.hs @@ -1,6 +1,8 @@ module Development.IDE.Graph.Classes( - Show(..), Typeable, Eq(..), Hashable(..), Binary(..), NFData(..) + Show(..), Typeable, Eq(..), Hashable(..), NFData(..) ) where -import Development.Shake.Classes +import Control.DeepSeq +import Data.Hashable +import Data.Typeable diff --git a/src/Development/IDE/Graph/Database.hs b/src/Development/IDE/Graph/Database.hs --- a/src/Development/IDE/Graph/Database.hs +++ b/src/Development/IDE/Graph/Database.hs @@ -1,36 +1,86 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} module Development.IDE.Graph.Database( - Shake.ShakeDatabase, - SomeShakeValue(..), + ShakeDatabase, + ShakeValue, shakeOpenDatabase, + shakeRunDatabase, shakeRunDatabaseForKeys, - Shake.shakeProfileDatabase, - ) where - -import Data.Typeable + shakeProfileDatabase, + shakeGetBuildStep, + shakeGetDirtySet, + shakeGetCleanKeys + ,shakeGetBuildEdges) where +import Data.Dynamic +import Data.IORef (readIORef) +import Data.Maybe +import Development.IDE.Graph.Classes () import Development.IDE.Graph.Internal.Action +import Development.IDE.Graph.Internal.Database +import qualified Development.IDE.Graph.Internal.Ids as Ids import Development.IDE.Graph.Internal.Options +import Development.IDE.Graph.Internal.Profile (writeProfile) import Development.IDE.Graph.Internal.Rules -import Development.Shake (ShakeValue) -import Development.Shake.Classes -import qualified Development.Shake.Database as Shake +import Development.IDE.Graph.Internal.Types -shakeOpenDatabase :: ShakeOptions -> Rules () -> IO (IO Shake.ShakeDatabase, IO ()) -shakeOpenDatabase a b = Shake.shakeOpenDatabase (fromShakeOptions a) (fromRules b) +data ShakeDatabase = ShakeDatabase !Int [Action ()] Database -data SomeShakeValue = forall k . ShakeValue k => SomeShakeValue k -instance Eq SomeShakeValue where SomeShakeValue a == SomeShakeValue b = cast a == Just b -instance Hashable SomeShakeValue where hashWithSalt s (SomeShakeValue x) = hashWithSalt s x -instance Show SomeShakeValue where show (SomeShakeValue x) = show x +-- Placeholder to be the 'extra' if the user doesn't set it +data NonExportedType = NonExportedType +shakeOpenDatabase :: ShakeOptions -> Rules () -> IO (IO ShakeDatabase, IO ()) +shakeOpenDatabase opts rules = pure (shakeNewDatabase opts rules, pure ()) + +shakeNewDatabase :: ShakeOptions -> Rules () -> IO ShakeDatabase +shakeNewDatabase opts rules = do + let extra = fromMaybe (toDyn NonExportedType) $ shakeExtra opts + (theRules, actions) <- runRules extra rules + db <- newDatabase extra theRules + pure $ ShakeDatabase (length actions) actions db + +shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO ([a], [IO ()]) +shakeRunDatabase = shakeRunDatabaseForKeys Nothing + +-- | Returns the set of dirty keys annotated with their age (in # of builds) +shakeGetDirtySet :: ShakeDatabase -> IO [(Key, Int)] +shakeGetDirtySet (ShakeDatabase _ _ db) = + fmap snd <$> Development.IDE.Graph.Internal.Database.getDirtySet db + +-- | Returns the build number +shakeGetBuildStep :: ShakeDatabase -> IO Int +shakeGetBuildStep (ShakeDatabase _ _ db) = do + Step s <- readIORef $ databaseStep db + return s + +-- Only valid if we never pull on the results, which we don't +unvoid :: Functor m => m () -> m a +unvoid = fmap undefined + shakeRunDatabaseForKeys - :: Maybe [SomeShakeValue] + :: Maybe [Key] -- ^ Set of keys changed since last run. 'Nothing' means everything has changed - -> Shake.ShakeDatabase + -> ShakeDatabase -> [Action a] -> IO ([a], [IO ()]) -shakeRunDatabaseForKeys _keys a b = - -- Shake upstream does not accept the set of keys changed yet - -- https://github.com/ndmitchell/shake/pull/802 - Shake.shakeRunDatabase a (map fromAction b) +shakeRunDatabaseForKeys keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do + incDatabase db keysChanged + as <- fmap (drop lenAs1) $ runActions db $ map unvoid as1 ++ as2 + return (as, []) + +-- | Given a 'ShakeDatabase', write an HTML profile to the given file about the latest run. +shakeProfileDatabase :: ShakeDatabase -> FilePath -> IO () +shakeProfileDatabase (ShakeDatabase _ _ s) file = writeProfile file s + +-- | Returns the clean keys in the database +shakeGetCleanKeys :: ShakeDatabase -> IO [(Key, Result )] +shakeGetCleanKeys (ShakeDatabase _ _ db) = do + keys <- Ids.elems $ databaseValues db + return [ (k,res) | (k, Clean res) <- keys] + +-- | Returns the total count of edges in the build graph +shakeGetBuildEdges :: ShakeDatabase -> IO Int +shakeGetBuildEdges (ShakeDatabase _ _ db) = do + keys <- Ids.elems $ databaseValues db + let ress = mapMaybe (getResult . snd) keys + return $ sum $ map (length . getResultDepsDefault [] . resultDeps) ress diff --git a/src/Development/IDE/Graph/Internal/Action.hs b/src/Development/IDE/Graph/Internal/Action.hs --- a/src/Development/IDE/Graph/Internal/Action.hs +++ b/src/Development/IDE/Graph/Internal/Action.hs @@ -1,38 +1,138 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -module Development.IDE.Graph.Internal.Action where +module Development.IDE.Graph.Internal.Action +( ShakeValue +, actionFork +, actionBracket +, actionCatch +, actionFinally +, alwaysRerun +, apply1 +, apply +, parallel +, reschedule +, runActions +, Development.IDE.Graph.Internal.Action.getDirtySet +, getKeysAndVisitedAge +) where +import Control.Concurrent.Async import Control.Exception -import Control.Monad.Fail import Control.Monad.IO.Class -import qualified Development.Shake as Shake -import Development.Shake.Classes -import qualified Development.Shake.Rule as Shake +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Data.IORef +import Development.IDE.Graph.Classes +import Development.IDE.Graph.Internal.Database +import Development.IDE.Graph.Internal.Rules (RuleResult) +import Development.IDE.Graph.Internal.Types +import System.Exit -newtype Action a = Action {fromAction :: Shake.Action a} - deriving (Monad, Applicative, Functor, MonadIO, MonadFail) +type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a) +-- | Always rerun this rule when dirty, regardless of the dependencies. alwaysRerun :: Action () -alwaysRerun = Action Shake.alwaysRerun +alwaysRerun = do + ref <- Action $ asks actionDeps + liftIO $ modifyIORef ref (AlwaysRerunDeps [] <>) +-- No-op for now reschedule :: Double -> Action () -reschedule = Action . Shake.reschedule +reschedule _ = pure () parallel :: [Action a] -> Action [a] -parallel = Action . Shake.parallel . map fromAction +parallel [] = pure [] +parallel [x] = fmap (:[]) x +parallel xs = do + a <- Action ask + deps <- liftIO $ readIORef $ actionDeps a + case deps of + UnknownDeps -> + -- if we are already in the rerun mode, nothing we do is going to impact our state + liftIO $ mapConcurrently (ignoreState a) xs + deps -> do + (newDeps, res) <- liftIO $ unzip <$> mapConcurrently (usingState a) xs + liftIO $ writeIORef (actionDeps a) $ mconcat $ deps : newDeps + pure res + where + usingState a x = do + ref <- newIORef mempty + res <- runReaderT (fromAction x) a{actionDeps=ref} + deps <- readIORef ref + pure (deps, res) +ignoreState :: SAction -> Action b -> IO b +ignoreState a x = do + ref <- newIORef mempty + runReaderT (fromAction x) a{actionDeps=ref} + +actionFork :: Action a -> (Async a -> Action b) -> Action b +actionFork act k = do + a <- Action ask + deps <- liftIO $ readIORef $ actionDeps a + let db = actionDatabase a + case deps of + UnknownDeps -> do + -- if we are already in the rerun mode, nothing we do is going to impact our state + [res] <- liftIO $ withAsync (ignoreState a act) $ \as -> runActions db [k as] + return res + _ -> + error "please help me" + +isAsyncException :: SomeException -> Bool +isAsyncException e + | Just (_ :: AsyncCancelled) <- fromException e = True + | Just (_ :: AsyncException) <- fromException e = True + | Just (_ :: ExitCode) <- fromException e = True + | otherwise = False + + actionCatch :: Exception e => Action a -> (e -> Action a) -> Action a -actionCatch a b = Action $ Shake.actionCatch (fromAction a) (fromAction . b) +actionCatch a b = do + v <- Action ask + Action $ lift $ catchJust f (runReaderT (fromAction a) v) (\x -> runReaderT (fromAction (b x)) v) + where + -- Catch only catches exceptions that were caused by this code, not those that + -- are a result of program termination + f e | isAsyncException e = Nothing + | otherwise = fromException e actionBracket :: IO a -> (a -> IO b) -> (a -> Action c) -> Action c -actionBracket a b c = Action $ Shake.actionBracket a b (fromAction . c) +actionBracket a b c = do + v <- Action ask + Action $ lift $ bracket a b (\x -> runReaderT (fromAction (c x)) v) actionFinally :: Action a -> IO b -> Action a -actionFinally a b = Action $ Shake.actionFinally (fromAction a) b +actionFinally a b = do + v <- Action ask + Action $ lift $ finally (runReaderT (fromAction a) v) b -apply1 :: (Shake.RuleResult key ~ value, Shake.ShakeValue key, Typeable value) => key -> Action value -apply1 = Action . Shake.apply1 +apply1 :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value +apply1 k = head <$> apply [k] -apply :: (Shake.RuleResult key ~ value, Shake.ShakeValue key, Typeable value) => [key] -> Action [value] -apply = Action . Shake.apply +apply :: (RuleResult key ~ value, ShakeValue key, Typeable value) => [key] -> Action [value] +apply ks = do + db <- Action $ asks actionDatabase + (is, vs) <- liftIO $ build db ks + ref <- Action $ asks actionDeps + liftIO $ modifyIORef ref (ResultDeps is <>) + pure vs + +runActions :: Database -> [Action a] -> IO [a] +runActions db xs = do + deps <- newIORef mempty + runReaderT (fromAction $ parallel xs) $ SAction db deps + +-- | Returns the set of dirty keys annotated with their age (in # of builds) +getDirtySet :: Action [(Key, Int)] +getDirtySet = do + db <- getDatabase + liftIO $ fmap snd <$> Development.IDE.Graph.Internal.Database.getDirtySet db + +getKeysAndVisitedAge :: Action [(Key, Int)] +getKeysAndVisitedAge = do + db <- getDatabase + liftIO $ Development.IDE.Graph.Internal.Database.getKeysAndVisitAge db diff --git a/src/Development/IDE/Graph/Internal/Database.hs b/src/Development/IDE/Graph/Internal/Database.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Graph/Internal/Database.hs @@ -0,0 +1,301 @@ +-- We deliberately want to ensure the function we add to the rule database +-- has the constraints we need on it when we get it out. +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where + +import Control.Concurrent.Async +import Control.Concurrent.Extra +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader +import qualified Control.Monad.Trans.State.Strict as State +import Data.Dynamic +import Data.Either +import Data.Foldable (traverse_) +import Data.IORef.Extra +import Data.IntSet (IntSet) +import qualified Data.IntSet as Set +import Data.Maybe +import Data.Tuple.Extra +import Development.IDE.Graph.Classes +import qualified Development.IDE.Graph.Internal.Ids as Ids +import Development.IDE.Graph.Internal.Intern +import qualified Development.IDE.Graph.Internal.Intern as Intern +import Development.IDE.Graph.Internal.Rules +import Development.IDE.Graph.Internal.Types +import System.IO.Unsafe +import System.Time.Extra (duration) + +newDatabase :: Dynamic -> TheRules -> IO Database +newDatabase databaseExtra databaseRules = do + databaseStep <- newIORef $ Step 0 + databaseLock <- newLock + databaseIds <- newIORef Intern.empty + databaseValues <- Ids.empty + databaseReverseDeps <- Ids.empty + databaseReverseDepsLock <- newLock + pure Database{..} + +-- | Increment the step and mark dirty +incDatabase :: Database -> Maybe [Key] -> IO () +-- all keys are dirty +incDatabase db Nothing = do + modifyIORef' (databaseStep db) $ \(Step i) -> Step $ i + 1 + withLock (databaseLock db) $ + Ids.forMutate (databaseValues db) $ \_ -> second $ \case + Clean x -> Dirty (Just x) + Dirty x -> Dirty x + Running _ _ x -> Dirty x +-- only some keys are dirty +incDatabase db (Just kk) = do + modifyIORef' (databaseStep db) $ \(Step i) -> Step $ i + 1 + intern <- readIORef (databaseIds db) + let dirtyIds = mapMaybe (`Intern.lookup` intern) kk + transitiveDirtyIds <- transitiveDirtySet db dirtyIds + withLock (databaseLock db) $ + Ids.forMutate (databaseValues db) $ \i -> \case + (k, Running _ _ x) -> (k, Dirty x) + (k, Clean x) | i `Set.member` transitiveDirtyIds -> + (k, Dirty (Just x)) + other -> other + + +-- | Unwrap and build a list of keys in parallel +build + :: forall key value . (RuleResult key ~ value, Typeable key, Show key, Hashable key, Eq key, Typeable value) + => Database -> [key] -> IO ([Id], [value]) +build db keys = do + (ids, vs) <- runAIO $ fmap unzip $ either return liftIO =<< builder db (map (Right . Key) keys) + pure (ids, map (asV . resultValue) vs) + where + asV :: Value -> value + asV (Value x) = unwrapDynamic x + +-- | Build a list of keys and return their results. +-- If none of the keys are dirty, we can return the results immediately. +-- Otherwise, a blocking computation is returned *which must be evaluated asynchronously* to avoid deadlock. +builder + :: Database -> [Either Id Key] -> AIO (Either [(Id, Result)] (IO [(Id, Result)])) +builder db@Database{..} keys = do + -- Things that I need to force before my results are ready + toForce <- liftIO $ newIORef [] + + results <- withLockAIO databaseLock $ do + flip traverse keys $ \idKey -> do + -- Resolve the id + id <- case idKey of + Left id -> pure id + Right key -> liftIO $ do + ids <- readIORef databaseIds + case Intern.lookup key ids of + Just v -> pure v + Nothing -> do + (ids, id) <- pure $ Intern.add key ids + writeIORef' databaseIds ids + return id + + -- Spawn the id if needed + status <- liftIO $ Ids.lookup databaseValues id + val <- case fromMaybe (fromRight undefined idKey, Dirty Nothing) status of + (_, Clean r) -> pure r + (_, Running force val _) -> do + liftIO $ modifyIORef toForce (Wait force :) + pure val + (key, Dirty s) -> do + act <- unliftAIO (refresh db key id s) + let (force, val) = splitIO (join act) + liftIO $ Ids.insert databaseValues id (key, Running force val s) + liftIO $ modifyIORef toForce (Spawn force:) + pure val + + pure (id, val) + + toForceList <- liftIO $ readIORef toForce + waitAll <- unliftAIO $ mapConcurrentlyAIO_ id toForceList + case toForceList of + [] -> return $ Left results + _ -> return $ Right $ do + waitAll + pure results + +-- | Refresh a key: +-- * If no dirty dependencies and we have evaluated the key previously, then we refresh it in the current thread. +-- This assumes that the implementation will be a lookup +-- * Otherwise, we spawn a new thread to refresh the dirty deps (if any) and the key itself +refresh :: Database -> Key -> Id -> Maybe Result -> AIO (IO Result) +refresh db key id result@(Just me@Result{resultDeps = ResultDeps deps}) = do + res <- builder db $ map Left deps + case res of + Left res -> + if isDirty res + then asyncWithCleanUp $ liftIO $ compute db key id RunDependenciesChanged result + else pure $ compute db key id RunDependenciesSame result + Right iores -> asyncWithCleanUp $ liftIO $ do + res <- iores + let mode = if isDirty res then RunDependenciesChanged else RunDependenciesSame + compute db key id mode result + where + isDirty = any (\(_,dep) -> resultBuilt me < resultChanged dep) + +refresh db key id result = + asyncWithCleanUp $ liftIO $ compute db key id RunDependenciesChanged result + + +-- | Compute a key. +compute :: Database -> Key -> Id -> RunMode -> Maybe Result -> IO Result +compute db@Database{..} key id mode result = do + let act = runRule databaseRules key (fmap resultData result) mode + deps <- newIORef UnknownDeps + (execution, RunResult{..}) <- + duration $ runReaderT (fromAction act) $ SAction db deps + built <- readIORef databaseStep + deps <- readIORef deps + let changed = if runChanged == ChangedRecomputeDiff then built else maybe built resultChanged result + built' = if runChanged /= ChangedNothing then built else changed + -- only update the deps when the rule ran with changes + actualDeps = if runChanged /= ChangedNothing then deps else previousDeps + previousDeps= maybe UnknownDeps resultDeps result + let res = Result runValue built' changed built actualDeps execution runStore + case getResultDepsDefault [] actualDeps of + deps | not(null deps) + && runChanged /= ChangedNothing + -> do + void $ forkIO $ + updateReverseDeps id db (getResultDepsDefault [] previousDeps) (Set.fromList deps) + _ -> pure () + withLock databaseLock $ + Ids.insert databaseValues id (key, Clean res) + pure res + +-- | Returns the set of dirty keys annotated with their age (in # of builds) +getDirtySet :: Database -> IO [(Id,(Key, Int))] +getDirtySet db = do + Step curr <- readIORef (databaseStep db) + dbContents <- Ids.toList (databaseValues db) + let calcAge Result{resultBuilt = Step x} = curr - x + calcAgeStatus (Dirty x)=calcAge <$> x + calcAgeStatus _ = Nothing + return $ mapMaybe ((secondM.secondM) calcAgeStatus) dbContents + +-- | Returns ann approximation of the database keys, +-- annotated with how long ago (in # builds) they were visited +getKeysAndVisitAge :: Database -> IO [(Key, Int)] +getKeysAndVisitAge db = do + values <- Ids.elems (databaseValues db) + Step curr <- readIORef (databaseStep db) + let keysWithVisitAge = mapMaybe (secondM (fmap getAge . getResult)) values + getAge Result{resultVisited = Step s} = curr - s + return keysWithVisitAge +-------------------------------------------------------------------------------- +-- Lazy IO trick + +data Box a = Box {fromBox :: a} + +-- | Split an IO computation into an unsafe lazy value and a forcing computation +splitIO :: IO a -> (IO (), a) +splitIO act = do + let act2 = Box <$> act + let res = unsafePerformIO act2 + (void $ evaluate res, fromBox res) + +-------------------------------------------------------------------------------- +-- Reverse dependencies + +-- | Update the reverse dependencies of an Id +updateReverseDeps + :: Id -- ^ Id + -> Database + -> [Id] -- ^ Previous direct dependencies of Id + -> IntSet -- ^ Current direct dependencies of Id + -> IO () +updateReverseDeps myId db prev new = withLock (databaseReverseDepsLock db) $ uninterruptibleMask_ $ do + forM_ prev $ \d -> + unless (d `Set.member` new) $ + doOne (Set.delete myId) d + forM_ (Set.elems new) $ + doOne (Set.insert myId) + where + doOne f id = do + rdeps <- getReverseDependencies db id + Ids.insert (databaseReverseDeps db) id (f $ fromMaybe mempty rdeps) + +getReverseDependencies :: Database -> Id -> IO (Maybe (IntSet)) +getReverseDependencies db = Ids.lookup (databaseReverseDeps db) + +transitiveDirtySet :: Foldable t => Database -> t Id -> IO IntSet +transitiveDirtySet database = flip State.execStateT Set.empty . traverse_ loop + where + loop x = do + seen <- State.get + if x `Set.member` seen then pure () else do + State.put (Set.insert x seen) + next <- lift $ getReverseDependencies database x + traverse_ loop (maybe mempty Set.toList next) + +-- | IO extended to track created asyncs to clean them up when the thread is killed, +-- generalizing 'withAsync' +newtype AIO a = AIO { unAIO :: ReaderT (IORef [Async ()]) IO a } + deriving newtype (Applicative, Functor, Monad, MonadIO) + +runAIO :: AIO a -> IO a +runAIO (AIO act) = do + asyncs <- newIORef [] + runReaderT act asyncs `onException` cleanupAsync asyncs + +asyncWithCleanUp :: AIO a -> AIO (IO a) +asyncWithCleanUp act = do + st <- AIO ask + io <- unliftAIO act + liftIO $ uninterruptibleMask $ \restore -> do + a <- async $ restore io + atomicModifyIORef'_ st (void a :) + return $ wait a + +withLockAIO :: Lock -> AIO a -> AIO a +withLockAIO lock act = do + io <- unliftAIO act + liftIO $ withLock lock io + +unliftAIO :: AIO a -> AIO (IO a) +unliftAIO act = do + st <- AIO ask + return $ runReaderT (unAIO act) st + +cleanupAsync :: IORef [Async a] -> IO () +cleanupAsync ref = uninterruptibleMask_ $ do + asyncs <- readIORef ref + mapM_ (\a -> throwTo (asyncThreadId a) AsyncCancelled) asyncs + mapM_ waitCatch asyncs + +data Wait a + = Wait {justWait :: !a} + | Spawn {justWait :: !a} + deriving Functor + +waitOrSpawn :: Wait (IO a) -> IO (Either (IO a) (Async a)) +waitOrSpawn (Wait io) = pure $ Left io +waitOrSpawn (Spawn io) = Right <$> async io + +mapConcurrentlyAIO_ :: (a -> IO ()) -> [Wait a] -> AIO () +mapConcurrentlyAIO_ _ [] = pure () +mapConcurrentlyAIO_ f [one] = liftIO $ justWait $ fmap f one +mapConcurrentlyAIO_ f many = do + ref <- AIO ask + waits <- liftIO $ uninterruptibleMask $ \restore -> do + waits <- liftIO $ traverse (waitOrSpawn . fmap (restore . f)) many + let asyncs = rights waits + liftIO $ atomicModifyIORef'_ ref (asyncs ++) + return waits + liftIO $ traverse_ (either id wait) waits diff --git a/src/Development/IDE/Graph/Internal/Ids.hs b/src/Development/IDE/Graph/Internal/Ids.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Graph/Internal/Ids.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UnboxedTuples #-} + +-- Note that argument order is more like IORef than Map, because its mutable +module Development.IDE.Graph.Internal.Ids( + Ids, Id, + empty, insert, lookup, fromList, + null, size, sizeUpperBound, + forWithKeyM_, forCopy, forMutate, + toList, elems, toMap + ) where + +import Control.Exception +import Control.Monad.Extra +import Data.Functor +import qualified Data.HashMap.Strict as Map +import Data.IORef.Extra +import Data.List.Extra (zipFrom) +import Data.Maybe +import Data.Primitive.Array hiding (fromList) +import Development.IDE.Graph.Internal.Intern (Id) +import GHC.Exts (RealWorld) +import GHC.IO (IO (..)) +import Prelude hiding (lookup, null) + + +newtype Ids a = Ids (IORef (S a)) + +data S a = S + {capacity :: {-# UNPACK #-} !Int -- ^ Number of entries in values, initially 0 + ,used :: {-# UNPACK #-} !Int -- ^ Capacity that has been used, assuming no gaps from index 0, initially 0 + ,values :: {-# UNPACK #-} !(MutableArray RealWorld (Maybe a)) + } + + +empty :: IO (Ids a) +empty = do + let capacity = 0 + let used = 0 + values <- newArray capacity Nothing + Ids <$> newIORef S{..} + +fromList :: [a] -> IO (Ids a) +fromList xs = do + let capacity = length xs + let used = capacity + values <- newArray capacity Nothing + forM_ (zipFrom 0 xs) $ \(i, x) -> + writeArray values i $ Just x + Ids <$> newIORef S{..} + +sizeUpperBound :: Ids a -> IO Int +sizeUpperBound (Ids ref) = do + S{..} <- readIORef ref + pure used + + +size :: Ids a -> IO Int +size (Ids ref) = do + S{..} <- readIORef ref + let go !acc i + | i < 0 = pure acc + | otherwise = do + v <- readArray values i + if isJust v then go (acc+1) (i-1) else go acc (i-1) + go 0 (used-1) + + +toMap :: Ids a -> IO (Map.HashMap Id a) +toMap ids = do + mp <- Map.fromList <$> toListUnsafe ids + pure $! mp + +forWithKeyM_ :: Ids a -> (Id -> a -> IO ()) -> IO () +forWithKeyM_ (Ids ref) f = do + S{..} <- readIORef ref + let go !i | i >= used = pure () + | otherwise = do + v <- readArray values i + whenJust v $ f $ fromIntegral i + go $ i+1 + go 0 + +forCopy :: Ids a -> (a -> b) -> IO (Ids b) +forCopy (Ids ref) f = do + S{..} <- readIORef ref + values2 <- newArray capacity Nothing + let go !i | i >= used = pure () + | otherwise = do + v <- readArray values i + whenJust v $ \v -> writeArray values2 i $ Just $ f v + go $ i+1 + go 0 + Ids <$> newIORef (S capacity used values2) + + +forMutate :: Ids a -> (Id -> a -> a) -> IO () +forMutate (Ids ref) f = do + S{..} <- readIORef ref + let go !i | i >= used = pure () + | otherwise = do + v <- readArray values i + whenJust v $ \v -> writeArray values i $! Just $! f i v + go $ i+1 + go 0 + + +toListUnsafe :: Ids a -> IO [(Id, a)] +toListUnsafe (Ids ref) = do + S{..} <- readIORef ref + + -- execute in O(1) stack + -- see https://neilmitchell.blogspot.co.uk/2015/09/making-sequencemapm-for-io-take-o1-stack.html + let index _ i | i >= used = [] + index r i | IO io <- readArray values i = case io r of + (# r, Nothing #) -> index r (i+1) + (# r, Just v #) -> (fromIntegral i, v) : index r (i+1) + + IO $ \r -> (# r, index r 0 #) + + +toList :: Ids a -> IO [(Id, a)] +toList ids = do + xs <- toListUnsafe ids + let demand (_:xs) = demand xs + demand [] = () + evaluate $ demand xs + pure xs + +elems :: Ids a -> IO [a] +elems ids = map snd <$> toList ids + +null :: Ids a -> IO Bool +null ids = (== 0) <$> sizeUpperBound ids + + +insert :: Ids a -> Id -> a -> IO () +insert (Ids ref) (i) v = do + S{..} <- readIORef ref + let ii = fromIntegral i + if ii < capacity then do + writeArray values ii $ Just v + when (ii >= used) $ writeIORef' ref S{used=ii+1,..} + else do + c2<- pure $ max (capacity * 2) (ii + 10000) + v2 <- newArray c2 Nothing + copyMutableArray v2 0 values 0 capacity + writeArray v2 ii $ Just v + writeIORef' ref $ S c2 (ii+1) v2 + +lookup :: Ids a -> Id -> IO (Maybe a) +lookup (Ids ref) (i) = do + S{..} <- readIORef ref + let ii = fromIntegral i + if ii < used then + readArray values ii + else + pure Nothing diff --git a/src/Development/IDE/Graph/Internal/Intern.hs b/src/Development/IDE/Graph/Internal/Intern.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Graph/Internal/Intern.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Development.IDE.Graph.Internal.Intern( + Intern, Id, + empty, insert, add, lookup, toList, fromList + ) where + +import qualified Data.HashMap.Strict as Map +import Data.List (foldl') +import Development.IDE.Graph.Classes +import Prelude hiding (lookup) + + +-- Invariant: The first field is the highest value in the Map +data Intern a = Intern {-# UNPACK #-} !Int !(Map.HashMap a Id) + +type Id = Int + +empty :: Intern a +empty = Intern 0 Map.empty + + +insert :: (Eq a, Hashable a) => a -> Id -> Intern a -> Intern a +insert k v (Intern n mp) = Intern (max n v) $ Map.insert k v mp + + +add :: (Eq a, Hashable a) => a -> Intern a -> (Intern a, Id) +add k (Intern v mp) = (Intern v2 $ Map.insert k v2 mp, v2) + where v2 = v + 1 + + +lookup :: (Eq a, Hashable a) => a -> Intern a -> Maybe Id +lookup k (Intern _ mp) = Map.lookup k mp + + +toList :: Intern a -> [(a, Id)] +toList (Intern _ mp) = Map.toList mp + + +fromList :: (Eq a, Hashable a) => [(a, Id)] -> Intern a +fromList xs = Intern (foldl' max 0 [i | (_, i) <- xs]) (Map.fromList xs) diff --git a/src/Development/IDE/Graph/Internal/Options.hs b/src/Development/IDE/Graph/Internal/Options.hs --- a/src/Development/IDE/Graph/Internal/Options.hs +++ b/src/Development/IDE/Graph/Internal/Options.hs @@ -2,13 +2,12 @@ module Development.IDE.Graph.Internal.Options where +import Control.Monad.Trans.Reader import Data.Dynamic -import qualified Data.HashMap.Strict as Map -import Development.IDE.Graph.Internal.Action -import Development.IDE.Graph.Internal.Rules -import qualified Development.Shake as Shake +import Development.IDE.Graph.Internal.Types data ShakeOptions = ShakeOptions { + -- | Has no effect, kept only for api compatibility with Shake shakeThreads :: Int, shakeFiles :: FilePath, shakeExtra :: Maybe Dynamic, @@ -19,22 +18,15 @@ shakeOptions :: ShakeOptions shakeOptions = ShakeOptions 0 ".shake" Nothing False False -fromShakeOptions :: ShakeOptions -> Shake.ShakeOptions -fromShakeOptions ShakeOptions{..} = Shake.shakeOptions{ - Shake.shakeThreads = shakeThreads, - Shake.shakeFiles = shakeFiles, - Shake.shakeExtra = maybe Map.empty f shakeExtra, - Shake.shakeAllowRedefineRules = shakeAllowRedefineRules, - Shake.shakeTimings = shakeTimings - } - where f x = Map.singleton (dynTypeRep x) x - - getShakeExtra :: Typeable a => Action (Maybe a) -getShakeExtra = Action Shake.getShakeExtra +getShakeExtra = do + extra <- Action $ asks $ databaseExtra . actionDatabase + pure $ fromDynamic extra getShakeExtraRules :: Typeable a => Rules (Maybe a) -getShakeExtraRules = Rules Shake.getShakeExtraRules +getShakeExtraRules = do + extra <- Rules $ asks rulesExtra + pure $ fromDynamic extra newShakeExtra :: Typeable a => a -> Maybe Dynamic newShakeExtra = Just . toDyn diff --git a/src/Development/IDE/Graph/Internal/Paths.hs b/src/Development/IDE/Graph/Internal/Paths.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Graph/Internal/Paths.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +module Development.IDE.Graph.Internal.Paths (getDataFile) where + +import Paths_hls_graph + +#ifndef FILE_EMBED +import Control.Exception (SomeException (SomeException), catch) +import Control.Monad (filterM) +import System.Directory (doesFileExist, getCurrentDirectory) +import System.Environment (getExecutablePath) +import System.FilePath (takeDirectory, ()) +import System.IO.Unsafe (unsafePerformIO) +#endif + +#ifdef FILE_EMBED +import qualified Data.ByteString as BS +import qualified Data.ByteString as LBS +import Data.FileEmbed + +initDataDirectory :: IO () +initDataDirectory = pure () + +htmlDataFiles :: [(FilePath, BS.ByteString)] +htmlDataFiles = + [ ("profile.html", $(embedFile "html/profile.html")) + , ("progress.html", $(embedFile "html/progress.html")) + , ("shake.js", $(embedFile "html/shake.js")) + ] + +readDataFileHTML :: FilePath -> IO LBS.ByteString +readDataFileHTML file = do + case lookup file htmlDataFiles of + Nothing -> fail $ "Could not find data file " ++ file ++ " in embedded data files!" + Just x -> pure (LBS.fromStrict x) + +manualDirData :: [(FilePath, BS.ByteString)] +manualDirData = $(embedDir "docs/manual") + +hasManualData :: IO Bool +hasManualData = pure True + +copyManualData :: FilePath -> IO () +copyManualData dest = do + createDirectoryRecursive dest + forM_ manualDirData $ \(file, bs) -> do + BS.writeFile (dest file) bs + +#else +-- We want getDataFileName to be relative to the current directory on program startup, +-- even if we issue a change directory command. Therefore, first call caches, future ones read. + +{-# NOINLINE dataDirs #-} +dataDirs :: [String] +dataDirs = unsafePerformIO $ do + datdir <- getDataDir + exedir <- takeDirectory <$> getExecutablePath `catch` \SomeException{} -> pure "" + curdir <- getCurrentDirectory + pure $ [datdir] ++ [exedir | exedir /= ""] ++ [curdir] + + +getDataFile :: FilePath -> IO FilePath +getDataFile file = do + let poss = map ( file) dataDirs + res <- filterM doesFileExist poss + case res of + [] -> fail $ unlines $ ("Could not find data file " ++ file ++ ", looked in:") : map (" " ++) poss + x:_ -> pure x + +#endif diff --git a/src/Development/IDE/Graph/Internal/Profile.hs b/src/Development/IDE/Graph/Internal/Profile.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Graph/Internal/Profile.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +{- HLINT ignore "Redundant bracket" -} -- a result of CPP expansion + +module Development.IDE.Graph.Internal.Profile (writeProfile) where + +import Data.Bifunctor +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Char +import Data.Dynamic (toDyn) +import qualified Data.HashMap.Strict as Map +import Data.IORef +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as Set +import Data.List (dropWhileEnd, foldl', + intercalate, + partition, sort, + sortBy) +import Data.List.Extra (nubOrd) +import Data.Maybe +import Data.Time (defaultTimeLocale, + formatTime, + getCurrentTime, + iso8601DateFormat) +import Development.IDE.Graph.Classes +import Development.IDE.Graph.Internal.Database (getDirtySet) +import qualified Development.IDE.Graph.Internal.Ids as Ids +import Development.IDE.Graph.Internal.Paths +import Development.IDE.Graph.Internal.Types +import qualified Language.Javascript.DGTable as DGTable +import qualified Language.Javascript.Flot as Flot +import qualified Language.Javascript.JQuery as JQuery +import Numeric.Extra (showDP) +import System.FilePath +import System.IO.Unsafe (unsafePerformIO) +import System.Time.Extra (Seconds) + +#ifdef FILE_EMBED +import Data.FileEmbed +import Language.Haskell.TH.Syntax (runIO) +#endif + +-- | Generates an report given some build system profiling data. +writeProfile :: FilePath -> Database -> IO () +writeProfile out db = do + (report, mapping) <- toReport db + dirtyKeysMapped <- do + dirtyIds <- Set.fromList . fmap fst <$> getDirtySet db + let dirtyKeysMapped = mapMaybe (`IntMap.lookup` mapping) . Set.toList $ dirtyIds + return $ Just $ sort dirtyKeysMapped + rpt <- generateHTML dirtyKeysMapped report + LBS.writeFile out rpt + +data ProfileEntry = ProfileEntry + {prfName :: !String, prfBuilt :: !Int, prfChanged :: !Int, prfVisited :: !Int, prfDepends :: [[Int]], prfExecution :: !Seconds} + +-- | Eliminate all errors from the database, pretending they don't exist +-- resultsOnly :: Map.HashMap Id (Key, Status) -> Map.HashMap Id (Key, Result (Either BS.ByteString Value)) +resultsOnly :: [(Ids.Id, (k, Status))] -> Map.HashMap Ids.Id (k, Result) +resultsOnly mp = Map.map (fmap (\r -> + r{resultDeps = mapResultDeps (filter (isJust . flip Map.lookup keep)) $ resultDeps r} + )) keep + where + keep = Map.fromList $ mapMaybe ((traverse.traverse) getResult) mp + +-- | Given a map of representing a dependency order (with a show for error messages), find an ordering for the items such +-- that no item points to an item before itself. +-- Raise an error if you end up with a cycle. +dependencyOrder :: (Eq a, Hashable a) => (a -> String) -> [(a,[a])] -> [a] +-- Algorithm: +-- Divide everyone up into those who have no dependencies [Id] +-- And those who depend on a particular Id, Dep :-> Maybe [(Key,[Dep])] +-- Where d :-> Just (k, ds), k depends on firstly d, then remaining on ds +-- For each with no dependencies, add to list, then take its dep hole and +-- promote them either to Nothing (if ds == []) or into a new slot. +-- k :-> Nothing means the key has already been freed +dependencyOrder shw status = + f (map fst noDeps) $ + Map.map Just $ + Map.fromListWith (++) + [(d, [(k,ds)]) | (k,d:ds) <- hasDeps] + where + (noDeps, hasDeps) = partition (null . snd) status + + f [] mp | null bad = [] + | otherwise = error $ unlines $ + "Internal invariant broken, database seems to be cyclic" : + map (" " ++) bad ++ + ["... plus " ++ show (length badOverflow) ++ " more ..." | not $ null badOverflow] + where (bad,badOverflow) = splitAt 10 [shw i | (i, Just _) <- Map.toList mp] + + f (x:xs) mp = x : f (now++xs) later + where Just free = Map.lookupDefault (Just []) x mp + (now,later) = foldl' g ([], Map.insert x Nothing mp) free + + g (free, mp) (k, []) = (k:free, mp) + g (free, mp) (k, d:ds) = case Map.lookupDefault (Just []) d mp of + Nothing -> g (free, mp) (k, ds) + Just todo -> (free, Map.insert d (Just $ (k,ds) : todo) mp) + +prepareForDependencyOrder :: Database -> IO (Map.HashMap Ids.Id (Key, Result)) +prepareForDependencyOrder db = do + current <- readIORef $ databaseStep db + Map.insert (-1) (Key "alwaysRerun", alwaysRerunResult current) . resultsOnly + <$> Ids.toList (databaseValues db) + +-- | Returns a list of profile entries, and a mapping linking a non-error Id to its profile entry +toReport :: Database -> IO ([ProfileEntry], IntMap Int) +toReport db = do + status <- prepareForDependencyOrder db + let order = let shw i = maybe "" (show . fst) $ Map.lookup i status + in dependencyOrder shw + $ map (second (getResultDepsDefault [-1] . resultDeps . snd)) + $ Map.toList status + ids = IntMap.fromList $ zip order [0..] + + steps = let xs = nubOrd $ concat [[resultChanged, resultBuilt, resultVisited] | (_k, Result{..}) <- Map.elems status] + + in Map.fromList $ zip (sortBy (flip compare) xs) [0..] + + f (k, Result{..}) = ProfileEntry + {prfName = show k + ,prfBuilt = fromStep resultBuilt + ,prfVisited = fromStep resultVisited + ,prfChanged = fromStep resultChanged + ,prfDepends = map pure $ mapMaybe (`IntMap.lookup` ids) $ getResultDepsDefault [-1] resultDeps + ,prfExecution = resultExecution + } + where fromStep i = fromJust $ Map.lookup i steps + pure ([maybe (error "toReport") f $ Map.lookup i status | i <- order], ids) + +alwaysRerunResult :: Step -> Result +alwaysRerunResult current = Result (Value $ toDyn "") (Step 0) (Step 0) current (ResultDeps []) 0 mempty + +readDataFileHTML :: FilePath -> IO LBS.ByteString +readDataFileHTML file = LBS.readFile =<< getDataFile ("html" file) + +generateHTML :: Maybe [Int] -> [ProfileEntry] -> IO LBS.ByteString +generateHTML dirtyKeys xs = do + report <- readDataFileHTML "profile.html" + let f "data/profile-data.js" = pure $ LBS.pack $ "var profile =\n" ++ generateJSONProfile xs + f "data/build-data.js" = pure $ LBS.pack $ "var build =\n" ++ generateJSONBuild dirtyKeys + f other = error other + runTemplate f report + +generateJSONBuild :: Maybe [Ids.Id] -> String +generateJSONBuild (Just dirtyKeys) = jsonList [jsonList (map show dirtyKeys)] +generateJSONBuild Nothing = jsonList [] + +generateJSONProfile :: [ProfileEntry] -> String +generateJSONProfile = jsonListLines . map showEntry + where + showEntry ProfileEntry{..} = jsonList $ + [show prfName + ,showTime prfExecution + ,show prfBuilt + ,show prfChanged + ,show prfVisited + ] ++ + [show prfDepends | not (null prfDepends)] + showTime x = if '.' `elem` y then dropWhileEnd (== '.') $ dropWhileEnd (== '0') y else y + where y = showDP 4 x + +jsonListLines :: [String] -> String +jsonListLines xs = "[" ++ intercalate "\n," xs ++ "\n]" + +jsonList :: [String] -> String +jsonList xs = "[" ++ intercalate "," xs ++ "]" + +-- Very hard to abstract over TH, so we do it with CPP +#ifdef FILE_EMBED +#define FILE(x) (pure (LBS.fromStrict $(embedFile =<< runIO (x)))) +#else +#define FILE(x) (LBS.readFile =<< (x)) +#endif + +libraries :: [(String, IO LBS.ByteString)] +libraries = + [("jquery.js", FILE(JQuery.file)) + ,("jquery.dgtable.js", FILE(DGTable.file)) + ,("jquery.flot.js", FILE(Flot.file Flot.Flot)) + ,("jquery.flot.stack.js", FILE(Flot.file Flot.FlotStack)) + ] + + +-- | Template Engine. Perform the following replacements on a line basis: +-- +-- * ==> +-- +-- * ==> +runTemplate :: (FilePath -> IO LBS.ByteString) -> LBS.ByteString -> IO LBS.ByteString +runTemplate ask = lbsMapLinesIO f + where + link = LBS.pack "\n" `LBS.append` res `LBS.append` LBS.pack "\n" + | Just file <- LBS.stripPrefix link y = do res <- grab file; pure $ LBS.pack "" + | otherwise = pure x + where + y = LBS.dropWhile isSpace x + grab = asker . takeWhile (/= '\"') . LBS.unpack + + asker o@(splitFileName -> ("lib/",x)) = + case lookup x libraries of + Nothing -> error $ "Template library, unknown library: " ++ o + Just act -> act + + asker "shake.js" = readDataFileHTML "shake.js" + asker "data/metadata.js" = do + time <- getCurrentTime + pure $ LBS.pack $ + "var version = \"0\"" ++ + "\nvar generated = " ++ show (formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S")) time) + asker x = ask x + +-- Perform a mapM on each line and put the result back together again +lbsMapLinesIO :: (LBS.ByteString -> IO LBS.ByteString) -> LBS.ByteString -> IO LBS.ByteString +-- If we do the obvious @fmap LBS.unlines . mapM f@ then all the monadic actions are run on all the lines +-- before it starts producing the lazy result, killing streaming and having more stack usage. +-- The real solution (albeit with too many dependencies for something small) is a streaming library, +-- but a little bit of unsafePerformIO does the trick too. +lbsMapLinesIO f = pure . LBS.unlines . map (unsafePerformIO . f) . LBS.lines diff --git a/src/Development/IDE/Graph/Internal/Rules.hs b/src/Development/IDE/Graph/Internal/Rules.hs --- a/src/Development/IDE/Graph/Internal/Rules.hs +++ b/src/Development/IDE/Graph/Internal/Rules.hs @@ -1,24 +1,60 @@ +-- We deliberately want to ensure the function we add to the rule database +-- has the constraints we need on it when we get it out. +{-# OPTIONS_GHC -Wno-redundant-constraints #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} module Development.IDE.Graph.Internal.Rules where -import Control.Monad.Fail -import Control.Monad.IO.Class -import qualified Data.ByteString as BS -import Development.IDE.Graph.Internal.Action -import qualified Development.Shake as Shake -import Development.Shake.Classes -import qualified Development.Shake.Rule as Shake +import Development.IDE.Graph.Classes +import Control.Exception.Extra +import Control.Monad +import Control.Monad.IO.Class +import qualified Data.ByteString as BS +import Data.Dynamic +import Data.Typeable +import Data.IORef +import qualified Data.HashMap.Strict as Map +import Control.Monad.Trans.Reader +import Development.IDE.Graph.Internal.Types +import Data.Maybe -newtype Rules a = Rules {fromRules :: Shake.Rules a} - deriving (Monoid, Semigroup, Monad, Applicative, Functor, MonadIO, MonadFail) +-- | The type mapping between the @key@ or a rule and the resulting @value@. +-- See 'addBuiltinRule' and 'Development.Shake.Rule.apply'. +type family RuleResult key -- = value action :: Action a -> Rules () -action = Rules . Shake.action . fromAction +action x = do + ref <- Rules $ asks rulesActions + liftIO $ modifyIORef' ref (void x:) addRule - :: (Shake.RuleResult key ~ value, Shake.ShakeValue key, Typeable value, NFData value, Show value) - => (key -> Maybe BS.ByteString -> Shake.RunMode -> Action (Shake.RunResult value)) + :: forall key value . + (RuleResult key ~ value, Typeable key, Hashable key, Eq key, Typeable value) + => (key -> Maybe BS.ByteString -> RunMode -> Action (RunResult value)) -> Rules () -addRule f = Rules $ Shake.addBuiltinRule Shake.noLint Shake.noIdentity $ \k bs r -> fromAction $ f k bs r +addRule f = do + ref <- Rules $ asks rulesMap + liftIO $ modifyIORef' ref $ Map.insert (typeRep (Proxy :: Proxy key)) (toDyn f2) + where + f2 :: Key -> Maybe BS.ByteString -> RunMode -> Action (RunResult Value) + f2 (Key a) b c = do + v <- f (fromJust $ cast a :: key) b c + v <- liftIO $ evaluate v + pure $ (Value . toDyn) <$> v + +runRule + :: TheRules -> Key -> Maybe BS.ByteString -> RunMode -> Action (RunResult Value) +runRule rules key@(Key t) bs mode = case Map.lookup (typeOf t) rules of + Nothing -> liftIO $ errorIO "Could not find key" + Just x -> unwrapDynamic x key bs mode + +runRules :: Dynamic -> Rules () -> IO (TheRules, [Action ()]) +runRules rulesExtra (Rules rules) = do + rulesActions <- newIORef [] + rulesMap <- newIORef Map.empty + runReaderT rules SRules{..} + (,) <$> readIORef rulesMap <*> readIORef rulesActions diff --git a/src/Development/IDE/Graph/Internal/Types.hs b/src/Development/IDE/Graph/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Graph/Internal/Types.hs @@ -0,0 +1,184 @@ + + +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Development.IDE.Graph.Internal.Types where + +import Control.Applicative +import Control.Concurrent.Extra +import Control.Monad.Catch +-- Needed in GHC 8.6.5 +import Control.Monad.Fail +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.ByteString as BS +import Data.Dynamic +import qualified Data.HashMap.Strict as Map +import Data.IORef +import Data.IntSet (IntSet) +import Data.Maybe +import Data.Typeable +import Development.IDE.Graph.Classes +import Development.IDE.Graph.Internal.Ids +import Development.IDE.Graph.Internal.Intern +import GHC.Generics (Generic) +import System.Time.Extra (Seconds) + + +unwrapDynamic :: forall a . Typeable a => Dynamic -> a +unwrapDynamic x = fromMaybe (error msg) $ fromDynamic x + where msg = "unwrapDynamic failed: Expected " ++ show (typeRep (Proxy :: Proxy a)) ++ + ", but got " ++ show (dynTypeRep x) + +--------------------------------------------------------------------- +-- RULES + +type TheRules = Map.HashMap TypeRep Dynamic + +newtype Rules a = Rules (ReaderT SRules IO a) + deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail) + +data SRules = SRules { + rulesExtra :: !Dynamic, + rulesActions :: !(IORef [Action ()]), + rulesMap :: !(IORef TheRules) + } + + +--------------------------------------------------------------------- +-- ACTIONS + +newtype Action a = Action {fromAction :: ReaderT SAction IO a} + deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask) + +data SAction = SAction { + actionDatabase :: !Database, + actionDeps :: !(IORef ResultDeps) + } + +getDatabase :: Action Database +getDatabase = Action $ asks actionDatabase + +--------------------------------------------------------------------- +-- DATABASE + +newtype Step = Step Int + deriving newtype (Eq,Ord,Hashable) + +data Key = forall a . (Typeable a, Eq a, Hashable a, Show a) => Key a + +instance Eq Key where + Key a == Key b = Just a == cast b + +instance Hashable Key where + hashWithSalt i (Key x) = hashWithSalt i (typeOf x, x) + +instance Show Key where + show (Key x) = show x + +newtype Value = Value Dynamic + +data Database = Database { + databaseExtra :: Dynamic, + databaseRules :: TheRules, + databaseStep :: !(IORef Step), + -- Hold the lock while mutating Ids/Values + databaseLock :: !Lock, + databaseIds :: !(IORef (Intern Key)), + databaseValues :: !(Ids (Key, Status)), + databaseReverseDeps :: !(Ids IntSet), + databaseReverseDepsLock :: !Lock + } + +data Status + = Clean Result + | Dirty (Maybe Result) + | Running (IO ()) Result (Maybe Result) + +getResult :: Status -> Maybe Result +getResult (Clean re) = Just re +getResult (Dirty m_re) = m_re +getResult (Running _ _ m_re) = m_re + +data Result = Result { + resultValue :: !Value, + resultBuilt :: !Step, -- ^ the step when it was last recomputed + resultChanged :: !Step, -- ^ the step when it last changed + resultVisited :: !Step, -- ^ the step when it was last looked up + resultDeps :: !ResultDeps, + resultExecution :: !Seconds, -- ^ How long it took, last time it ran + resultData :: BS.ByteString + } + +data ResultDeps = UnknownDeps | AlwaysRerunDeps ![Id] | ResultDeps ![Id] + +getResultDepsDefault :: [Id] -> ResultDeps -> [Id] +getResultDepsDefault _ (ResultDeps ids) = ids +getResultDepsDefault _ (AlwaysRerunDeps ids) = ids +getResultDepsDefault def UnknownDeps = def + +mapResultDeps :: ([Id] -> [Id]) -> ResultDeps -> ResultDeps +mapResultDeps f (ResultDeps ids) = ResultDeps $ f ids +mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ f ids +mapResultDeps _ UnknownDeps = UnknownDeps + +instance Semigroup ResultDeps where + UnknownDeps <> x = x + x <> UnknownDeps = x + AlwaysRerunDeps ids <> x = AlwaysRerunDeps (ids <> getResultDepsDefault [] x) + x <> AlwaysRerunDeps ids = AlwaysRerunDeps (getResultDepsDefault [] x <> ids) + ResultDeps ids <> ResultDeps ids' = ResultDeps (ids <> ids') + +instance Monoid ResultDeps where + mempty = UnknownDeps + +--------------------------------------------------------------------- +-- Running builds + +-- | What mode a rule is running in, passed as an argument to 'BuiltinRun'. +data RunMode + = RunDependenciesSame -- ^ My dependencies have not changed. + | RunDependenciesChanged -- ^ At least one of my dependencies from last time have changed, or I have no recorded dependencies. + deriving (Eq,Show) + +instance NFData RunMode where rnf x = x `seq` () + +-- | How the output of a rule has changed. +data RunChanged + = ChangedNothing -- ^ Nothing has changed. + | ChangedStore -- ^ The stored value has changed, but in a way that should be considered identical (used rarely). + | ChangedRecomputeSame -- ^ I recomputed the value and it was the same. + | ChangedRecomputeDiff -- ^ I recomputed the value and it was different. + deriving (Eq,Show,Generic) + deriving anyclass (FromJSON, ToJSON) + +instance NFData RunChanged where rnf x = x `seq` () + +-- | The result of 'BuiltinRun'. +data RunResult value = RunResult + {runChanged :: RunChanged + -- ^ How has the 'RunResult' changed from what happened last time. + ,runStore :: BS.ByteString + -- ^ The value to store in the Shake database. + ,runValue :: value + -- ^ The value to return from 'Development.Shake.Rule.apply'. + } deriving Functor + +instance NFData value => NFData (RunResult value) where + rnf (RunResult x1 x2 x3) = rnf x1 `seq` x2 `seq` rnf x3 + +--------------------------------------------------------------------- +-- INSTANCES + +instance Semigroup a => Semigroup (Rules a) where + a <> b = liftA2 (<>) a b + +instance Monoid a => Monoid (Rules a) where + mempty = pure mempty diff --git a/src/Development/IDE/Graph/Rule.hs b/src/Development/IDE/Graph/Rule.hs --- a/src/Development/IDE/Graph/Rule.hs +++ b/src/Development/IDE/Graph/Rule.hs @@ -4,7 +4,7 @@ -- * Defining builtin rules -- | Functions and types for defining new types of Shake rules. addRule, - Shake.RunMode(..), Shake.RunChanged(..), Shake.RunResult(..), + RunMode(..), RunChanged(..), RunResult(..), -- * Calling builtin rules -- | Wrappers around calling Shake rules. In general these should be specialised to a builtin rule. apply, apply1, @@ -12,4 +12,4 @@ import Development.IDE.Graph.Internal.Action import Development.IDE.Graph.Internal.Rules -import qualified Development.Shake.Rule as Shake +import Development.IDE.Graph.Internal.Types