Fix space leak between modules during compilation (#4517)

* Fix space leak between modules during compilation

For builds with a lot of warnings, memory usage grows drastically
since it appears that the thunks for the warnings hang onto a lot
of memory from compiling the module itself.

The goal of this change is to get memory usage for full builds
back in line with partial builds.

* Limit concurrent builds to getNumCapabilities

This ensures that modules are fully built in one pass,
to avoid partial builds being interrupted and holding onto
memory in the meantime.

* Use Data.Map.Strict in CSE

* Add script for traces in eventlog

* Add changelog entry

CHANGELOG.d/fix_module-space-leak.md

@@ -0,0 +1,11 @@
+* Fix two space leaks while compiling many modules
+
+ The first would interleave compilation of too many modules at once, which
+ would increase memory usage, especially for single threaded builds with
+ `+RTS -N1 -RTS`. Now the number of concurrent modules is limited to
+ the number of threads available to the
+ [GHC runtime system](https://downloads.haskell.org/ghc/latest/docs/users_guide/using-concurrent.html#rts-options-for-smp-parallelism).
+
+ The second would hold on to memory from modules that compiled with warnings
+ until the end of the build when the warnings were printed and the memory freed.
+ This is now fixed with additional `NFData` instances.

debug/eventlog.js

@@ -0,0 +1,215 @@
+// Debug compilation times of modules from eventlog profiling
+//
+// Build and run purs with profiling enabled:
+// cabal build --enable-profiling
+// cabal exec -- purs ......
+// Or with stack:
+// stack build --profile
+// stack --profile exec -- purs ......
+// Run a command like this to generate purs.eventlog:
+// purs +RTS -l-agu -i1.5 -hc -RTS compile -g corefn $(spago sources)
+// (If you want accurate stats for individual modules, add -N1.)
+// Process it with
+// eventlog2html --json purs.eventlog
+// node eventlog.js purs.eventlog.json
+//
+// See the GHC docs for descriptions of the RTS flags:
+// - https://downloads.haskell.org/ghc/latest/docs/users_guide/profiling.html#rts-options-for-heap-profiling
+// - https://downloads.haskell.org/ghc/latest/docs/users_guide/runtime_control.html#rts-eventlog
+// - https://downloads.haskell.org/ghc/latest/docs/users_guide/using-concurrent.html?highlight=threaded#rts-options-for-smp-parallelism
+var mainFile = process.argv[2];
+if (!mainFile) throw new Error("Provide a file name");
+
+var name_length = 0;
+
+function summarizeEventlog(filename) {
+ var eventlog = JSON.parse(require("fs").readFileSync(filename, "utf-8"));
+ // eventlog.heap
+ // c: Set(3) { 'Heap Size', 'Live Bytes', 'Blocks Size' }
+ // eventlog.samples
+ // eventlog.traces
+
+ var traces = {};
+ var minTx = Infinity;
+ var maxTx = -Infinity;
+ var maxMem = -Infinity;
+ var total = 0;
+ var con = [];
+ var max_cons = [[]];
+ var cursor = 0;
+
+ // I guess some buffering makes it out of order?
+ eventlog.traces.sort(({tx: tx1}, {tx: tx2}) => tx1 - tx2);
+
+ for (let trace of eventlog.traces) {
+ var m = /^([\w.]+) (start|end)$/.exec(trace.desc);
+ if (!m) continue;
+ var name = m[1];
+ if (!(name in traces)) traces[name] = {};
+ if (name.length > name_length) name_length = name.length;
+ var ev = m[2];
+
+ if (traces[name][ev]) {
+ if (traces[name].time === 0) {
+ console.log("Warn: start after end", name, traces[name].start, trace.tx);
+ } else {
+ console.log("Warn: duplicate event", trace.desc);
+ }
+ continue;
+ }
+
+ var time = trace.tx;
+ if (time < minTx) minTx = time;
+ if (time > maxTx) maxTx = time;
+
+ while (cursor < eventlog.heap.length && eventlog.heap[cursor].x < trace.tx) {
+ cursor++;
+ if (eventlog.heap[cursor].c !== 'Heap Size') {
+ cursor = eventlog.heap.length;
+ }
+ }
+ if (ev === "start") {
+ traces[name].cursor = cursor;
+ }
+
+ traces[name][ev] = time;
+ if (ev === "end" && !("start" in traces[name])) {
+ console.log("Warn: missing start for", name);
+ traces[name].start = time;
+ traces[name].time = 0;
+ continue;
+ }
+ if ("start" in traces[name] && "end" in traces[name]) {
+ traces[name].time = traces[name].end - traces[name].start;
+ var mems = eventlog.heap.slice(traces[name].cursor, cursor).map(e => e.y);
+ var mem_min = Math.min(...mems);
+ var mem_max = Math.max(...mems);
+ var maxMem = Math.max(maxMem, mem_max);
+ Object.assign(traces[name], {mem_min,mem_max});
+ total += traces[name].time;
+ }
+
+ if (ev === "start") con = con.concat([name]);
+ if (ev === "end") {
+ var l = con.length;
+ con = con.filter(n => n !== name);
+ if (con.length !== l - 1) {
+ console.log(con, name);
+ }
+ }
+ if (con.length >= max_cons[0].length) {
+ if (con.length > max_cons[0].length)
+ max_cons = [];
+ max_cons.push(con);
+ }
+ }
+
+ var timespan = maxTx - minTx;
+
+ return { traces, total, minTx, maxTx, timespan, max_cons, maxMem };
+}
+
+var mainFiles = process.argv.slice(2);
+
+if (mainFiles.length > 1) {
+ for (let file of mainFiles) {
+ console.log(file);
+ var { traces, total, timespan, max_cons, maxMem } = summarizeEventlog(file);
+ if (timespan === -Infinity && total === 0 && max_cons[0].length === 0) continue;
+ var max_con_time = 0;
+ var concurrencies = max_cons.map(max_con => {
+ if (max_con.length !== max_cons[0].length)
+ throw new Error("max_con length error");
+ var modules = max_con.map(name => [name, traces[name]]);
+ var start = Math.max(...modules.map(([name, {start}]) => start));
+ var end = Math.min(...modules.map(([name, {end}]) => end));
+ var time = end - start;
+ max_con_time += time;
+ return {
+ modules,
+ start,
+ end,
+ time,
+ };
+ });
+ console.log("timespan ", timespan);
+ console.log("ratio (avg concurrency?) ", total/timespan);
+ console.log("max concurrency ", max_cons[0].length);
+ console.log("time at max concurrency (%)", 100*max_con_time/timespan);
+ console.log("peak heap size ", space(maxMem));
+ }
+ process.exit(0);
+}
+
+var { traces, total, timespan, max_cons } = summarizeEventlog(mainFile);
+
+var timings = [];
+for (let name in traces) {
+ let trace = traces[name];
+ if (!("time" in trace)) {
+ console.log("Warn: missing timing for", name, trace);
+ } else if (trace.time > 0) {
+ timings.push([name, trace.time]);
+ }
+}
+
+timings.sort(([n1,t1,_1,m1], [n2,t2,_2,m2]) => t1 - t2);
+
+timings.push(["stats", "-----"]);
+timings.push(["total", total]);
+timings.push(["timespan", timespan]);
+timings.push(["ratio (avg concurrency?)", total/timespan]);
+var max_con_time = 0;
+var concurrencies = max_cons.map(max_con => {
+ if (max_con.length !== max_cons[0].length)
+ throw new Error("max_con length error");
+ var modules = max_con.map(name => [name, traces[name]]);
+ var start = Math.max(...modules.map(([name, {start}]) => start));
+ var end = Math.min(...modules.map(([name, {end}]) => end));
+ var time = end - start;
+ max_con_time += time;
+ return {
+ modules,
+ start,
+ end,
+ time,
+ };
+});
+timings.push(["max concurrency", max_cons[0].length]);
+timings.push(["time at max concurrency (s)", max_con_time]);
+timings.push(["time at max concurrency (%)", 100*max_con_time/timespan]);
+
+for (let [name, time] of timings) {
+ // console.log(name.padEnd(name_length, " "), (""+time).substring(0, 5).padStart(5, " "));
+ console.log(name.padEnd(name_length, " "), time);
+}
+
+//require("fs").writeFileSync("concurrencies.json", JSON.stringify(concurrencies, null, 2), "utf-8");
+
+
+function space(v) {
+ if (!isFinite(v)) return "----";
+ if (v === Infinity) return "+Inf";
+ if (v === -Infinity) return "-Inf";
+ if (v !== v) return " NaN";
+ var sizes = [
+ [1_000_000_000, "G"],
+ [1_000_000, "M"],
+ [1_000, "K"],
+ [0, ""],
+ ]
+ for (let [value, suffix] of sizes) {
+ if (v < value) continue;
+ if (!suffix) return (""+v).padStart(4, " ");
+ var adj = v/value;
+ var str = ""+adj;
+ if (adj >= 100) return str.substring(0,3)+suffix;
+ if (adj >= 10) return " "+str.substring(0,2)+suffix;
+ return str.substring(0,3)+suffix;
+ }
+}
+function signed(fmt, v) {
+ if (!isFinite(v)) return " "+fmt(v);
+ if (v < 0) return "-"+fmt(-v);
+ return "+"+fmt(v);
+}

src/Language/PureScript/AST/Binders.hs

@@ -1,10 +1,13 @@
+{-# LANGUAGE DeriveAnyClass #-}
 -- |
 -- Case binders
 --
 module Language.PureScript.AST.Binders where
 
 import Prelude
 
+import Control.DeepSeq (NFData)
+import GHC.Generics (Generic)
 import Language.PureScript.AST.SourcePos (SourceSpan)
 import Language.PureScript.AST.Literals (Literal(..))
 import Language.PureScript.Names (Ident, OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified)
@@ -61,7 +64,7 @@ data Binder
  -- A binder with a type annotation
  --
  | TypedBinder SourceType Binder
- deriving (Show)
+ deriving (Show, Generic, NFData)
 
 -- Manual Eq and Ord instances for `Binder` were added on 2018-03-05. Comparing
 -- the `SourceSpan` values embedded in some of the data constructors of `Binder`