add a view for Haskell STG intermediary output #3571 (#3585)

compiler-explorer · Apr 28, 2022 · 943af8f · 943af8f
1 parent 3cf18aa
commit 943af8f
Show file tree

Hide file tree

Showing 9 changed files with 286 additions and 8 deletions.
diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
@@ -116,3 +116,4 @@ From oldest to newest contributor, we would like to thank:
 - [Ankur Saini](https://github.com/Arsenic-ATG)
 - [m8mble](https://github.com/m8mble)
 - [Anders-T](https://github.com/anders-torbjornsen)
+- [Adam Sandberg Eriksson](https://github.com/adamse)
diff --git a/lib/base-compiler.js b/lib/base-compiler.js
@@ -891,6 +891,10 @@ export class BaseCompiler {
         return outputFilename.replace(path.extname(outputFilename), '.mir');
     }
 
+    getHaskellStgOutputFilename(inputFilename) {
+        return inputFilename.replace(path.extname(inputFilename), '.dump-stg-final');
+    }
+
     // Currently called for getting macro expansion and HIR.
     // It returns the content of the output file created after using -Z unpretty=<unprettyOpt>.
     // The outputFriendlyName is a free form string used in case of error.
@@ -938,6 +942,29 @@ export class BaseCompiler {
         return [{text: 'Internal error; unable to open output path'}];
     }
 
+    async processHaskellStgOutput(inputFilename, output) {
+        const stgPath = this.getHaskellStgOutputFilename(inputFilename);
+        if (output.code !== 0) {
+            return [{text: 'Failed to run compiler to get Haskell STG'}];
+        }
+        if (await fs.exists(stgPath)) {
+            const content = await fs.readFile(stgPath, 'utf-8');
+            // output file starts with
+            //
+            // ==================== Final STG: ====================
+            // 2022-04-27 16:48:25.411966835 UTC
+            //
+            // we want to drop this to make the output nicer
+            return content
+                .split('\n')
+                .slice(4)
+                .map(line => ({
+                    text: line,
+                }));
+        }
+        return [{text: 'Internal error; unable to open output path'}];
+    }
+
     getIrOutputFilename(inputFilename) {
         return inputFilename.replace(path.extname(inputFilename), '.ll');
     }
@@ -1422,6 +1449,7 @@ export class BaseCompiler {
         const makeRustMir = backendOptions.produceRustMir && this.compiler.supportsRustMirView;
         const makeRustMacroExp = backendOptions.produceRustMacroExp && this.compiler.supportsRustMacroExpView;
         const makeRustHir = backendOptions.produceRustHir && this.compiler.supportsRustHirView;
+        const makeHaskellStg = backendOptions.produceHaskellStg && this.compiler.supportsHaskellStgView;
         const makeGccDump =
             backendOptions.produceGccDump && backendOptions.produceGccDump.opened && this.compiler.supportsGccDump;
 
@@ -1462,6 +1490,8 @@ export class BaseCompiler {
             : '';
         const rustMirResult = makeRustMir ? await this.processRustMirOutput(outputFilename, asmResult) : '';
 
+        const haskellStgResult = makeHaskellStg ? await this.processHaskellStgOutput(inputFilename, asmResult) : '';
+
         asmResult.dirPath = dirPath;
         asmResult.compilationOptions = options;
         asmResult.downloads = downloads;
@@ -1526,6 +1556,10 @@ export class BaseCompiler {
             asmResult.hasRustHirOutput = true;
             asmResult.rustHirOutput = rustHirResult;
         }
+        if (haskellStgResult) {
+            asmResult.hasHaskellStgOutput = true;
+            asmResult.haskellStgOutput = haskellStgResult;
+        }
 
         return this.checkOutputFileAndDoPostProcess(asmResult, outputFilename, filters);
     }

diff --git a/lib/compilers/haskell.js b/lib/compilers/haskell.js
@@ -22,28 +22,40 @@
 // ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 // POSSIBILITY OF SUCH DAMAGE.
 
-import { BaseCompiler } from '../base-compiler';
+import path from 'path';
 
-import { ClangParser } from './argument-parsers';
+import {BaseCompiler} from '../base-compiler';
+
+import {ClangParser} from './argument-parsers';
 
 export class HaskellCompiler extends BaseCompiler {
     static get key() {
         return 'haskell';
     }
 
+    constructor(info, env) {
+        super(info, env);
+        this.compiler.supportsHaskellStgView = true;
+    }
+
+    optionsForBackend(backendOptions, outputFilename) {
+        const opts = super.optionsForBackend(backendOptions, outputFilename);
+
+        if (backendOptions.produceHaskellStg && this.compiler.supportsHaskellStgView) {
+            opts.push('-ddump-to-file', '-dumpdir', path.dirname(outputFilename), '-ddump-stg-final');
+        }
+        return opts;
+    }
+
     optionsForFilter(filters, outputFilename) {
         const options = ['-g', '-o', this.filename(outputFilename)];
-        if (!filters.binary)
-            options.unshift('-S');
+        if (!filters.binary) options.unshift('-S');
         return options;
     }
 
     getSharedLibraryPathsAsArguments(libraries) {
         const libPathFlag = this.compiler.libpathFlag || '-L';
-        return [
-            libPathFlag + '.',
-            ...this.getSharedLibraryPaths(libraries).map(path => libPathFlag + path),
-        ];
+        return [libPathFlag + '.', ...this.getSharedLibraryPaths(libraries).map(path => libPathFlag + path)];
     }
 
     getArgumentParser() {

diff --git a/static/components.js b/static/components.js
@@ -338,6 +338,27 @@ module.exports = {
             },
         };
     },
+    getHaskellStgView: function () {
+        return {
+            type: 'component',
+            componentName: 'haskellStg',
+            componentState: {},
+        };
+    },
+    getHaskellStgViewWith: function (id, source, haskellStgOutput, compilerName, editorid, treeid) {
+        return {
+            type: 'component',
+            componentName: 'haskellStg',
+            componentState: {
+                id: id,
+                source: source,
+                haskellStgOutput: haskellStgOutput,
+                compilerName: compilerName,
+                editorid: editorid,
+                treeid: treeid,
+            },
+        };
+    },
 
     getGnatDebugTreeView: function () {
         return {

diff --git a/static/hub.ts b/static/hub.ts
@@ -46,6 +46,7 @@ import {DeviceAsm as DeviceView} from './panes/device-view';
 import {GnatDebug as GnatDebugView} from './panes/gnatdebug-view';
 import {RustMir as RustMirView} from './panes/rustmir-view';
 import {RustHir as RustHirView} from './panes/rusthir-view';
+import {HaskellStg as HaskellStgView} from './panes/haskellstg-view';
 import {GccDump as GCCDumpView} from './panes/gccdump-view';
 import {Cfg as CfgView} from './panes/cfg-view';
 import {Conformance as ConformanceView} from './panes/conformance-view';
@@ -94,6 +95,9 @@ export class Hub {
         layout.registerComponent(Components.getIrView().componentName, (c, s) => this.irViewFactory(c, s));
         layout.registerComponent(Components.getDeviceView().componentName, (c, s) => this.deviceViewFactory(c, s));
         layout.registerComponent(Components.getRustMirView().componentName, (c, s) => this.rustMirViewFactory(c, s));
+        layout.registerComponent(Components.getHaskellStgView().componentName, (c, s) =>
+            this.haskellStgViewFactory(c, s)
+        );
         // eslint-disable-next-line max-len
         layout.registerComponent(Components.getGnatDebugTreeView().componentName, (c, s) =>
             this.gnatDebugTreeViewFactory(c, s)
@@ -463,6 +467,13 @@ export class Hub {
         return new RustHirView(this, container, state);
     }
 
+    public haskellStgViewFactory(
+        container: GoldenLayout.Container,
+        state: ConstructorParameters<typeof HaskellStgView>[2]
+    ): HaskellStgView {
+        return new HaskellStgView(this, container, state);
+    }
+
     public gccDumpViewFactory(container: GoldenLayout.Container, state: any): any /* typeof GccDumpView */ {
         return new GCCDumpView(this, container, state);
     }

diff --git a/static/panes/compiler.js b/static/panes/compiler.js
@@ -330,6 +330,17 @@ Compiler.prototype.initPanerButtons = function () {
         );
     }, this);
 
+    var createHaskellStgView = _.bind(function () {
+        return Components.getHaskellStgViewWith(
+            this.id,
+            this.source,
+            this.lastResult.haskellStgOutput,
+            this.getCompilerName(),
+            this.sourceEditorId,
+            this.sourceTreeId
+        );
+    }, this);
+
     var createGccDumpView = _.bind(function () {
         return Components.getGccDumpViewWith(
             this.id,
@@ -486,6 +497,18 @@ Compiler.prototype.initPanerButtons = function () {
         }, this)
     );
 
+    this.container.layoutManager
+        .createDragSource(this.haskellStgButton, createHaskellStgView)
+        ._dragListener.on('dragStart', togglePannerAdder);
+
+    this.haskellStgButton.click(
+        _.bind(function () {
+            var insertPoint =
+                this.hub.findParentRowOrColumn(this.container) || this.container.layoutManager.root.contentItems[0];
+            insertPoint.addChild(createHaskellStgView);
+        }, this)
+    );
+
     this.container.layoutManager
         .createDragSource(this.rustMacroExpButton, createRustMacroExpView)
         ._dragListener.on('dragStart', togglePannerAdder);
@@ -865,6 +888,7 @@ Compiler.prototype.compile = function (bypassCache, newTools) {
             produceRustMir: this.rustMirViewOpen,
             produceRustMacroExp: this.rustMacroExpViewOpen,
             produceRustHir: this.rustHirViewOpen,
+            produceHaskellStg: this.haskellStgViewOpen,
         },
         filters: this.getEffectiveFilters(),
         tools: this.getActiveTools(newTools),
@@ -1488,6 +1512,21 @@ Compiler.prototype.onRustMirViewClosed = function (id) {
     }
 };
 
+Compiler.prototype.onHaskellStgViewOpened = function (id) {
+    if (this.id === id) {
+        this.haskellStgButton.prop('disabled', true);
+        this.haskellStgViewOpen = true;
+        this.compile();
+    }
+};
+
+Compiler.prototype.onHaskellStgViewClosed = function (id) {
+    if (this.id === id) {
+        this.haskellStgButton.prop('disabled', false);
+        this.haskellStgViewOpen = false;
+    }
+};
+
 Compiler.prototype.onGnatDebugTreeViewOpened = function (id) {
     if (this.id === id) {
         this.gnatDebugTreeButton.prop('disabled', true);
@@ -1690,6 +1729,7 @@ Compiler.prototype.initButtons = function (state) {
     this.rustMirButton = this.domRoot.find('.btn.view-rustmir');
     this.rustMacroExpButton = this.domRoot.find('.btn.view-rustmacroexp');
     this.rustHirButton = this.domRoot.find('.btn.view-rusthir');
+    this.haskellStgButton = this.domRoot.find('.btn.view-haskellStg');
     this.gccDumpButton = this.domRoot.find('.btn.view-gccdump');
     this.cfgButton = this.domRoot.find('.btn.view-cfg');
     this.executorButton = this.domRoot.find('.create-executor');
@@ -1934,6 +1974,7 @@ Compiler.prototype.updateButtons = function () {
     this.irButton.prop('disabled', this.irViewOpen);
     this.deviceButton.prop('disabled', this.deviceViewOpen);
     this.rustMirButton.prop('disabled', this.rustMirViewOpen);
+    this.haskellStgButton.prop('disabled', this.haskellStgrViewOpen);
     this.rustMacroExpButton.prop('disabled', this.rustMacroExpViewOpen);
     this.rustHirButton.prop('disabled', this.rustHirViewOpen);
     this.cfgButton.prop('disabled', this.cfgViewOpen);
@@ -1951,6 +1992,7 @@ Compiler.prototype.updateButtons = function () {
     this.rustMirButton.toggle(!!this.compiler.supportsRustMirView);
     this.rustMacroExpButton.toggle(!!this.compiler.supportsRustMacroExpView);
     this.rustHirButton.toggle(!!this.compiler.supportsRustHirView);
+    this.haskellStgButton.toggle(!!this.compiler.supportsHaskellStgView);
     this.cfgButton.toggle(!!this.compiler.supportsCfg);
     this.gccDumpButton.toggle(!!this.compiler.supportsGccDump);
     this.gnatDebugTreeButton.toggle(!!this.compiler.supportsGnatDebugViews);
@@ -2064,6 +2106,8 @@ Compiler.prototype.initListeners = function () {
     this.eventHub.on('rustMacroExpViewClosed', this.onRustMacroExpViewClosed, this);
     this.eventHub.on('rustHirViewOpened', this.onRustHirViewOpened, this);
     this.eventHub.on('rustHirViewClosed', this.onRustHirViewClosed, this);
+    this.eventHub.on('haskellStgViewOpened', this.onHaskellStgViewOpened, this);
+    this.eventHub.on('haskellStgViewClosed', this.onHaskellStgViewClosed, this);
     this.eventHub.on('outputOpened', this.onOutputOpened, this);
     this.eventHub.on('outputClosed', this.onOutputClosed, this);
 

diff --git a/static/panes/haskellstg-view.interfaces.ts b/static/panes/haskellstg-view.interfaces.ts
@@ -0,0 +1,27 @@
+// Copyright (c) 2022, Compiler Explorer Authors
+// All rights reserved.
+//
+// Redistribution and use in source and binary forms, with or without
+// modification, are permitted provided that the following conditions are met:
+//
+//     * Redistributions of source code must retain the above copyright notice,
+//       this list of conditions and the following disclaimer.
+//     * Redistributions in binary form must reproduce the above copyright
+//       notice, this list of conditions and the following disclaimer in the
+//       documentation and/or other materials provided with the distribution.
+//
+// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+// ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+// LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+// CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+// SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+// CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+// ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+// POSSIBILITY OF SUCH DAMAGE.
+
+export interface HaskellStgState {
+    haskellStgOutput: any;
+}