├── .github └── workflows │ └── main.yml ├── .gitignore ├── README.md ├── cabal.project ├── dap-estgi-server ├── CHANGELOG.md ├── LICENSE ├── dap-estgi-server.cabal └── src │ ├── Breakpoints.hs │ ├── CustomCommands.hs │ ├── DapBase.hs │ ├── Graph.hs │ ├── GraphProtocol │ ├── Commands.hs │ └── Server.hs │ ├── Inspect │ ├── Stack.hs │ ├── Value.hs │ └── Value │ │ ├── Atom.hs │ │ ├── HeapObject.hs │ │ └── StackContinuation.hs │ ├── Main.hs │ ├── SourceCode.hs │ └── SourceLocation.hs ├── default.nix ├── docs-images ├── dap-01-vscode-setup-5fps.avif ├── dap-02-run-dap-estgi-extension-5fps.avif ├── dap-03-start-dap-estgi-server-5fps.avif ├── dap-04-compile-debuggee-5fps.avif └── dap-05-open-debuggee-in-vscode-5fps.avif ├── nixpkgs.json ├── sample-program-to-debug ├── LICENSE ├── Main.hs ├── hello.cabal └── stack.yaml ├── shell.nix ├── source.json └── stack.yaml /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: Haskell Debugger CI 2 | on: 3 | push: 4 | branches: 5 | - master 6 | pull_request: 7 | 8 | jobs: 9 | build: 10 | runs-on: ubuntu-latest 11 | if: github.ref != 'refs/heads/master' 12 | steps: 13 | - uses: DeterminateSystems/nix-installer-action@main 14 | - uses: actions/checkout@v3.5.3 15 | - uses: cachix/install-nix-action@v25 16 | with: 17 | nix_path: nixpkgs=channel:nixpkgs-unstable 18 | 19 | - name: Nix channel update 20 | run: nix-channel --update 21 | 22 | - name: Cabal install 23 | run: nix-env -iA pkgs.cabal-install -f . 24 | 25 | - name: Cabal update 26 | run: cabal update 27 | 28 | - name: (x86 - C++) Build ext-stg-gc (souffle-produced reachability analysis for GC) 29 | run: nix-build -A ext-stg-gc 30 | 31 | - name: (x86 - GHC 9.6.6) Build dap-estgi-server w/ nix 32 | run: nix-build -A dap-estgi-server 33 | 34 | # - name: (x86 - GHC 9.6.6) Build dap-estgi-server w/ cabal 35 | # run: nix-shell -p pkgs.ghc -p pkgs.bzip2.dev -p pkgs.zlib.dev --run 'cabal build dap-estgi-server' -I=. 36 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # vscode-extension 2 | out 3 | dist/ 4 | node_modules 5 | .vscode-test/ 6 | npm-debug.log 7 | mock-debug.txt 8 | *.vsix 9 | .DS_Store 10 | dap-extension/package-lock.json 11 | 12 | # haskell 13 | stack.yaml.lock 14 | .stack-work/ 15 | dist-newstyle/ 16 | cabal.project.local 17 | .ghc.environment.* 18 | *.o 19 | *.hi 20 | 21 | # nix 22 | result* 23 | 24 | # osx 25 | .DS_Store 26 | 27 | # emacs 28 | *~ 29 | 30 | # tags 31 | TAGS 32 | main 33 | 34 | # C 35 | ./main 36 | *.dSYM 37 | 38 | # stg 39 | *.fullpak 40 | *.modpak 41 | 42 | # tags 43 | tags 44 | 45 | # external-stg-interpreter 46 | .ext-stg-work 47 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Haskell ESTGi Debugger ![GitHub Actions Workflow Status](https://img.shields.io/github/actions/workflow/status/haskell-debugger/haskell-estgi-debugger/main.yml?style=flat-square) 2 | 3 | 4 | # Table of Contents 5 | 1. [Introduction](#introduction) 6 | 2. [Overview](#overview) 7 | 3. [Setup](#setup) 8 | 4. [Development](#development) 9 | 10 | ## Introduction 11 | 12 | This repository contains the `dap-estgi-server` for Haskell debugging based on the Debug Adapter Protocol ([DAP](https://microsoft.github.io/debug-adapter-protocol)). 13 | 14 | - [`dap-estgi-server/`](dap-estgi-server/): DAP server for External STG Interpreter (DAP-ESTGi) 15 | 16 | This library depends on two other libraries as well 17 | 18 | - [`dap/`](https://github.com/haskell-debugger/dap/): Language and backend independent DAP library 19 | - [`dap-estgi-vscode-extension/`](https://github.com/haskell-debugger/dap-estgi-vscode-extension/): VSCode extension to support Haskell debugging using DAP-ESTGi server 20 | 21 | ## Overview 22 | 23 | The `dap-estgi-vscode-extension` turns VSCode into a Haskell debugger. 24 | VSCode offers a nice debugger UI while the debugger features are provided by the External STG Interpreter DAP Server. 25 | 26 | ```mermaid 27 | flowchart LR 28 | subgraph User Interface 29 | A(VSCode) -.- |Plugin API| B(DAP ESTGi Extension) 30 | end 31 | B <-->|DAP via network| C(DAP ESTGi Server) 32 | subgraph Debugger 33 | C -.- |HS library API| D(External STG Interpreter) 34 | end 35 | ``` 36 | 37 | The `dap-estgi-server` and `dap-estgi-vscode-extension` are application specific components, while the `dap` library is designed to be application independent to support any project that needs a simple DAP framework. 38 | 39 | ## Setup 40 | - Enable `Allow breakpoints everywhere` option in VSCode settings. 41 | 42 | ### Install Haskell ESTGi Debugger Dependencies 43 | - Run `(cd haskell-estgi-debugger ; stack install zip-cmd)` 44 | - Ensure `libgmp` is installed (e.g. if using homebrew, `brew install gmp`) 45 | 46 | ### Install `dap-estgi-extension` 47 | - Run `(git clone https://github.com/haskell-debugger/dap-estgi-vscode-extension; cd dap-estgi-vscode-extension ; npm install)` 48 | - Open `dap-estgi-vscode-extension` folder by using the `Files/Open Folder` menu. 49 | - Open the `src/extension.ts` file. 50 | - Press F5 to run the extension in a new VSCode [Extension Development Host] window. 51 | 52 | ### Start `dap-estgi-server` 53 | `(cd dap-estgi-server ; stack run)` 54 | 55 | **Note**: If using Darwin OSX and you receive 56 | 57 | ``` 58 | external-stg-interpreter> * Missing (or bad) C library: omp 59 | external-stg-interpreter> This problem can usually be solved by installing the system package that 60 | external-stg-interpreter> provides this library (you may need the "-dev" version). If the library is 61 | external-stg-interpreter> already installed but in a non-standard location then you can use the flags 62 | external-stg-interpreter> --extra-include-dirs= and --extra-lib-dirs= to specify where it is.If the 63 | external-stg-interpreter> library file does exist, it may contain errors that are caught by the C 64 | external-stg-interpreter> compiler at the preprocessing stage. In this case you can re-run configure 65 | external-stg-interpreter> with the verbosity flag -v3 to see the error messages. 66 | ``` 67 | 68 | Try installing `libomp` from [brew](https://formulae.brew.sh/formula/libomp) and then running: 69 | 70 | 71 | ```bash 72 | $ stack run --extra-include-dirs=/usr/local/opt/libomp/include --extra-lib-dirs=/usr/local/opt/libomp/lib 73 | ``` 74 | 75 | ### Compile debuggee program with GHC-WPC using stack 76 | - Add the following lines to debuggee's `stack.yaml`: 77 | 78 | ```yaml 79 | # use custom ext-stg whole program compiler GHC 80 | compiler: ghc-9.2.7 81 | compiler-check: match-exact 82 | ghc-variant: wpc 83 | setup-info: 84 | ghc: 85 | linux64-custom-wpc-tinfo6: 86 | 9.2.7: 87 | url: "https://github.com/grin-compiler/foundation-pak/releases/download/ghc-9.2.7/ghc-9.2.7-x86_64-unknown-linux.tar.xz" 88 | macosx-custom-wpc: 89 | 9.2.7: 90 | url: "https://github.com/grin-compiler/foundation-pak/releases/download/ghc-9.2.7/ghc-9.2.7-x86_64-apple-darwin.tar.xz" 91 | macosx-aarch64-custom-wpc: 92 | 9.2.7: 93 | url: "https://github.com/grin-compiler/foundation-pak/releases/download/ghc-9.2.7/ghc-9.2.7-aarch64-apple-darwin.tar.xz" 94 | ``` 95 | - Run `stack build` 96 | i.e. build the provided sample hello world: `(cd sample-program-to-debug ; stack build)` 97 | 98 | ### Open debuggee program in VSCode [Extension Development Host] 99 | - Open debugge project folder by using the `Files/Open Folder` menu. 100 | - Select the debug view on the side bar 101 | - Click to `create a launch.json file`, then select `Haskell DAP ESTGi` 102 | - Press F5 or the `Play` button to start debugging 103 | 104 | ## Development 105 | 106 | ### Allow breakpoints everywhere 107 | ![](docs-images/dap-01-vscode-setup-5fps.avif) 108 | 109 | ### Run `dap-estgi-extension` 110 | ![](docs-images/dap-02-run-dap-estgi-extension-5fps.avif) 111 | 112 | ### Start `dap-estgi-server` 113 | ![](docs-images/dap-03-start-dap-estgi-server-5fps.avif) 114 | 115 | ### Compile debuggee program with GHC-WPC using stack 116 | ![](docs-images/dap-04-compile-debuggee-5fps.avif) 117 | 118 | ### Open debuggee program in VSCode [Extension Development Host] 119 | ![](docs-images/dap-05-open-debuggee-in-vscode-5fps.avif) 120 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | dap-estgi-server 3 | 4 | source-repository-package 5 | type: git 6 | location: https://github.com/david-christiansen/final-pretty-printer 7 | tag: 048e8fa2d8b2b7a6f9e4e209db4f67361321eec8 8 | 9 | source-repository-package 10 | type: git 11 | location: https://github.com/luc-tielen/souffle-haskell 12 | tag: 268a11283ca9293b5eacabf7a0b79d9368232478 13 | 14 | source-repository-package 15 | type: git 16 | location: https://github.com/TeofilC/digest 17 | tag: 27ffb6396ef322c5185bc919cae563ac449ba235 18 | 19 | source-repository-package 20 | type: git 21 | location: https://github.com/haskell-debugger/dap 22 | tag: 99543ed 23 | 24 | source-repository-package 25 | type: git 26 | location: https://github.com/haskell-debugger/ghc-whole-program-compiler-project 27 | tag: d058105b0bee1ab2e7c7aefd36bf9e0be6e840b7 28 | subdir: 29 | external-stg 30 | external-stg-syntax 31 | external-stg-interpreter 32 | 33 | package external-stg-interpreter 34 | flags: +external-ext-stg-gc 35 | 36 | package external-stg-compiler 37 | flags: +external-ext-stg-liveness 38 | 39 | package digest 40 | flags: -pkg-config 41 | 42 | allow-newer: type-errors-pretty:base 43 | -------------------------------------------------------------------------------- /dap-estgi-server/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for dap 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /dap-estgi-server/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2023, David M. Johnson 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 5 | 6 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 7 | 2. 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. 8 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 9 | 10 | 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. -------------------------------------------------------------------------------- /dap-estgi-server/dap-estgi-server.cabal: -------------------------------------------------------------------------------- 1 | name: dap-estgi-server 2 | version: 0.1.0.0 3 | description: Debug Adaptor Protocol (DAP) implementation for External STG Interpreter 4 | synopsis: Debug adaptor protocol implementation for ESTGi 5 | bug-reports: https://github.com/dap/issues 6 | license: BSD3 7 | license-file: LICENSE 8 | author: David Johnson 9 | maintainer: djohnson.m@gmail.com 10 | copyright: (c) 2023 David Johnson 11 | category: Debuggers, Language 12 | build-type: Simple 13 | tested-with: GHC==9.2.4 14 | cabal-version: >= 1.10 15 | 16 | extra-source-files: 17 | CHANGELOG.md 18 | 19 | executable dap-estgi 20 | other-modules: 21 | Inspect.Stack 22 | Inspect.Value 23 | Inspect.Value.Atom 24 | Inspect.Value.HeapObject 25 | Inspect.Value.StackContinuation 26 | CustomCommands 27 | GraphProtocol.Commands 28 | GraphProtocol.Server 29 | Graph 30 | Breakpoints 31 | DapBase 32 | SourceCode 33 | SourceLocation 34 | 35 | main-is: 36 | Main.hs 37 | ghc-options: 38 | -threaded 39 | build-depends: 40 | ansi-wl-pprint 41 | , base < 5 42 | , containers 43 | , dap 44 | , bytestring 45 | , external-stg-interpreter 46 | , external-stg-syntax 47 | , external-stg 48 | , filepath 49 | , filemanip 50 | , lifted-base 51 | , network 52 | , unagi-chan 53 | , unordered-containers 54 | , string-conversions 55 | , aeson 56 | , text 57 | , time 58 | , mtl 59 | , yaml 60 | , zip 61 | , bimap 62 | , pretty-simple 63 | , network-simple 64 | hs-source-dirs: 65 | src 66 | default-language: 67 | Haskell2010 68 | -------------------------------------------------------------------------------- /dap-estgi-server/src/Breakpoints.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | module Breakpoints where 5 | 6 | import Text.Read ( readMaybe ) 7 | import Data.Maybe ( fromMaybe, maybeToList ) 8 | import Data.List ( sortOn ) 9 | import Control.Monad 10 | import Data.String.Conversions (cs) 11 | import qualified Data.Text as T 12 | import qualified Data.Bimap as Bimap 13 | import qualified Data.IntSet as IntSet 14 | import qualified Data.Map.Strict as Map 15 | import qualified Stg.Interpreter.Base as Stg 16 | import Stg.Interpreter.Base hiding (lookupEnv, getCurrentThreadState, Breakpoint) 17 | import Stg.Syntax hiding (sourceName, Scope) 18 | import Stg.IRLocation 19 | 20 | import DAP 21 | import DapBase 22 | import SourceCode 23 | 24 | ---------------------------------------------------------------------------- 25 | -- | Clears the currently known breakpoint set 26 | clearBreakpoints :: Adaptor ESTG () 27 | clearBreakpoints = do 28 | updateDebugSession $ \estg -> estg {breakpointMap = mempty} 29 | 30 | ---------------------------------------------------------------------------- 31 | -- | Adds new BreakpointId for a givent StgPoint 32 | addNewBreakpoint :: Stg.Breakpoint -> Adaptor ESTG BreakpointId 33 | addNewBreakpoint breakpoint = do 34 | bkpId <- getFreshBreakpointId 35 | updateDebugSession $ \estg@ESTG{..} -> estg {breakpointMap = Map.insertWith mappend breakpoint (IntSet.singleton bkpId) breakpointMap} 36 | pure bkpId 37 | 38 | commandSetBreakpoints :: Adaptor ESTG () 39 | commandSetBreakpoints = do 40 | SetBreakpointsArguments {..} <- getArguments 41 | maybeSourceRef <- getValidSourceRefFromSource setBreakpointsArgumentsSource 42 | 43 | -- the input SourceRef might be a remain of a previous DAP session, update it with the new valid one 44 | let refUpdatedSource = setBreakpointsArgumentsSource { sourceSourceReference = maybeSourceRef } 45 | 46 | clearBreakpoints 47 | {- 48 | supports placing breakpoint on: 49 | - Haskell 50 | - ExtStg 51 | -} 52 | ESTG {..} <- getDebugSession 53 | case (setBreakpointsArgumentsBreakpoints, maybeSourceRef, maybeSourceRef >>= flip Bimap.lookupR dapSourceRefMap) of 54 | -- HINT: breakpoint on Haskell 55 | (Just sourceBreakpoints, Just sourceRef, Just hsCodeDesc@(Haskell pkg mod)) 56 | | Just extStgSourceRef <- Bimap.lookup (ExtStg pkg mod) dapSourceRefMap 57 | , Just hsSourceFilePath <- Bimap.lookupR hsCodeDesc haskellSrcPathMap 58 | -> do 59 | (_sourceCodeText, _locations, hsSrcLocs) <- getSourceFromFullPak extStgSourceRef 60 | breakpoints <- forM sourceBreakpoints $ \SourceBreakpoint{..} -> do 61 | -- filter all relevant ranges 62 | {- 63 | SP_RhsClosureExpr 64 | -} 65 | let onlySupported = \case 66 | SP_RhsClosureExpr{} -> True 67 | _ -> True -- TODO 68 | let relevantLocations = filter (onlySupported . fst . fst) $ case sourceBreakpointColumn of 69 | Nothing -> 70 | [ (p, spanSize) 71 | | p@(_,SourceNote RealSrcSpan'{..} _) <- hsSrcLocs 72 | , srcSpanFile == hsSourceFilePath 73 | , srcSpanSLine <= sourceBreakpointLine 74 | , srcSpanELine >= sourceBreakpointLine 75 | , let spanSize = (srcSpanELine - srcSpanSLine, srcSpanECol - srcSpanSCol) 76 | ] 77 | Just col -> 78 | [ (p, spanSize) 79 | | p@(_,SourceNote RealSrcSpan'{..} _) <- hsSrcLocs 80 | , srcSpanFile == hsSourceFilePath 81 | , srcSpanSLine <= sourceBreakpointLine 82 | , srcSpanELine >= sourceBreakpointLine 83 | , srcSpanSCol <= col 84 | , srcSpanECol >= col 85 | , let spanSize = (srcSpanELine - srcSpanSLine, srcSpanECol - srcSpanSCol) 86 | ] 87 | debugMessage . cs . unlines $ "relevant haskell locations:" : map show relevantLocations 88 | -- use the first location found 89 | -- HINT: locations are sorted according the span size, small spans are preferred more 90 | case map fst . take 1 $ sortOn snd relevantLocations of 91 | (stgPoint@(SP_RhsClosureExpr _closureName), SourceNote RealSrcSpan'{..} _) : _ -> do 92 | let hitCount = fromMaybe 0 (sourceBreakpointHitCondition >>= readMaybe . T.unpack) :: Int 93 | sendAndWait (CmdAddBreakpoint (BkpStgPoint stgPoint) hitCount) 94 | bkpId <- addNewBreakpoint $ BkpStgPoint stgPoint 95 | pure $ defaultBreakpoint 96 | { breakpointVerified = True 97 | , breakpointSource = Just refUpdatedSource 98 | , breakpointLine = Just srcSpanSLine 99 | , breakpointColumn = Just srcSpanSCol 100 | , breakpointEndLine = Just srcSpanELine 101 | , breakpointEndColumn = Just srcSpanECol 102 | , breakpointId = Just bkpId 103 | } 104 | _ -> 105 | pure $ defaultBreakpoint 106 | { breakpointVerified = False 107 | , breakpointSource = Just refUpdatedSource 108 | , breakpointMessage = Just "no hs code found" 109 | } 110 | sendSetBreakpointsResponse breakpoints 111 | 112 | -- HINT: breakpoint on ExtStg 113 | (Just sourceBreakpoints, Just sourceRef, Just ExtStg{}) -> do 114 | (_sourceCodeText, locations, _hsSrcLocs) <- getSourceFromFullPak sourceRef 115 | breakpoints <- forM sourceBreakpoints $ \SourceBreakpoint{..} -> do 116 | -- filter all relevant ranges 117 | {- 118 | SP_RhsClosureExpr 119 | -} 120 | let onlySupported = \case 121 | SP_RhsClosureExpr{} -> True 122 | _ -> False 123 | let relevantLocations = filter (onlySupported . fst) $ case sourceBreakpointColumn of 124 | Nothing -> 125 | [ p 126 | | p@(_,((startRow, startCol), (endRow, endCol))) <- locations 127 | , startRow <= sourceBreakpointLine 128 | , endRow >= sourceBreakpointLine 129 | ] 130 | Just col -> 131 | [ p 132 | | p@(_,((startRow, startCol), (endRow, endCol))) <- locations 133 | , startRow <= sourceBreakpointLine 134 | , endRow >= sourceBreakpointLine 135 | , startCol <= col 136 | , endCol >= col 137 | ] 138 | debugMessage . cs $ "relevantLocations: " ++ show relevantLocations 139 | -- use the first location found 140 | case sortOn snd relevantLocations of 141 | (stgPoint@(SP_RhsClosureExpr _closureName), ((startRow, startCol), (endRow, endCol))) : _ -> do 142 | let hitCount = fromMaybe 0 (sourceBreakpointHitCondition >>= readMaybe . T.unpack) :: Int 143 | sendAndWait (CmdAddBreakpoint (BkpStgPoint stgPoint) hitCount) 144 | bkpId <- addNewBreakpoint $ BkpStgPoint stgPoint 145 | pure $ defaultBreakpoint 146 | { breakpointVerified = True 147 | , breakpointSource = Just refUpdatedSource 148 | , breakpointLine = Just startRow 149 | , breakpointColumn = Just startCol 150 | , breakpointEndLine = Just endRow 151 | , breakpointEndColumn = Just endCol 152 | , breakpointId = Just bkpId 153 | } 154 | _ -> 155 | pure $ defaultBreakpoint 156 | { breakpointVerified = False 157 | , breakpointSource = Just refUpdatedSource 158 | , breakpointMessage = Just "no code found" 159 | } 160 | sendSetBreakpointsResponse breakpoints 161 | v -> do 162 | sendSetBreakpointsResponse [] 163 | -------------------------------------------------------------------------------- /dap-estgi-server/src/CustomCommands.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | module CustomCommands where 4 | 5 | import GHC.Generics ( Generic ) 6 | 7 | import Data.Text 8 | import Data.Aeson 9 | import DAP.Utils 10 | 11 | data GetSourceLinksArguments 12 | = GetSourceLinksArguments 13 | { getSourceLinksArgumentsPath :: Text 14 | } deriving stock (Show, Eq, Generic) 15 | 16 | instance FromJSON GetSourceLinksArguments where 17 | parseJSON = genericParseJSONWithModifier 18 | 19 | ------------ 20 | 21 | data GetSourceLinksResponse 22 | = GetSourceLinksResponse 23 | { getSourceLinksResponseSourceLinks :: [SourceLink] 24 | } deriving stock (Show, Eq, Generic) 25 | ---------------------------------------------------------------------------- 26 | instance ToJSON GetSourceLinksResponse where 27 | toJSON = genericToJSONWithModifier 28 | ---------------------------------------------------------------------------- 29 | data SourceLink 30 | = SourceLink 31 | { sourceLinkSourceLine :: Int 32 | , sourceLinkSourceColumn :: Int 33 | , sourceLinkSourceEndLine :: Int 34 | , sourceLinkSourceEndColumn :: Int 35 | , sourceLinkTargetLine :: Int 36 | , sourceLinkTargetColumn :: Int 37 | , sourceLinkTargetEndLine :: Int 38 | , sourceLinkTargetEndColumn :: Int 39 | , sourceLinkTargetPath :: Text 40 | } deriving stock (Show, Eq, Generic) 41 | ---------------------------------------------------------------------------- 42 | instance ToJSON SourceLink where 43 | toJSON = genericToJSONWithModifier 44 | 45 | ---------------------------------------------------------------------------- 46 | data ShowVariableGraphStructureArguments 47 | = ShowVariableGraphStructureArguments 48 | { showVariableGraphStructureArgumentsVariablesReference :: Int 49 | } deriving stock (Show, Eq, Generic) 50 | 51 | instance FromJSON ShowVariableGraphStructureArguments where 52 | parseJSON = genericParseJSONWithModifier 53 | 54 | ---------------------------------------------------------------------------- 55 | -------------------------------------------------------------------------------- /dap-estgi-server/src/DapBase.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | module DapBase where 5 | 6 | import Data.Bimap ( Bimap ) 7 | import qualified Data.Bimap as Bimap 8 | import Data.Text ( Text ) 9 | import qualified Data.Text as T 10 | import Data.Map.Strict ( Map ) 11 | import qualified Data.Map.Strict as Map 12 | import Data.IntSet ( IntSet ) 13 | import Data.Set ( Set ) 14 | import Data.IntMap.Strict ( IntMap ) 15 | import qualified Data.IntMap.Strict as IntMap 16 | import qualified Data.ByteString.Lazy.Char8 as BL8 ( pack, unpack, fromStrict, toStrict ) 17 | import qualified Control.Concurrent.MVar as MVar 18 | import Control.Monad.IO.Class (liftIO) 19 | 20 | import Stg.Interpreter.Base hiding (lookupEnv, getCurrentThreadState, Breakpoint) 21 | import qualified Stg.Interpreter.Base as Stg 22 | import Stg.Interpreter.GC.GCRef 23 | import Stg.Syntax hiding (sourceName, Scope) 24 | import DAP hiding (send) 25 | 26 | type PackageName = Text 27 | type QualifiedModuleName = Text 28 | type BreakpointId = Int 29 | type SourceId = Int 30 | type ThreadId = Int 31 | 32 | {- 33 | IDEA: 34 | pure design 35 | use pure and unique resource descriptors to select items from StgState 36 | maintain a bimap between the pure resource descriptors and DAP integer ids 37 | 38 | IMPORTANT: avoid use of counters 39 | BENEFIT: 40 | DAP request order independence 41 | no resource caching is needed 42 | stateless 43 | use of descriptive resource identification instead of integers 44 | 45 | IDEA: 46 | ResourceID ADT - structured key 47 | idMap :: ResourceID -> Int 48 | 49 | DAP request argument -> estg domian idientifiers 50 | request argument's id -> estg domain 51 | 52 | resource ids 53 | threadRef = thread id 54 | frameRef = thread id + frame index 55 | scopeRef = thread id + frame index + argument index 56 | variablesRef = ?? 57 | sourceRef 58 | 59 | HINT: VariablesRef -> [Variable] 60 | 61 | DAP id types: 62 | thread 63 | stack frame 64 | variable 65 | 66 | 67 | Threads args: NONE 68 | StackTrace args: threadId 69 | Scopes args: frameId 70 | Variables args: variablesRef 71 | ... 72 | Variables 73 | -} 74 | 75 | type StackFrameIndex = Int 76 | 77 | data DapFrameIdDescriptor 78 | = FrameId_CurrentThreadTopStackFrame 79 | | FrameId_ThreadStackFrame ThreadId StackFrameIndex 80 | deriving (Show, Eq, Ord) 81 | 82 | data ValueRoot 83 | = ValueRoot_StackFrame DapFrameIdDescriptor 84 | | ValueRoot_Value (RefNamespace, Int) 85 | deriving (Show, Eq, Ord) 86 | 87 | data DapVariablesRefDescriptor 88 | = VariablesRef_StackFrameVariables DapFrameIdDescriptor 89 | | VariablesRef_Value ValueRoot RefNamespace Int 90 | deriving (Show, Eq, Ord) 91 | 92 | data SourceCodeDescriptor 93 | = Haskell PackageName QualifiedModuleName 94 | | GhcCore PackageName QualifiedModuleName 95 | | GhcStg PackageName QualifiedModuleName 96 | | Cmm PackageName QualifiedModuleName 97 | | Asm PackageName QualifiedModuleName 98 | | ExtStg PackageName QualifiedModuleName 99 | | FFICStub PackageName QualifiedModuleName 100 | | FFIHStub PackageName QualifiedModuleName 101 | | ModInfo PackageName QualifiedModuleName 102 | | ForeignC PackageName FilePath 103 | deriving (Show, Read, Eq, Ord) 104 | 105 | ---------------------------------------------------------------------------- 106 | -- | External STG Interpreter application internal state 107 | data ESTG 108 | = ESTG 109 | { debuggerChan :: DebuggerChan 110 | , fullPakPath :: String 111 | , breakpointMap :: Map Stg.Breakpoint IntSet 112 | , sourceCodeSet :: Set SourceCodeDescriptor 113 | , unitIdMap :: Bimap UnitId PackageName 114 | , haskellSrcPathMap :: Bimap Name SourceCodeDescriptor 115 | , dapSourceNameMap :: Bimap Text SourceCodeDescriptor 116 | 117 | -- application specific resource handling 118 | 119 | , dapSourceRefMap :: !(Bimap SourceCodeDescriptor Int) 120 | -- ^ Used to track source reference IDs 121 | -- 122 | , dapFrameIdMap :: !(Bimap DapFrameIdDescriptor Int) 123 | -- ^ Used to track stack frame IDs 124 | -- 125 | , dapVariablesRefMap :: !(Bimap DapVariablesRefDescriptor Int) 126 | -- ^ Used to track variablesReferences 127 | -- 128 | , dapStackFrameCache :: !(Map DapFrameIdDescriptor StackContinuation) 129 | -- ^ Stores the assigned StackContinuation for each DAP FrameId (Int) 130 | -- 131 | , nextFreshBreakpointId :: !Int 132 | -- ^ monotinic counter for unique BreakpointId assignment 133 | -- 134 | } 135 | 136 | -- resource handling 137 | 138 | getsApp f = f <$> getDebugSession 139 | modifyApp = updateDebugSession 140 | 141 | ---------------------------------------------------------------------------- 142 | -- | Synchronous call to Debugger, sends message and waits for response 143 | sendAndWait :: DebugCommand -> Adaptor ESTG DebugOutput 144 | sendAndWait cmd = do 145 | ESTG {..} <- getDebugSession 146 | let DebuggerChan{..} = debuggerChan 147 | liftIO $ do 148 | MVar.putMVar dbgSyncRequest cmd 149 | MVar.takeMVar dbgSyncResponse 150 | 151 | getStgState :: Adaptor ESTG StgState 152 | getStgState = do 153 | sendAndWait (CmdInternal "get-stg-state") >>= \case 154 | DbgOutStgState stgState -> 155 | pure stgState 156 | otherMessage -> do 157 | let errorMsg 158 | = concat 159 | [ "Unexpected Message received from interpreter: " 160 | , show otherMessage 161 | ] 162 | logInfo (BL8.pack errorMsg) 163 | sendError (ErrorMessage (T.pack errorMsg)) Nothing 164 | 165 | ---------------------------------------------------------------------------- 166 | mkThreadLabel :: ThreadState -> String 167 | mkThreadLabel = maybe "" (BL8.unpack . BL8.fromStrict) . tsLabel 168 | 169 | getFrameId :: DapFrameIdDescriptor -> Adaptor ESTG Int 170 | getFrameId key = do 171 | getsApp (Bimap.lookup key . dapFrameIdMap) >>= \case 172 | Just frameId -> pure frameId 173 | Nothing -> do 174 | frameId <- getsApp (succ . Bimap.size . dapFrameIdMap) 175 | modifyApp $ \s -> s {dapFrameIdMap = Bimap.insert key frameId (dapFrameIdMap s)} 176 | pure frameId 177 | 178 | getVariablesRef :: DapVariablesRefDescriptor -> Adaptor ESTG Int 179 | getVariablesRef key = do 180 | getsApp (Bimap.lookup key . dapVariablesRefMap) >>= \case 181 | Just varRef -> pure varRef 182 | Nothing -> do 183 | varRef <- getsApp (succ . Bimap.size . dapVariablesRefMap) 184 | modifyApp $ \s -> s {dapVariablesRefMap = Bimap.insert key varRef (dapVariablesRefMap s)} 185 | pure varRef 186 | 187 | addStackFrameToCache :: DapFrameIdDescriptor -> StackContinuation -> Adaptor ESTG () 188 | addStackFrameToCache frameIdDesc stackCont = do 189 | modifyApp $ \s -> s {dapStackFrameCache = Map.insert frameIdDesc stackCont (dapStackFrameCache s)} 190 | 191 | getStackFrameFromCache :: DapFrameIdDescriptor -> Adaptor ESTG StackContinuation 192 | getStackFrameFromCache frameIdDesc = do 193 | ESTG {..} <- getDebugSession 194 | case Map.lookup frameIdDesc dapStackFrameCache of 195 | Nothing -> sendError (ErrorMessage (T.pack $ "Unknown stack frame: " ++ show frameIdDesc)) Nothing 196 | Just stackCont -> pure stackCont 197 | 198 | -- | Invoked when a StepEvent has occurred 199 | resetObjectLifetimes :: Adaptor ESTG () 200 | resetObjectLifetimes = do 201 | modifyApp $ \s -> s 202 | { dapFrameIdMap = Bimap.empty 203 | , dapVariablesRefMap = Bimap.empty 204 | , dapStackFrameCache = mempty 205 | } 206 | 207 | getFreshBreakpointId :: Adaptor ESTG BreakpointId 208 | getFreshBreakpointId = do 209 | bkpId <- getsApp nextFreshBreakpointId 210 | modifyApp $ \s -> s { nextFreshBreakpointId = nextFreshBreakpointId s + 1 } 211 | pure bkpId 212 | -------------------------------------------------------------------------------- /dap-estgi-server/src/Graph.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | module Graph where 5 | 6 | import System.FilePath ( (-<.>), (), takeDirectory, takeFileName, takeExtension, dropExtension, splitFileName, splitPath, joinPath, splitDirectories) 7 | import Data.String.Conversions (cs) 8 | import Control.Monad 9 | import Control.Monad.IO.Class (liftIO) 10 | import qualified Data.Text as T 11 | import qualified Data.IntMap.Strict as IntMap 12 | import qualified Data.Bimap as Bimap 13 | import qualified Data.Set as Set 14 | 15 | import qualified Data.Map.Strict as StrictMap 16 | import Data.List (intercalate, foldl', sortOn) 17 | import System.IO 18 | 19 | 20 | import Stg.Interpreter.Base hiding (lookupEnv, getCurrentThreadState, Breakpoint) 21 | import Stg.Interpreter.GC.GCRef 22 | import Stg.Interpreter.Debugger.TraverseState 23 | import Stg.IRLocation 24 | 25 | import DAP 26 | import DapBase 27 | import CustomCommands 28 | import GraphProtocol.Server 29 | import GraphProtocol.Commands 30 | import Inspect.Value.Atom 31 | 32 | customCommandShowVariableGraphStructure :: Adaptor ESTG () 33 | customCommandShowVariableGraphStructure = do 34 | ShowVariableGraphStructureArguments {..} <- getArguments 35 | getsApp (Bimap.lookupR showVariableGraphStructureArgumentsVariablesReference . dapVariablesRefMap) >>= \case 36 | Just VariablesRef_StackFrameVariables{} -> do 37 | -- TODO: create graph from the full stack frame 38 | sendSuccesfulEmptyResponse 39 | Just (VariablesRef_Value _valueRoot valueNameSpace addr) -> do 40 | stgState@StgState{..} <- getStgState 41 | valueSummary <- getValueSummary valueNameSpace addr 42 | 43 | -- generate names 44 | ESTG {..} <- getDebugSession 45 | let nodesFname = fullPakPath ++ "-graph-nodes.tsv" 46 | edgesFname = fullPakPath ++ "-graph-edges.tsv" 47 | 48 | liftIO $ exportReachableGraph nodesFname edgesFname stgState $ encodeRef addr valueNameSpace 49 | liftIO $ sendGraphCommand LoadGraph 50 | { loadGraphRequest = "loadGraph" 51 | , loadGraphTitle = cs $ show addr ++ " " ++ valueSummary 52 | , loadGraphNodesFilepath = Just $ cs nodesFname 53 | , loadGraphEdgesFilepath = cs edgesFname 54 | } 55 | sendSuccesfulEmptyResponse 56 | Nothing -> sendError (ErrorMessage (T.pack $ "Unknown variables ref: " ++ show showVariableGraphStructureArgumentsVariablesReference)) Nothing 57 | 58 | customCommandShowCallGraph :: Adaptor ESTG () 59 | customCommandShowCallGraph = do 60 | ESTG {..} <- getDebugSession 61 | let nodesFname = fullPakPath ++ "-graph-nodes.tsv" 62 | edgesFname = fullPakPath ++ "-graph-edges.tsv" 63 | StgState{..} <- getStgState 64 | liftIO $ do 65 | writeCallGraphEdges edgesFname ssCallGraph 66 | writeCallGraphNodes nodesFname ssCallGraph 67 | sendGraphCommand LoadGraph 68 | { loadGraphRequest = "loadGraph" 69 | , loadGraphTitle = cs $ takeFileName fullPakPath ++ " call graph" 70 | , loadGraphNodesFilepath = Just $ cs nodesFname 71 | , loadGraphEdgesFilepath = cs edgesFname 72 | } 73 | sendSuccesfulEmptyResponse 74 | 75 | writeCallGraphEdges :: FilePath -> CallGraph -> IO () 76 | writeCallGraphEdges fname CallGraph{..} = do 77 | let showCallType = \case 78 | SO_CloArg -> "unknown" 79 | SO_Let -> "known" 80 | SO_Scrut -> "unknown" 81 | SO_AltArg -> "unknown" 82 | SO_TopLevel -> "known" 83 | SO_Builtin -> "known" 84 | SO_ClosureResult -> "unknown" 85 | withFile fname WriteMode $ \h -> do 86 | hPutStrLn h $ intercalate "\t" 87 | [ "Source" 88 | , "Target" 89 | , "Label" 90 | , "count" 91 | , "static-origin" 92 | , "call-site-type" 93 | ] 94 | forM_ (sortOn (negate . snd) $ StrictMap.toList cgInterClosureCallGraph) $ \((so, from, to), count) -> do 95 | hPutStrLn h $ intercalate "\t" 96 | [ show from 97 | , show to 98 | , show count 99 | , show count 100 | , show so 101 | , showCallType so 102 | ] 103 | forM_ (sortOn (negate . snd) $ StrictMap.toList cgIntraClosureCallGraph) $ \((from, so, to), count) -> do 104 | hPutStrLn h $ intercalate "\t" 105 | [ show from 106 | , show to 107 | , show count 108 | , show count 109 | , "direct" 110 | , "known" 111 | ] 112 | writeCallGraphNodes :: FilePath -> CallGraph -> IO () 113 | writeCallGraphNodes fname CallGraph{..} = do 114 | withFile fname WriteMode $ \h -> do 115 | hPutStrLn h $ intercalate "\t" 116 | [ "Id" 117 | , "Label" 118 | -- , "package-id" 119 | -- , "module" 120 | , "partition2" 121 | ] 122 | let nodes = Set.fromList . concat $ 123 | [[from, to] | (_so, from, to) <- StrictMap.keys cgInterClosureCallGraph] ++ 124 | [[from, to] | (from, _so, to) <- StrictMap.keys cgIntraClosureCallGraph] 125 | 126 | 127 | forM_ nodes $ \node -> 128 | hPutStrLn h $ intercalate "\t" 129 | [ show node 130 | , getLabelForProgramPoint node 131 | , case node of 132 | PP_StgPoint{} -> "PP_StgPoint" 133 | PP_Global{} -> "PP_Global" 134 | PP_Apply{} -> "PP_Apply" 135 | ] 136 | 137 | getLabelForProgramPoint :: ProgramPoint -> String 138 | getLabelForProgramPoint = \case 139 | PP_Global -> "global scope" 140 | PP_Apply n pp -> "apply " ++ show n ++ " " ++ getLabelForProgramPoint pp 141 | PP_StgPoint p -> getLabelForStgPoint p 142 | 143 | getLabelForStgPoint :: StgPoint -> String 144 | getLabelForStgPoint = \case 145 | SP_CaseScrutineeExpr{..} -> getLabelForStgId spScrutineeResultName 146 | SP_LetExpr{..} -> getLabelForStgPoint spParent 147 | SP_LetNoEscapeExpr{..} -> getLabelForStgPoint spParent 148 | SP_RhsClosureExpr{..} -> getLabelForStgId spRhsBinderName 149 | SP_AltExpr{..} -> "alt " ++ show spAltIndex ++ ": " ++ getLabelForStgId spScrutineeResultName 150 | SP_RhsCon{..} -> getLabelForStgId spRhsBinderName 151 | SP_Binding{..} -> getLabelForStgId spBinderName 152 | SP_Tickish{..} -> getLabelForStgPoint spParent 153 | 154 | getLabelForStgId :: StgId -> String 155 | getLabelForStgId StgId{..} = cs (siUnitId <> "_" <> siModuleName <> "." <> siName) <> maybe "" (\u -> "_" <> show u) siUnique 156 | -------------------------------------------------------------------------------- /dap-estgi-server/src/GraphProtocol/Commands.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | module GraphProtocol.Commands where 4 | 5 | import GHC.Generics ( Generic ) 6 | 7 | import Data.Text 8 | import Data.Aeson 9 | import DAP.Utils 10 | 11 | 12 | data LoadGraph 13 | = LoadGraph 14 | { loadGraphRequest :: Text 15 | , loadGraphTitle :: Text 16 | , loadGraphNodesFilepath :: Maybe Text 17 | , loadGraphEdgesFilepath :: Text 18 | } deriving stock (Show, Eq, Generic) 19 | ---------------------------------------------------------------------------- 20 | instance ToJSON LoadGraph where 21 | toJSON = genericToJSONWithModifier 22 | ---------------------------------------------------------------------------- 23 | 24 | -------------------------------------------------------------------------------- /dap-estgi-server/src/GraphProtocol/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | module GraphProtocol.Server where 4 | 5 | import Control.Monad 6 | import Network.Simple.TCP ( serve, HostPreference(Host) ) 7 | import Network.Socket ( socketToHandle, withSocketsDo, SockAddr ) 8 | import System.IO ( hClose, hSetNewlineMode, Handle, Newline(CRLF) 9 | , NewlineMode(NewlineMode, outputNL, inputNL) 10 | , IOMode(ReadWriteMode) ) 11 | import Data.Aeson ( Value, (.=), ToJSON ) 12 | import qualified Data.Aeson as Aeson 13 | import qualified Data.Aeson.KeyMap as Aeson 14 | 15 | import qualified Data.ByteString.Char8 as BS 16 | 17 | import Data.Text ( Text ) 18 | import qualified Data.Map.Strict as Map 19 | import Data.Map.Strict ( Map ) 20 | 21 | import DAP 22 | import DAP.Utils (encodeBaseProtocolMessage) 23 | import Data.IORef 24 | import System.IO.Unsafe 25 | 26 | import Control.Concurrent.MVar 27 | import Control.Concurrent.Chan.Unagi.Bounded as Unagi 28 | 29 | serverConfig0 = ServerConfig 30 | { host = "0.0.0.0" 31 | , port = 4721 32 | , serverCapabilities = defaultCapabilities 33 | , debugLogging = True 34 | } 35 | 36 | data GraphEvent 37 | = GraphEventShowValue Text 38 | deriving (Show, Eq, Ord) 39 | 40 | data GraphChan 41 | = GraphChan 42 | { graphAsyncEventIn :: InChan GraphEvent 43 | , graphAsyncEventOut :: OutChan GraphEvent 44 | } 45 | deriving Eq 46 | 47 | instance Show GraphChan where 48 | show _ = "GraphChan" 49 | 50 | data GraphServerState 51 | = GraphServerState 52 | { gssHandle :: Handle 53 | , gssGraphChanMap :: Map Text GraphChan 54 | } 55 | 56 | emptyGraphServerState :: GraphServerState 57 | emptyGraphServerState = GraphServerState 58 | { gssHandle = error "missing gssHandle" 59 | , gssGraphChanMap = mempty 60 | } 61 | 62 | {-# NOINLINE graphServerStateIORef #-} 63 | graphServerStateIORef :: IORef GraphServerState 64 | graphServerStateIORef = unsafePerformIO $ newIORef emptyGraphServerState 65 | 66 | registerGraphChan :: Text -> GraphChan -> IO () 67 | registerGraphChan sessionId graphChan = do 68 | modifyIORef' graphServerStateIORef $ \s@GraphServerState{..} -> s {gssGraphChanMap = Map.insert sessionId graphChan gssGraphChanMap} 69 | 70 | sendGraphCommand :: ToJSON a => a -> IO () 71 | sendGraphCommand msg = do 72 | GraphServerState{..} <- readIORef graphServerStateIORef 73 | BS.hPut gssHandle $ encodeBaseProtocolMessage msg 74 | 75 | runGraphServer :: IO () 76 | runGraphServer = withSocketsDo $ do 77 | let ServerConfig{..} = serverConfig0 78 | serverConfig = serverConfig0 79 | when debugLogging $ putStrLn ("Running GRAPH server on " <> show port <> "...") 80 | serve (Host host) (show port) $ \(socket, address) -> do 81 | when debugLogging $ do 82 | putStrLn $ "TCP connection established from " ++ show address 83 | handle <- socketToHandle socket ReadWriteMode 84 | hSetNewlineMode handle NewlineMode { inputNL = CRLF, outputNL = CRLF } 85 | modifyIORef' graphServerStateIORef $ \s -> s {gssHandle = handle} 86 | serviceClient handle -- `catch` exceptionHandler handle address debugLogging 87 | 88 | serviceClient :: Handle -> IO () 89 | serviceClient handle = do 90 | {- 91 | get session id from message 92 | lookup the communication channel based on session id 93 | if there is no match then report and error, or use the first session as a fallback 94 | -} 95 | nextRequest <- readPayload handle :: IO (Either String Value) 96 | print nextRequest 97 | case nextRequest of 98 | Left err -> do 99 | putStrLn $ "error: " ++ err 100 | Right (Aeson.Object json) 101 | | Just "showValue" <- Aeson.lookup "event" json 102 | , Just (Aeson.String nodeId) <- Aeson.lookup "nodeId" json 103 | -> do 104 | GraphServerState{..} <- readIORef graphServerStateIORef 105 | -- TODO: handle sessions correctly, select the right session 106 | forM_ (Map.elems gssGraphChanMap) $ \GraphChan{..} -> do 107 | Unagi.writeChan graphAsyncEventIn $ GraphEventShowValue nodeId 108 | Right json -> do 109 | putStrLn $ "unknown event: " ++ show nextRequest 110 | -- loop: serve the next request 111 | serviceClient handle 112 | 113 | {- 114 | use cases: 115 | debug one program 116 | 1 vscode 117 | 1 gephi 118 | 1 estgi dap session / program 119 | debug multiple programs 120 | -} -------------------------------------------------------------------------------- /dap-estgi-server/src/Inspect/Stack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | module Inspect.Stack where 4 | 5 | import Data.Typeable ( typeOf ) 6 | import Control.Monad 7 | import Data.String.Conversions (cs) 8 | import Data.Text ( Text ) 9 | import qualified Data.Text as T 10 | import qualified Data.Map.Strict as Map 11 | import qualified Data.Bimap as Bimap 12 | import qualified Data.IntMap.Strict as IntMap 13 | 14 | import Stg.Interpreter.Base hiding (lookupEnv, getCurrentThreadState, Breakpoint) 15 | import Stg.Syntax hiding (sourceName, Scope) 16 | import Stg.IRLocation 17 | 18 | import DAP 19 | import DapBase 20 | import Inspect.Value.Atom 21 | import Inspect.Value.StackContinuation 22 | import SourceCode 23 | import SourceLocation 24 | 25 | {- 26 | TODO: 27 | done - refactor stack inspection to: 28 | getVariablesForStackContinuation :: ValueRoot -> StackContinuation -> Adaptor ESTG [Variable] 29 | done - store stack frames in cache/map: (ThreadId, FrameIndex) -> StackContinuation 30 | -} 31 | 32 | ---------------------------------------------------------------------------- 33 | 34 | getVariablesForStackFrame :: DapFrameIdDescriptor -> Adaptor ESTG [Variable] 35 | getVariablesForStackFrame frameIdDesc = do 36 | let valueRoot = ValueRoot_StackFrame frameIdDesc 37 | case frameIdDesc of 38 | FrameId_CurrentThreadTopStackFrame -> do 39 | StgState{..} <- getStgState 40 | forM (Map.toList ssCurrentClosureEnv) $ \(Id (Binder{..}), (_, atom)) -> do 41 | let BinderId u = binderId 42 | displayName = if binderScope == ModulePublic then cs binderName else cs (show u) 43 | getVariableForAtom displayName valueRoot atom 44 | 45 | FrameId_ThreadStackFrame _threadId _stackFrameIndex -> do 46 | stackCont <- getStackFrameFromCache frameIdDesc 47 | getVariablesForStackContinuation valueRoot stackCont 48 | 49 | getScopesForStackContinuation 50 | :: DapFrameIdDescriptor 51 | -> StackContinuation 52 | -- ^ The stack instruction that we're generating Scopes for 53 | -> Adaptor ESTG [Scope] 54 | -- ^ List of Scopes for this StackFrame 55 | getScopesForStackContinuation frameIdDesc stackCont = do 56 | scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc 57 | let scope = defaultScope 58 | { scopeName = "Locals" 59 | , scopePresentationHint = Just ScopePresentationHintLocals 60 | , scopeVariablesReference = scopeVarablesRef 61 | } 62 | scopeWithSourceLoc <- case stackCont of 63 | CaseOf _ closureId _ _ _ _ -> do 64 | (source, line, column, endLine, endColumn) <- getSourceAndPositionForStgPoint (SP_RhsClosureExpr (binderToStgId . unId $ closureId)) 65 | pure scope 66 | { scopeSource = source 67 | , scopeLine = Just line 68 | , scopeColumn = Just column 69 | , scopeEndLine = Just endLine 70 | , scopeEndColumn = Just endColumn 71 | } 72 | _ -> pure scope 73 | pure [scopeWithSourceLoc] 74 | 75 | getScopesForTopStackFrame 76 | :: DapFrameIdDescriptor 77 | -> Id 78 | -> Adaptor ESTG [Scope] 79 | getScopesForTopStackFrame frameIdDesc closureId = do 80 | scopeVarablesRef <- getVariablesRef $ VariablesRef_StackFrameVariables frameIdDesc 81 | (source, line, column, endLine, endColumn) <- getSourceAndPositionForStgPoint (SP_RhsClosureExpr . binderToStgId $ unId closureId) 82 | pure 83 | [ defaultScope 84 | { scopeName = "Locals" 85 | , scopePresentationHint = Just ScopePresentationHintLocals 86 | , scopeVariablesReference = scopeVarablesRef 87 | , scopeSource = source 88 | , scopeLine = Just line 89 | , scopeColumn = Just column 90 | , scopeEndLine = Just endLine 91 | , scopeEndColumn = Just endColumn 92 | } 93 | ] 94 | 95 | commandThreads :: Adaptor ESTG () 96 | commandThreads = do 97 | allThreads <- IntMap.toList . ssThreads <$> getStgState 98 | sendThreadsResponse 99 | [ Thread 100 | { threadId = threadId 101 | , threadName = T.pack ("thread id: " <> show threadId <> " " <> threadLabel) 102 | } 103 | | (threadId, threadState) <- allThreads 104 | , isThreadLive $ tsStatus threadState 105 | , let threadLabel = mkThreadLabel threadState 106 | ] 107 | 108 | commandStackTrace :: Adaptor ESTG () 109 | commandStackTrace = do 110 | {- 111 | TODO: 112 | done - use the thread id from the arguments 113 | done - generate source location for stack frames where possible 114 | done - add the top frame derived from the current closure and env 115 | done - generate frameIds properly, store thread id and frame index for each frameId 116 | REQUIREMENT: 117 | move all resource handling code to the application side, the library should only be a message framework 118 | -} 119 | StackTraceArguments {..} <- getArguments 120 | StgState{..} <- getStgState 121 | case IntMap.lookup stackTraceArgumentsThreadId ssThreads of 122 | Nothing -> do 123 | sendError (ErrorMessage (T.pack $ "Unknown threadId: " ++ show stackTraceArgumentsThreadId)) Nothing 124 | 125 | Just ThreadState{..} -> do 126 | -- create the top stack frame from the current closure, but only for the current thread 127 | -- other (not currently running) threads do have everything on the thread stack 128 | topFrame <- case ssCurrentClosure of 129 | Just currentClosureId 130 | | ssCurrentThreadId == stackTraceArgumentsThreadId 131 | -> do 132 | (source, line, column, endLine, endColumn) <- getSourceAndPositionForStgPoint (SP_RhsClosureExpr . binderToStgId $ unId currentClosureId) 133 | frameId <- getFrameId FrameId_CurrentThreadTopStackFrame 134 | pure [ defaultStackFrame 135 | { stackFrameId = frameId 136 | , stackFrameName = T.pack (show currentClosureId) 137 | , stackFrameSource = source 138 | , stackFrameLine = line 139 | , stackFrameColumn = column 140 | , stackFrameEndLine = Just endLine 141 | , stackFrameEndColumn = Just endColumn 142 | } 143 | ] 144 | _ -> pure [] 145 | 146 | -- create the rest of frames from the Thread's stack frames 147 | stackFrames <- forM (zip [0..] tsStack) $ \(frameIndex, stackCont) -> do 148 | let frameIdDesc = FrameId_ThreadStackFrame stackTraceArgumentsThreadId frameIndex 149 | addStackFrameToCache frameIdDesc stackCont 150 | frameId <- getFrameId frameIdDesc 151 | case stackCont of 152 | CaseOf _ closureId _ scrutResultId _ _ -> do 153 | -- HINT: use the case scrutinee result's unique binder id to lookup source location info 154 | (source, line, column, endLine, endColumn) <- getSourceAndPositionForStgPoint (SP_CaseScrutineeExpr . binderToStgId $ unId scrutResultId) 155 | pure $ defaultStackFrame 156 | { stackFrameId = frameId 157 | , stackFrameName = cs $ "CaseOf " ++ show closureId 158 | , stackFrameSource = source 159 | , stackFrameLine = line 160 | , stackFrameColumn = column 161 | , stackFrameEndLine = Just endLine 162 | , stackFrameEndColumn = Just endColumn 163 | } 164 | 165 | _ -> do 166 | pure $ defaultStackFrame 167 | -- HINT: no source location info 168 | { stackFrameId = frameId 169 | , stackFrameName = T.pack (showStackCont stackCont) 170 | , stackFrameLine = 0 171 | , stackFrameColumn = 0 172 | } 173 | 174 | sendStackTraceResponse $ StackTraceResponse 175 | { stackFrames = topFrame ++ stackFrames 176 | , totalFrames = Just (length topFrame + length stackFrames) 177 | } 178 | 179 | commandScopes :: Adaptor ESTG () 180 | commandScopes = do 181 | ScopesArguments {..} <- getArguments 182 | StgState{..} <- getStgState 183 | ESTG {..} <- getDebugSession 184 | case Bimap.lookupR scopesArgumentsFrameId dapFrameIdMap of 185 | Nothing -> do 186 | sendError (ErrorMessage (T.pack $ "Unknown frameId: " ++ show scopesArgumentsFrameId)) Nothing 187 | 188 | Just frameIdDescriptor@FrameId_CurrentThreadTopStackFrame 189 | | Just currentClosureId <- ssCurrentClosure 190 | -> do 191 | scopes <- getScopesForTopStackFrame frameIdDescriptor currentClosureId 192 | sendScopesResponse (ScopesResponse scopes) 193 | 194 | Just frameIdDescriptor@(FrameId_ThreadStackFrame _threadId _frameIndex) -> do 195 | stackFrame <- getStackFrameFromCache frameIdDescriptor 196 | scopes <- getScopesForStackContinuation frameIdDescriptor stackFrame 197 | sendScopesResponse (ScopesResponse scopes) 198 | 199 | _ -> sendScopesResponse (ScopesResponse []) 200 | -------------------------------------------------------------------------------- /dap-estgi-server/src/Inspect/Value.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | module Inspect.Value where 3 | 4 | import Stg.Interpreter.Base hiding (lookupEnv, getCurrentThreadState, Breakpoint) 5 | import Stg.Interpreter.GC.GCRef 6 | import qualified Data.IntMap as IntMap 7 | 8 | import DAP 9 | import DapBase 10 | import Inspect.Value.HeapObject 11 | 12 | getVariablesForValue :: ValueRoot -> RefNamespace -> Int -> Adaptor ESTG [Variable] 13 | getVariablesForValue valueRoot valueNS idx = do 14 | StgState{..} <- getStgState 15 | case valueNS of 16 | NS_HeapPtr 17 | | Just v <- IntMap.lookup idx ssHeap 18 | -> getVariablesForHeapObject valueRoot v 19 | 20 | _ -> pure [] 21 | 22 | {- 23 | 24 | data RefNamespace 25 | = NS_Array 26 | | NS_ArrayArray 27 | | NS_HeapPtr 28 | | NS_MutableArray 29 | | NS_MutableArrayArray 30 | | NS_MutableByteArray 31 | | NS_MutVar 32 | | NS_TVar 33 | | NS_MVar 34 | | NS_SmallArray 35 | | NS_SmallMutableArray 36 | | NS_StableName 37 | | NS_StablePointer 38 | | NS_WeakPointer 39 | | NS_Thread 40 | -} -------------------------------------------------------------------------------- /dap-estgi-server/src/Inspect/Value/Atom.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | module Inspect.Value.Atom where 4 | 5 | import Data.List 6 | import Data.String.Conversions (cs) 7 | import Data.IntMap.Strict ( IntMap ) 8 | import qualified Data.IntMap.Strict as IntMap 9 | import Data.Text ( Text ) 10 | import qualified Data.Text.Lazy as LazyText 11 | import qualified Text.Pretty.Simple as PP 12 | import Foreign.Ptr 13 | 14 | import Stg.Interpreter.Base hiding (lookupEnv, getCurrentThreadState, Breakpoint) 15 | import Stg.Interpreter.GC.GCRef 16 | import Stg.Syntax hiding (sourceName, Scope) 17 | 18 | import DAP 19 | import DapBase 20 | 21 | showLitNumType :: LitNumType -> String 22 | showLitNumType = \case 23 | LitNumInt8 -> "Int8" 24 | LitNumInt16 -> "Int16" 25 | LitNumInt32 -> "Int32" 26 | LitNumInt64 -> "Int64" 27 | LitNumWord -> "Word" 28 | LitNumWord8 -> "Word8" 29 | LitNumWord16 -> "Word16" 30 | LitNumWord32 -> "Word32" 31 | LitNumWord64 -> "Word64" 32 | 33 | showElemRep :: PrimElemRep -> String 34 | showElemRep = \case 35 | Int8ElemRep -> "Int8Rep" 36 | Int16ElemRep -> "Int16Rep" 37 | Int32ElemRep -> "Int32Rep" 38 | Int64ElemRep -> "Int64Rep" 39 | Word8ElemRep -> "Word8Rep" 40 | Word16ElemRep -> "Word16Rep" 41 | Word32ElemRep -> "Word32Rep" 42 | Word64ElemRep -> "Word64Rep" 43 | FloatElemRep -> "FloatRep" 44 | DoubleElemRep -> "DoubleRep" 45 | 46 | showRubbishType :: Type -> String 47 | showRubbishType (SingleValue primRep) = showPrimRep primRep 48 | 49 | showRubbishType (UnboxedTuple primReps) = 50 | concat 51 | [ "(# " 52 | , intercalate "," (showPrimRep <$> primReps) 53 | , " #)" 54 | ] 55 | showRubbishType PolymorphicRep = show PolymorphicRep 56 | 57 | showPrimRep :: PrimRep -> String 58 | showPrimRep (VecRep n primElemRep) = 59 | concat 60 | [ "<" 61 | , intercalate "," (replicate n (showElemRep primElemRep)) 62 | , ">" 63 | ] 64 | showPrimRep rep = show rep 65 | 66 | getAtomTypeAndValueM 67 | :: ValueRoot 68 | -> Atom 69 | -> Adaptor ESTG (String, String, Int) 70 | getAtomTypeAndValueM valueRoot atom = do 71 | ss@StgState{..} <- getStgState 72 | case atom of 73 | HeapPtr addr 74 | | Just o <- IntMap.lookup addr ssHeap 75 | -> do 76 | varsRef <- getVariablesRef $ VariablesRef_Value valueRoot NS_HeapPtr addr 77 | pure ("HeapPtr", show addr ++ " " ++ getHeapObjectSummary o ++ "\n --- \n" ++ LazyText.unpack (PP.pShowNoColor o), varsRef) 78 | _ 79 | | (t, v) <- getAtomTypeAndValue ss atom 80 | -> pure (t, v, 0) 81 | 82 | getAtomTypeAndValue 83 | :: StgState 84 | -> Atom 85 | -> (String, String) 86 | getAtomTypeAndValue StgState{..} atom = case atom of 87 | HeapPtr addr 88 | | Just o <- IntMap.lookup addr ssHeap 89 | -> ("HeapPtr", show addr ++ "\n --- \n" ++ LazyText.unpack (PP.pShowNoColor o)) 90 | Literal (LitChar char) -> ("Char", show char) 91 | Literal (LitString bytes) -> ("String", cs $ show bytes) 92 | Literal LitNullAddr -> ("Address", "0x00000000") 93 | Literal (LitFloat float) -> ("Float", show float) 94 | Literal (LitDouble double) -> ("Double", show double) 95 | Literal (LitLabel labelName FunctionLabel{}) -> ("Foreign Function", cs labelName) 96 | Literal (LitLabel labelName DataLabel) -> ("Foreign Data", cs labelName) 97 | Literal (LitNumber num value) -> (showLitNumType num, show value) 98 | Literal (LitRubbish rubbishType) -> ("Rubbish", showRubbishType rubbishType) 99 | Void -> ("Void", "()") 100 | PtrAtom _ x -> ("Ptr", show x) 101 | IntAtom x -> ("Int", show x) 102 | WordAtom x -> ("Word", show x) 103 | FloatAtom x -> ("Float", show x) 104 | DoubleAtom x -> ("Double", show x) 105 | MVar x -> ("MVar", show atom) 106 | MutVar x -> ("MutVar", show atom) 107 | TVar x -> ("TVar", show atom) 108 | Array idx -> ("Array", show atom) 109 | MutableArray idx -> ("MutableArray", show atom) 110 | SmallArray idx -> ("SmallArray", show atom) 111 | SmallMutableArray idx -> ("SmallMutableArray", show atom) 112 | ArrayArray idx -> ("ArrayArray", show atom) 113 | MutableArrayArray idx -> ("MutableArrayArray", show atom) 114 | ByteArray idx -> ("ByteArray", show atom) 115 | MutableByteArray idx -> ("MutableByteArray", show atom) 116 | WeakPointer x -> ("WeakPoint", show atom) 117 | StableName x -> ("StableName", show atom) 118 | ThreadId x -> ("ThreadId", show atom) 119 | LiftedUndefined -> ("LiftedUndefined","undefined") 120 | 121 | getHeapObjectSummary :: HeapObject -> String 122 | getHeapObjectSummary = \case 123 | Con{..} -> "Con: " ++ show hoCon 124 | Closure{..} -> if hoCloMissing == 0 125 | then "Thunk: " ++ show hoName 126 | else "Closure: " ++ show hoName 127 | BlackHole{} -> "BlackHole" 128 | ApStack{} -> "ApStack" 129 | RaiseException{} -> "RaiseException" 130 | 131 | getVariableForAtom :: Text -> ValueRoot -> Atom -> Adaptor ESTG Variable 132 | getVariableForAtom name valueRoot atom = do 133 | (variableType, variableValue, varsRef) <- getAtomTypeAndValueM valueRoot atom 134 | pure defaultVariable 135 | { variableName = name 136 | , variableValue = cs variableValue 137 | , variableType = Just (cs variableType) 138 | , variableVariablesReference = varsRef 139 | } 140 | 141 | valueToAtom :: RefNamespace -> Int -> Adaptor ESTG Atom 142 | valueToAtom ns i = do 143 | StgState{..} <- getStgState 144 | pure $ case ns of 145 | NS_HeapPtr -> HeapPtr i 146 | NS_StablePointer -> PtrAtom (StablePtr i) (intPtrToPtr $ IntPtr i) 147 | NS_MVar -> MVar i 148 | NS_MutVar -> MutVar i 149 | NS_TVar -> TVar i 150 | NS_Array -> Array $ ArrIdx i 151 | NS_MutableArray -> MutableArray $ MutArrIdx i 152 | NS_SmallArray -> SmallArray $ SmallArrIdx i 153 | NS_SmallMutableArray -> SmallMutableArray $ SmallMutArrIdx i 154 | NS_ArrayArray -> ArrayArray $ ArrayArrIdx i 155 | NS_MutableArrayArray -> MutableArrayArray $ ArrayMutArrIdx i 156 | NS_MutableByteArray 157 | | Just ByteArrayDescriptor{..} <- IntMap.lookup i ssMutableByteArrays 158 | -> MutableByteArray $ ByteArrayIdx 159 | { baId = i 160 | , baPinned = baaPinned 161 | , baAlignment = baaAlignment 162 | } 163 | NS_WeakPointer -> WeakPointer i 164 | NS_StableName -> StableName i 165 | NS_Thread -> ThreadId i 166 | 167 | getValueSummary :: RefNamespace -> Int -> Adaptor ESTG String 168 | getValueSummary ns i = do 169 | StgState{..} <- getStgState 170 | pure $ case ns of 171 | NS_HeapPtr 172 | | Just o <- IntMap.lookup i ssHeap 173 | -> "HeapPtr " ++ getHeapObjectSummary o 174 | _ -> show (ns, i) 175 | -------------------------------------------------------------------------------- /dap-estgi-server/src/Inspect/Value/HeapObject.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | module Inspect.Value.HeapObject where 5 | 6 | import Control.Monad 7 | 8 | import qualified Data.Map.Strict as Map 9 | import Data.String.Conversions (cs) 10 | 11 | import Stg.Interpreter.Base hiding (lookupEnv, getCurrentThreadState, Breakpoint) 12 | import Stg.Syntax hiding (sourceName, Scope) 13 | import Stg.IRLocation 14 | 15 | import DAP 16 | import DapBase 17 | import Inspect.Value.Atom 18 | import SourceLocation 19 | 20 | getVariablesForHeapObject :: ValueRoot -> HeapObject -> Adaptor ESTG [Variable] 21 | getVariablesForHeapObject valueRoot = \case 22 | Con{..} -> forM (zip [0..] hoConArgs) $ \(idx, atom) -> do 23 | let name = cs $ "arg" ++ show idx 24 | getVariableForAtom name valueRoot atom 25 | 26 | Closure{..} -> do 27 | srcLocJson <- getStgSourceLocJSONText . SP_Binding . binderToStgId $ unId hoName 28 | let bodyVar = defaultVariable 29 | { variableName = "code" 30 | , variableValue = cs $ show hoName 31 | , variableEvaluateName = srcLocJson 32 | } 33 | {- 34 | TODO: 35 | show env in subnode 36 | show args in subnode 37 | show missing-args-count / is thunk? 38 | -} 39 | argVarList <- forM (zip [0..] hoCloArgs) $ \(idx, atom) -> do 40 | let name = cs $ "arg" ++ show idx 41 | getVariableForAtom name valueRoot atom 42 | 43 | envVarList <- forM (Map.toList hoEnv) $ \(Id (Binder{..}), (_, atom)) -> do 44 | let BinderId u = binderId 45 | displayName = if binderScope == ModulePublic then cs binderName else cs (show u) 46 | getVariableForAtom displayName valueRoot atom 47 | 48 | pure $ bodyVar : argVarList ++ envVarList 49 | 50 | BlackHole{..} -> do 51 | bodyVar <- case hoBHOriginalThunk of 52 | Closure{..} -> do 53 | srcLocJson <- getStgSourceLocJSONText . SP_Binding . binderToStgId $ unId hoName 54 | pure . pure $ defaultVariable 55 | { variableName = "code" 56 | , variableValue = cs $ show hoName 57 | , variableEvaluateName = cs <$> srcLocJson 58 | } 59 | _ -> pure [] 60 | onwerVar <- getVariableForAtom "owner thread id" valueRoot $ ThreadId hoBHOwnerThreadId 61 | queueVarList <- forM hoBHWaitQueue $ \tid -> getVariableForAtom "waiting thread id" valueRoot $ ThreadId tid 62 | pure $ bodyVar ++ onwerVar : queueVarList 63 | 64 | ApStack{..} -> do 65 | resultVarList <- forM hoResult $ \atom -> do 66 | getVariableForAtom "latest result" valueRoot atom 67 | -- TODO: hoStack 68 | pure resultVarList 69 | 70 | RaiseException ex -> do 71 | sequence [getVariableForAtom "exception" valueRoot ex] 72 | -------------------------------------------------------------------------------- /dap-estgi-server/src/Inspect/Value/StackContinuation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | module Inspect.Value.StackContinuation where 5 | 6 | import Control.Monad 7 | 8 | import qualified Data.Map.Strict as Map 9 | import Data.String.Conversions (cs) 10 | import Data.Text ( Text ) 11 | import qualified Data.Text as T 12 | 13 | import Stg.Interpreter.Base hiding (lookupEnv, getCurrentThreadState, Breakpoint) 14 | import Stg.Syntax hiding (sourceName, Scope) 15 | import Stg.IRLocation 16 | 17 | import DAP 18 | import DapBase 19 | import Inspect.Value.Atom 20 | import SourceLocation 21 | 22 | showScheduleReason :: ScheduleReason -> Text 23 | showScheduleReason = \case 24 | SR_ThreadFinished -> "Thread Finished" 25 | SR_ThreadFinishedFFICallback -> "Thread Finished FFI Callback" 26 | SR_ThreadBlocked -> "Thread Blocked" 27 | SR_ThreadYield -> "Thread Yield" 28 | SR_ThreadFinishedMain -> "Thread Finished Main" 29 | 30 | getVariablesForStackContinuation :: ValueRoot -> StackContinuation -> Adaptor ESTG [Variable] 31 | getVariablesForStackContinuation valueRoot = \case 32 | CaseOf _ _ env _ _ _ -> do 33 | forM (Map.toList env) $ \(Id (Binder{..}), (_, atom)) -> do 34 | -- DMJ: for now everything is local. 35 | -- Inspect StaticOrigin to put things top-level, or as arguments, where applicable 36 | let BinderId u = binderId 37 | displayName = if binderScope == ModulePublic then cs binderName else cs (show u) 38 | getVariableForAtom displayName valueRoot atom 39 | 40 | Update addr -> do 41 | sequence [getVariableForAtom "Thunk Address" valueRoot $ HeapPtr addr] 42 | 43 | Apply atoms -> do 44 | forM atoms $ \atom -> do 45 | getVariableForAtom "Closure argument" valueRoot atom 46 | 47 | Catch atom blockAsync interruptible -> do 48 | sequence 49 | [ getVariableForAtom "Exception Handler" valueRoot atom 50 | , pure defaultVariable 51 | { variableName = "BlockAsyncExceptions" 52 | , variableValue = T.pack (show blockAsync) 53 | , variableType = Just "Bool" 54 | } 55 | , pure defaultVariable 56 | { variableName = "Interruptible" 57 | , variableValue = T.pack (show interruptible) 58 | , variableType = Just "Bool" 59 | } 60 | ] 61 | 62 | RestoreExMask _ blockAsync interruptible -> do 63 | pure 64 | [ defaultVariable 65 | { variableName = "BlockAsyncExceptions" 66 | , variableValue = T.pack (show blockAsync) 67 | , variableType = Just "Bool" 68 | } 69 | , defaultVariable 70 | { variableName = "Interruptible" 71 | , variableValue = T.pack (show interruptible) 72 | , variableType = Just "Bool" 73 | } 74 | ] 75 | 76 | RunScheduler reason -> do 77 | pure 78 | [ defaultVariable 79 | { variableName = "Schedule Reason" 80 | , variableValue = showScheduleReason reason 81 | } 82 | ] 83 | 84 | Atomically atom -> do 85 | sequence [getVariableForAtom "STM action" valueRoot atom] 86 | 87 | CatchRetry primaryAction alternativeAction isRunningAlternative _tlog -> do 88 | sequence 89 | [ getVariableForAtom "First STM action" valueRoot primaryAction 90 | , getVariableForAtom "Second STM action" valueRoot alternativeAction 91 | , pure defaultVariable 92 | { variableName = "Is running alternative STM action" 93 | , variableValue = T.pack (show isRunningAlternative) 94 | , variableType = Just "Bool" 95 | } 96 | -- todo add tlog 97 | ] 98 | 99 | CatchSTM action handler -> do 100 | sequence 101 | [ getVariableForAtom "STM action" valueRoot action 102 | , getVariableForAtom "Exception Handler" valueRoot handler 103 | ] 104 | 105 | DataToTagOp -> do 106 | pure [] 107 | 108 | RaiseOp atom -> do 109 | sequence [getVariableForAtom "Exception" valueRoot atom] 110 | 111 | KeepAlive atom -> do 112 | sequence [getVariableForAtom "Managed Object" valueRoot atom] 113 | 114 | DebugFrame (RestoreProgramPoint maybeId _) -> do 115 | pure 116 | [ defaultVariable 117 | { variableName = "DebugFrame" 118 | , variableValue = cs (show maybeId) 119 | , variableType = Just "RestoreProgramPoint" 120 | } 121 | ] 122 | -------------------------------------------------------------------------------- /dap-estgi-server/src/Main.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Main 4 | -- Copyright : (C) 2023 David M. Johnson 5 | -- License : BSD3-style (see the file LICENSE) 6 | -- Maintainer : David M. Johnson 7 | -- Stability : experimental 8 | -- Portability : non-portable 9 | -- | 10 | ---------------------------------------------------------------------------- 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE DerivingStrategies #-} 13 | {-# LANGUAGE OverloadedStrings #-} 14 | {-# LANGUAGE FlexibleContexts #-} 15 | {-# LANGUAGE TypeApplications #-} 16 | {-# LANGUAGE RecordWildCards #-} 17 | {-# LANGUAGE DeriveAnyClass #-} 18 | {-# LANGUAGE DeriveGeneric #-} 19 | {-# LANGUAGE ViewPatterns #-} 20 | {-# LANGUAGE LambdaCase #-} 21 | {-# LANGUAGE TupleSections #-} 22 | ---------------------------------------------------------------------------- 23 | module Main (main) where 24 | ---------------------------------------------------------------------------- 25 | import Data.List 26 | import Data.String.Conversions (cs) 27 | import Text.PrettyPrint.ANSI.Leijen (pretty, plain) 28 | import Codec.Archive.Zip (withArchive, unEntrySelector, getEntries) 29 | import Data.IntSet ( IntSet ) 30 | import qualified Data.IntSet as IntSet 31 | import Data.Set ( Set ) 32 | import qualified Data.Set as Set 33 | import Control.Arrow 34 | import Data.IORef 35 | import Control.Exception hiding (catch) 36 | import Control.Monad.IO.Class (liftIO) 37 | import Control.Exception.Lifted (catch) 38 | import Control.Monad.State.Strict ( gets ) 39 | import Control.Monad 40 | import Control.Monad.State.Strict ( gets ) 41 | import Data.Aeson ( Value(Null), FromJSON ) 42 | import qualified Data.Aeson as Aeson 43 | import Data.IntMap.Strict ( IntMap ) 44 | import qualified Data.IntMap.Strict as IntMap 45 | import Data.Bimap ( Bimap ) 46 | import qualified Data.Bimap as Bimap 47 | import qualified Data.Map.Strict as M 48 | import Data.Map.Strict ( Map ) 49 | import qualified Data.Text.Encoding as T 50 | import Data.Text ( Text ) 51 | import qualified Data.Text as T 52 | import qualified Data.Text.Lazy as LazyText 53 | import Data.Typeable ( typeOf ) 54 | import Data.Maybe ( fromMaybe, maybeToList ) 55 | import Data.List ( sortOn ) 56 | import GHC.Generics ( Generic ) 57 | import System.Environment ( lookupEnv ) 58 | import System.FilePath ( (-<.>), (), takeDirectory, takeFileName, takeExtension, dropExtension, splitFileName, splitPath, joinPath, splitDirectories) 59 | import Text.Read ( readMaybe ) 60 | import qualified Data.ByteString.Lazy.Char8 as BL8 ( pack, unpack, fromStrict, toStrict ) 61 | import qualified Control.Concurrent.Chan.Unagi.Bounded as Unagi 62 | import Control.Concurrent.MVar ( MVar ) 63 | import qualified Control.Concurrent.MVar as MVar 64 | import Control.Concurrent ( forkIO ) 65 | import qualified System.FilePath.Find as Glob 66 | ---------------------------------------------------------------------------- 67 | import Stg.Syntax hiding (sourceName, Scope) 68 | import Stg.IRLocation 69 | import Stg.Tickish ( collectTickish ) 70 | import Stg.Pretty 71 | import Stg.Interpreter 72 | import Stg.Interpreter.Debug 73 | import Stg.Interpreter.Base hiding (lookupEnv, getCurrentThreadState, Breakpoint) 74 | import qualified Stg.Interpreter.Base as Stg 75 | import Stg.Interpreter.Debugger 76 | import Stg.Interpreter.Debugger.UI 77 | import Stg.Interpreter.Debugger.TraverseState 78 | import Stg.Interpreter.GC.GCRef 79 | import Stg.IO 80 | import Stg.Program 81 | import Stg.Fullpak 82 | import Data.Yaml hiding (Array) 83 | import qualified Text.Pretty.Simple as PP 84 | ---------------------------------------------------------------------------- 85 | import DAP hiding (send) 86 | ---------------------------------------------------------------------------- 87 | import DapBase 88 | import CustomCommands 89 | import GraphProtocol.Commands 90 | import GraphProtocol.Server 91 | import SourceCode 92 | import SourceLocation 93 | import Breakpoints 94 | import Inspect.Value.Atom 95 | import Inspect.Value 96 | import Inspect.Stack 97 | import Graph 98 | ---------------------------------------------------------------------------- 99 | -- | DAP entry point 100 | -- Extracts configuration information from the environment 101 | -- Opens a listen socket on a port (defaulting to '4711') 102 | -- Converts the 'Socket' to a 'Handle' for convenience 103 | main :: IO () 104 | main = do 105 | config <- getConfig 106 | forkIO runGraphServer 107 | finally (runDAPServer config talk) $ do 108 | putStrLn "dap finished, bye!" 109 | 110 | ---------------------------------------------------------------------------- 111 | -- | Fetch config from environment, fallback to sane defaults 112 | getConfig :: IO ServerConfig 113 | getConfig = do 114 | let 115 | hostDefault = "0.0.0.0" 116 | portDefault = 4711 117 | capabilities = defaultCapabilities 118 | { supportsConfigurationDoneRequest = True 119 | , supportsHitConditionalBreakpoints = True 120 | , supportsEvaluateForHovers = False 121 | , supportsModulesRequest = True 122 | , additionalModuleColumns = [ defaultColumnDescriptor 123 | { columnDescriptorAttributeName = "Extra" 124 | , columnDescriptorLabel = "Label" 125 | } 126 | ] 127 | , supportsValueFormattingOptions = True 128 | , supportTerminateDebuggee = True 129 | , supportsLoadedSourcesRequest = True 130 | } 131 | ServerConfig 132 | <$> do fromMaybe hostDefault <$> lookupEnv "DAP_HOST" 133 | <*> do fromMaybe portDefault . (readMaybe =<<) <$> do lookupEnv "DAP_PORT" 134 | <*> pure capabilities 135 | <*> pure True 136 | 137 | 138 | findProgram :: String -> IO [FilePath] 139 | findProgram globPattern = do 140 | let isPattern = any (`elem` ("[*?" :: String)) 141 | startDir = joinPath . takeWhile (not . isPattern) . splitPath $ takeDirectory globPattern 142 | Glob.find Glob.always (Glob.filePath Glob.~~? globPattern) startDir 143 | 144 | ---------------------------------------------------------------------------- 145 | -- | VSCode arguments are custom for attach 146 | -- > "arguments": { 147 | -- > "__configurationTarget": 6, 148 | -- > "__sessionId": "6c0ba6f8-e478-4698-821e-356fc4a72c3d", 149 | -- > "name": "thing", 150 | -- > "program": "/home/dmjio/Desktop/stg-dap/test.ghc_stgapp", 151 | -- > "request": "attach", 152 | -- > "type": "dap-estgi-extension" 153 | -- > } 154 | -- 155 | data AttachArgs 156 | = AttachArgs 157 | { __sessionId :: Text 158 | -- ^ SessionID from VSCode 159 | , program :: String 160 | -- ^ Path or glob pattern to .ghc_stgapp file 161 | } deriving stock (Show, Eq, Generic) 162 | deriving anyclass FromJSON 163 | 164 | ---------------------------------------------------------------------------- 165 | -- | Intialize ESTG interpreter 166 | ---------------------------------------------------------------------------- 167 | initESTG :: AttachArgs -> Adaptor ESTG () 168 | initESTG AttachArgs {..} = do 169 | ghcstgappPath <- (liftIO $ findProgram program) >>= \case 170 | [fname] -> pure fname 171 | [] -> sendError (ErrorMessage (T.pack $ unlines ["No .ghc_stgapp program found at:", program])) Nothing 172 | names -> sendError (ErrorMessage (T.pack $ unlines $ ["Ambiguous program path:", program, "Use more specific path pattern to fix the issue.", "Multiple matches:"] ++ names)) Nothing 173 | let fullpakPath = ghcstgappPath -<.> ".fullpak" 174 | liftIO $ mkFullpak ghcstgappPath False False fullpakPath 175 | (sourceCodeList, unitIdMap, haskellSrcPathMap) <- liftIO $ getSourceCodeListFromFullPak fullpakPath 176 | (dbgAsyncI, dbgAsyncO) <- liftIO (Unagi.newChan 100) 177 | dbgRequestMVar <- liftIO MVar.newEmptyMVar 178 | dbgResponseMVar <- liftIO MVar.newEmptyMVar 179 | let dbgChan = DebuggerChan 180 | { dbgSyncRequest = dbgRequestMVar 181 | , dbgSyncResponse = dbgResponseMVar 182 | , dbgAsyncEventIn = dbgAsyncI 183 | , dbgAsyncEventOut = dbgAsyncO 184 | } 185 | (graphAsyncI, graphAsyncO) <- liftIO (Unagi.newChan 100) 186 | let graphChan = GraphChan 187 | { graphAsyncEventIn = graphAsyncI 188 | , graphAsyncEventOut = graphAsyncO 189 | } 190 | estg = ESTG 191 | { debuggerChan = dbgChan 192 | , fullPakPath = fullpakPath 193 | , breakpointMap = mempty 194 | , sourceCodeSet = Set.fromList sourceCodeList 195 | , unitIdMap = unitIdMap 196 | , haskellSrcPathMap = haskellSrcPathMap 197 | , dapSourceNameMap = Bimap.fromList [(cs $ getSourceName d, d) | d <- sourceCodeList] 198 | , dapSourceRefMap = Bimap.fromList $ zip sourceCodeList [1..] 199 | , dapFrameIdMap = Bimap.empty 200 | , dapVariablesRefMap = Bimap.empty 201 | , dapStackFrameCache = mempty 202 | , nextFreshBreakpointId = 1 203 | } 204 | flip catch handleDebuggerExceptions $ do 205 | registerNewDebugSession __sessionId estg 206 | [ \_withAdaptor -> loadAndRunProgram True True fullpakPath [] dbgChan DbgStepByStep False defaultDebugSettings 207 | , handleDebugEvents dbgChan 208 | , handleGraphEvents graphChan 209 | ] 210 | liftIO $ registerGraphChan __sessionId graphChan 211 | 212 | ---------------------------------------------------------------------------- 213 | -- | Graph Event Handler 214 | handleGraphEvents :: GraphChan -> (Adaptor ESTG () -> IO ()) -> IO () 215 | handleGraphEvents GraphChan{..} withAdaptor = forever $ do 216 | graphEvent <- liftIO (Unagi.readChan graphAsyncEventOut) 217 | withAdaptor . flip catch handleDebuggerExceptions $ do 218 | let sendEvent ev = sendSuccesfulEvent ev . setBody 219 | case graphEvent of 220 | GraphEventShowValue nodeId 221 | | Just programPoint <- readMaybe $ cs nodeId 222 | -> do 223 | let getStgPointFromProgramPoint = \case 224 | PP_Global -> Nothing 225 | PP_Apply _ pp -> getStgPointFromProgramPoint pp 226 | PP_StgPoint p -> Just p 227 | case getStgPointFromProgramPoint programPoint of 228 | Nothing -> pure () 229 | Just stgPoint -> do 230 | srcLocJson <- getStgSourceLocJSON stgPoint 231 | sendEvent (EventTypeCustom "showCode") srcLocJson 232 | 233 | GraphEventShowValue nodeId 234 | | Just root@(ns, idx) <- readMaybe $ cs nodeId 235 | -> do 236 | atom <- valueToAtom ns idx 237 | var <- getVariableForAtom "" (ValueRoot_Value root) atom 238 | sendEvent (EventTypeCustom "showValue") $ object 239 | [ "variable" .= var 240 | ] 241 | 242 | GraphEventShowValue nodeId -> do 243 | logError $ BL8.pack ("invalid node id format: " <> cs nodeId) 244 | 245 | ---------------------------------------------------------------------------- 246 | -- | Debug Event Handler 247 | handleDebugEvents :: DebuggerChan -> (Adaptor ESTG () -> IO ()) -> IO () 248 | handleDebugEvents DebuggerChan{..} withAdaptor = forever $ do 249 | dbgEvent <- liftIO (Unagi.readChan dbgAsyncEventOut) 250 | withAdaptor . flip catch handleDebuggerExceptions $ do 251 | ESTG {..} <- getDebugSession 252 | let sendEvent ev = sendSuccesfulEvent ev . setBody 253 | case dbgEvent of 254 | DbgEventStopped -> do 255 | resetObjectLifetimes 256 | StgState{..} <- getStgState 257 | sendEvent EventTypeStopped $ object 258 | [ "reason" .= String "step" 259 | , "allThreadsStopped" .= True 260 | , "threadId" .= Number (fromIntegral ssCurrentThreadId) 261 | ] 262 | 263 | DbgEventHitBreakpoint bkpName -> do 264 | resetObjectLifetimes 265 | StgState{..} <- getStgState 266 | sendEvent EventTypeStopped . object $ 267 | [ "reason" .= String "breakpoint" 268 | , "allThreadsStopped" .= True 269 | , "threadId" .= Number (fromIntegral ssCurrentThreadId) 270 | ] ++ 271 | [ "hitBreakpointIds" .= idSet 272 | | Just idSet <- pure $ M.lookup bkpName breakpointMap 273 | ] 274 | 275 | ---------------------------------------------------------------------------- 276 | -- | Exception Handler 277 | handleDebuggerExceptions :: SomeException -> Adaptor ESTG () 278 | handleDebuggerExceptions e | Just ThreadKilled <- fromException e = do 279 | sendTerminatedEvent (TerminatedEvent False) 280 | sendExitedEvent (ExitedEvent 0) 281 | handleDebuggerExceptions e = do 282 | logError $ BL8.pack ("Caught: " <> show e) 283 | sendTerminatedEvent (TerminatedEvent False) 284 | sendExitedEvent (ExitedEvent 1) 285 | 286 | ---------------------------------------------------------------------------- 287 | -- | Main function where requests are received and Events + Responses are returned. 288 | -- The core logic of communicating between the client <-> adaptor <-> debugger 289 | -- is implemented in this function. 290 | ---------------------------------------------------------------------------- 291 | talk :: Command -> Adaptor ESTG () 292 | ---------------------------------------------------------------------------- 293 | -- | Register SessionId and initialize program in the 'AppStore' 294 | talk CommandAttach = do 295 | initESTG =<< getArguments 296 | sendAttachResponse 297 | where 298 | emitEvent :: DebugOutput -> Adaptor ESTG () 299 | emitEvent cmd = logInfo $ BL8.pack (show cmd) 300 | ---------------------------------------------------------------------------- 301 | talk (CustomCommand "garbageCollect") = do 302 | logInfo "Running garbage collection..." 303 | sendAndWait (CmdInternal "gc") 304 | sendSuccesfulEmptyResponse 305 | ---------------------------------------------------------------------------- 306 | talk CommandContinue = do 307 | ESTG {..} <- getDebugSession 308 | sendAndWait CmdContinue 309 | sendContinueResponse (ContinueResponse True) 310 | ---------------------------------------------------------------------------- 311 | talk CommandConfigurationDone = do 312 | sendConfigurationDoneResponse 313 | ---------------------------------------------------------------------------- 314 | talk CommandDisconnect = do 315 | destroyDebugSession 316 | sendExitedEvent (ExitedEvent 0) 317 | sendDisconnectResponse 318 | ---------------------------------------------------------------------------- 319 | talk CommandInitialize = do 320 | sendInitializeResponse 321 | sendInitializedEvent 322 | ---------------------------------------------------------------------------- 323 | 324 | talk CommandLoadedSources = do 325 | sendLoadedSourcesResponse =<< do 326 | {- 327 | list only Haskell ExtStg and ForeignC files 328 | -} 329 | let shouldInclude = \case 330 | Haskell{} -> True 331 | ForeignC{} -> True 332 | _ -> False 333 | srcSet <- getsApp sourceCodeSet 334 | mapM getSourceFromSourceCodeDescriptor $ filter shouldInclude $ Set.toList srcSet 335 | 336 | ---------------------------------------------------------------------------- 337 | talk (CustomCommand "getSourceLinks") = customCommandGetSourceLinks 338 | ---------------------------------------------------------------------------- 339 | talk (CustomCommand "showVariableGraphStructure") = customCommandShowVariableGraphStructure 340 | ---------------------------------------------------------------------------- 341 | talk (CustomCommand "showCallGraph") = customCommandShowCallGraph 342 | ---------------------------------------------------------------------------- 343 | talk CommandModules = do 344 | sendModulesResponse (ModulesResponse [] Nothing) 345 | ---------------------------------------------------------------------------- 346 | talk CommandPause = do 347 | sendAndWait CmdStop 348 | sendPauseResponse 349 | ---------------------------------------------------------------------------- 350 | talk CommandSetBreakpoints = commandSetBreakpoints 351 | ---------------------------------------------------------------------------- 352 | talk CommandStackTrace = commandStackTrace 353 | ---------------------------------------------------------------------------- 354 | talk CommandSource = do 355 | SourceArguments {..} <- getArguments -- save path of fullpak in state 356 | {- 357 | primary: sourceArgumentsSource 358 | secondary: sourceArgumentsSourceReference 359 | -} 360 | sourceRef <- fromMaybe sourceArgumentsSourceReference <$> 361 | case sourceArgumentsSource of 362 | Just source -> getValidSourceRefFromSource source 363 | Nothing -> pure Nothing 364 | 365 | (source, _locations, _hsSrcLocs) <- getSourceFromFullPak sourceRef 366 | sendSourceResponse (SourceResponse source Nothing) 367 | ---------------------------------------------------------------------------- 368 | talk CommandThreads = commandThreads 369 | ---------------------------------------------------------------------------- 370 | talk CommandScopes = commandScopes 371 | ---------------------------------------------------------------------------- 372 | talk CommandVariables = do 373 | VariablesArguments {..} <- getArguments 374 | getsApp (Bimap.lookupR variablesArgumentsVariablesReference . dapVariablesRefMap) >>= \case 375 | Just (VariablesRef_StackFrameVariables frameIdDesc) -> do 376 | variables <- getVariablesForStackFrame frameIdDesc 377 | sendVariablesResponse (VariablesResponse variables) 378 | Just (VariablesRef_Value valueRoot valueNameSpace addr) -> do 379 | variables <- getVariablesForValue valueRoot valueNameSpace addr 380 | -- detect and annotate loops 381 | let markLoop v 382 | | variableVariablesReference v == 0 383 | = v 384 | | variableVariablesReference v > variablesArgumentsVariablesReference 385 | = v 386 | | otherwise 387 | = v {variableName = variableName v <> " "} 388 | sendVariablesResponse (VariablesResponse $ map markLoop variables) 389 | Nothing -> do 390 | sendVariablesResponse (VariablesResponse []) 391 | ---------------------------------------------------------------------------- 392 | talk CommandNext = do 393 | NextArguments {..} <- getArguments 394 | sendAndWait CmdStep 395 | sendNextResponse 396 | ---------------------------------------------------------------------------- 397 | talk CommandBreakpointLocations = sendBreakpointLocationsResponse [] 398 | talk CommandSetDataBreakpoints = sendSetDataBreakpointsResponse [] 399 | talk CommandSetExceptionBreakpoints = sendSetExceptionBreakpointsResponse [] 400 | talk CommandSetFunctionBreakpoints = sendSetFunctionBreakpointsResponse [] 401 | talk CommandSetInstructionBreakpoints = sendSetInstructionBreakpointsResponse [] 402 | ---------------------------------------------------------------------------- 403 | talk CommandEvaluate = do 404 | EvaluateArguments {..} <- getArguments 405 | sendEvaluateResponse EvaluateResponse 406 | { evaluateResponseResult = "evaluated value for " <> evaluateArgumentsExpression 407 | , evaluateResponseType = "evaluated type for " <> evaluateArgumentsExpression 408 | , evaluateResponsePresentationHint = Nothing 409 | , evaluateResponseVariablesReference = 1 410 | , evaluateResponseNamedVariables = Just 1 411 | , evaluateResponseIndexedVariables = Nothing 412 | , evaluateResponseMemoryReference = Nothing 413 | } 414 | ---------------------------------------------------------------------------- 415 | talk cmd = logInfo $ BL8.pack ("GOT cmd " <> show cmd) 416 | ---------------------------------------------------------------------------- 417 | 418 | 419 | -- + on watch causes "CommandEvaluate" 420 | -- right click - set value - [127.0.0.1:49599][INFO][GOT cmd CommandSetVariable] 421 | -- right click - copy value - [127.0.0.1:49599][INFO][GOT cmd CommandEvaluate] 422 | -- save breakpoints from breakpoints request into AdaptrClient set, set them on the interpreter after configuration done (not attach) 423 | -------------------------------------------------------------------------------- /dap-estgi-server/src/SourceCode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | module SourceCode where 4 | 5 | import Control.Monad.IO.Class (liftIO) 6 | import Control.Monad 7 | import Data.String.Conversions (cs) 8 | import qualified Data.Set as Set 9 | import Data.Bimap ( Bimap ) 10 | import qualified Data.Bimap as Bimap 11 | import Data.Text ( Text ) 12 | import qualified Data.Text as T 13 | import qualified Data.Text.Encoding as T 14 | import qualified Data.Map.Strict as Map 15 | import qualified Data.ByteString.Lazy.Char8 as BL8 ( pack, unpack, fromStrict, toStrict ) 16 | import System.FilePath ( (-<.>), (), takeDirectory, takeFileName, takeExtension, dropExtension, splitFileName, splitPath, joinPath, splitDirectories) 17 | import Codec.Archive.Zip (withArchive, unEntrySelector, getEntries) 18 | import Data.Yaml hiding (Array) 19 | 20 | import Stg.Syntax hiding (sourceName, Scope) 21 | import Stg.IRLocation 22 | import Stg.Pretty 23 | import Stg.Program 24 | import Stg.IO 25 | import Stg.Tickish ( collectTickish ) 26 | 27 | import DAP 28 | import DapBase 29 | 30 | 31 | ---------------------------------------------------------------------------- 32 | 33 | getSourcePath :: SourceCodeDescriptor -> FilePath 34 | getSourcePath = \case 35 | Haskell pkg mod -> "haskell" cs pkg cs mod "module.hs" 36 | GhcCore pkg mod -> "haskell" cs pkg cs mod "module.ghccore" 37 | GhcStg pkg mod -> "haskell" cs pkg cs mod "module.ghcstg" 38 | Cmm pkg mod -> "haskell" cs pkg cs mod "module.cmm" 39 | Asm pkg mod -> "haskell" cs pkg cs mod "module.s" 40 | ExtStg pkg mod -> "haskell" cs pkg cs mod "module.stgbin" 41 | FFICStub pkg mod -> "haskell" cs pkg cs mod "module_stub.c" 42 | FFIHStub pkg mod -> "haskell" cs pkg cs mod "module_stub.h" 43 | ModInfo pkg mod -> "haskell" cs pkg cs mod "module.info" 44 | ForeignC _pkg path -> cs path 45 | 46 | getSourceName :: SourceCodeDescriptor -> String 47 | getSourceName = \case 48 | Haskell pkg mod -> "haskell" cs pkg cs mod <> ".hs" 49 | GhcCore pkg mod -> "haskell" cs pkg cs mod <> ".ghccore" 50 | GhcStg pkg mod -> "haskell" cs pkg cs mod <> ".ghcstg" 51 | Cmm pkg mod -> "haskell" cs pkg cs mod <> ".cmm" 52 | Asm pkg mod -> "haskell" cs pkg cs mod <> ".s" 53 | ExtStg pkg mod -> "haskell" cs pkg cs mod <> ".stgbin.hs" 54 | FFICStub pkg mod -> "haskell" cs pkg cs mod <> "_stub.c" 55 | FFIHStub pkg mod -> "haskell" cs pkg cs mod <> "_stub.h" 56 | ModInfo pkg mod -> "haskell" cs pkg cs mod <> ".info" 57 | ForeignC _pkg path -> cs path 58 | 59 | ---------------------------------------------------------------------------- 60 | -- | Retrieves list of modules from .fullpak file 61 | getSourceCodeListFromFullPak :: FilePath -> IO ([SourceCodeDescriptor], Bimap UnitId PackageName, Bimap Name SourceCodeDescriptor) 62 | getSourceCodeListFromFullPak fullPakPath = do 63 | rawEntries <- fmap unEntrySelector . Map.keys <$> withArchive fullPakPath getEntries 64 | let folderNames = Set.fromList (takeDirectory <$> rawEntries) 65 | appInfoName = "app.info" 66 | appInfoBytes <- readModpakL fullPakPath appInfoName id 67 | AppInfo{..} <- decodeThrow (BL8.toStrict appInfoBytes) 68 | let unitIdMap = Bimap.fromList 69 | [ (UnitId $ cs ciUnitId, cs ciPackageName) 70 | | CodeInfo{..} <- aiLiveCode 71 | ] 72 | {- 73 | program source content: 74 | haskell modules 75 | foreign files 76 | -} 77 | let rawEntriesSet = Set.fromList rawEntries 78 | moduleCodeItems pkg mod = 79 | [ Haskell pkg mod 80 | , GhcCore pkg mod 81 | , GhcStg pkg mod 82 | , Cmm pkg mod 83 | , Asm pkg mod 84 | , ExtStg pkg mod 85 | , FFICStub pkg mod 86 | , FFIHStub pkg mod 87 | , ModInfo pkg mod 88 | ] 89 | haskellModuleCode :: [SourceCodeDescriptor] 90 | haskellModuleCode = 91 | [ srcDesc 92 | | CodeInfo{..} <- aiLiveCode 93 | , srcDesc <- moduleCodeItems (cs ciPackageName) (cs ciModuleName) 94 | , Set.member (getSourcePath srcDesc) rawEntriesSet 95 | ] 96 | 97 | cbitsSources :: [SourceCodeDescriptor] 98 | cbitsSources = 99 | [ ForeignC packageName path 100 | | path <- rawEntries 101 | , ("cbits-source" : unitIdString : _) <- [splitDirectories path] 102 | , Just packageName <- [Bimap.lookup (UnitId $ cs unitIdString) unitIdMap] 103 | ] 104 | 105 | hsPathList <- forM aiLiveCode $ \CodeInfo{..} -> do 106 | let extStgPath = getSourcePath $ ExtStg (cs ciPackageName) (cs ciModuleName) 107 | (_phase, _unitId, _modName, mSrcFilePath, _stubs, _hasForeignExport, _deps) <- readModpakL fullPakPath extStgPath decodeStgbinInfo 108 | case mSrcFilePath of 109 | Nothing -> pure [] 110 | Just p -> pure [(cs p, Haskell (cs ciPackageName) (cs ciModuleName))] 111 | let hsPathMap = Bimap.fromList $ concat hsPathList 112 | pure (haskellModuleCode ++ cbitsSources, unitIdMap, hsPathMap) 113 | 114 | getValidSourceRefFromSource :: Source -> Adaptor ESTG (Maybe Int) 115 | getValidSourceRefFromSource Source{..} = do 116 | ESTG {..} <- getDebugSession 117 | {- 118 | fallback chain: 119 | 1. sourcePath 120 | 2. sourceSourceReference 121 | -} 122 | let maybeSrcDesc = do 123 | srcName <- sourcePath 124 | Bimap.lookup srcName dapSourceNameMap 125 | case maybeSrcDesc of 126 | Just srcDesc -> Just <$> getSourceRef srcDesc 127 | Nothing -> case sourceSourceReference of 128 | Just srcRef 129 | | Bimap.memberR srcRef dapSourceRefMap 130 | -> pure sourceSourceReference 131 | _ -> pure Nothing 132 | 133 | ---------------------------------------------------------------------------- 134 | -- | Retrieves list of modules from .fullpak file 135 | getSourceFromFullPak :: SourceId -> Adaptor ESTG (Text, [(StgPoint, SrcRange)], [(StgPoint, Tickish)]) 136 | getSourceFromFullPak sourceId = do 137 | ESTG {..} <- getDebugSession 138 | srcDesc <- case Bimap.lookupR sourceId dapSourceRefMap of 139 | Nothing -> do 140 | sendError (ErrorMessage (T.pack $ "Unknown sourceId: " ++ show sourceId)) Nothing 141 | Just value -> pure value 142 | let sourcePath = getSourcePath srcDesc 143 | liftIO $ 144 | case srcDesc of 145 | ExtStg{} -> do 146 | m <- readModpakL fullPakPath sourcePath decodeStgbin 147 | let (stgCode, stgLocs) = pShowWithConfig Config {cfgPrintTickish = True} $ pprModule m 148 | tickishList = collectTickish m 149 | pure (stgCode, stgLocs, tickishList) 150 | _ -> do 151 | ir <- readModpakS fullPakPath sourcePath T.decodeUtf8 152 | pure (ir, [], []) 153 | 154 | getSourceFromSourceCodeDescriptor :: SourceCodeDescriptor -> Adaptor ESTG Source 155 | getSourceFromSourceCodeDescriptor srcDesc = do 156 | srcDescSet <- getsApp sourceCodeSet 157 | extraSources <- case srcDesc of 158 | Haskell packageName qualModName 159 | | cStub <- FFICStub packageName qualModName 160 | , hStub <- FFIHStub packageName qualModName 161 | -> Just <$> sequence ( 162 | [ getSourceFromSourceCodeDescriptor (ExtStg packageName qualModName) 163 | , getSourceFromSourceCodeDescriptor (GhcCore packageName qualModName) 164 | , getSourceFromSourceCodeDescriptor (GhcStg packageName qualModName) 165 | , getSourceFromSourceCodeDescriptor (Cmm packageName qualModName) 166 | , getSourceFromSourceCodeDescriptor (Asm packageName qualModName) 167 | , getSourceFromSourceCodeDescriptor (ModInfo packageName qualModName) 168 | ] ++ 169 | [ getSourceFromSourceCodeDescriptor cStub 170 | | Set.member cStub srcDescSet 171 | ] ++ 172 | [ getSourceFromSourceCodeDescriptor hStub 173 | | Set.member hStub srcDescSet 174 | ]) 175 | 176 | _ -> pure Nothing 177 | 178 | let sourceName = cs $ getSourceName srcDesc 179 | sourceRef <- getSourceRef srcDesc 180 | ESTG {..} <- getDebugSession 181 | pure defaultSource 182 | { sourceName = Just $ sourceName -- used in source tree children 183 | , sourceSourceReference = Just sourceRef 184 | , sourcePath = Just $ sourceName -- used in code tab title 185 | , sourceSources = extraSources 186 | } 187 | 188 | getSourceRef :: SourceCodeDescriptor -> Adaptor ESTG Int 189 | getSourceRef key = do 190 | -- NOTE: Source code related db is populated at initialization 191 | getsApp (Bimap.lookup key . dapSourceRefMap) >>= \case 192 | Just srcRef -> pure srcRef 193 | Nothing -> error $ "unknown source descriptor: " ++ show key 194 | -------------------------------------------------------------------------------- /dap-estgi-server/src/SourceLocation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | module SourceLocation where 5 | 6 | import Data.Maybe ( fromMaybe, maybeToList ) 7 | import Control.Monad.IO.Class (liftIO) 8 | import Control.Monad 9 | import Data.String.Conversions (cs) 10 | import Data.Text ( Text ) 11 | import qualified Data.Text as T 12 | import qualified Data.Aeson as Aeson 13 | import qualified Data.Bimap as Bimap 14 | import qualified Data.Map.Strict as Map 15 | 16 | import Stg.Syntax hiding (sourceName, Scope) 17 | import Stg.IRLocation 18 | 19 | import DAP 20 | import DapBase 21 | import SourceCode 22 | import CustomCommands 23 | 24 | getUnitIdAndModuleNameForStgPoint :: StgPoint -> (UnitId, ModuleName) 25 | getUnitIdAndModuleNameForStgPoint = \case 26 | SP_CaseScrutineeExpr StgId{..} -> (UnitId siUnitId, ModuleName siModuleName) 27 | SP_LetExpr stgPoint -> getUnitIdAndModuleNameForStgPoint stgPoint 28 | SP_LetNoEscapeExpr stgPoint -> getUnitIdAndModuleNameForStgPoint stgPoint 29 | SP_RhsClosureExpr StgId{..} -> (UnitId siUnitId, ModuleName siModuleName) 30 | SP_AltExpr StgId{..} _idx -> (UnitId siUnitId, ModuleName siModuleName) 31 | SP_RhsCon StgId{..} -> (UnitId siUnitId, ModuleName siModuleName) 32 | SP_Binding StgId{..} -> (UnitId siUnitId, ModuleName siModuleName) 33 | SP_Tickish stgPoint -> getUnitIdAndModuleNameForStgPoint stgPoint 34 | 35 | getSourceAndPositionForStgPoint :: StgPoint -> Adaptor ESTG (Maybe Source, Int, Int, Int, Int) 36 | getSourceAndPositionForStgPoint stgPoint = do 37 | let (unitId, moduleNameBS) = getUnitIdAndModuleNameForStgPoint stgPoint 38 | ESTG {..} <- getDebugSession 39 | packageName <- case Bimap.lookup unitId unitIdMap of 40 | Nothing -> sendError (ErrorMessage (T.pack $ "Unknown unit id: " ++ show unitId)) Nothing 41 | Just v -> pure v 42 | let moduleName = cs $ getModuleName moduleNameBS 43 | source <- getSourceFromSourceCodeDescriptor $ ExtStg packageName moduleName 44 | let Just sourceRef = sourceSourceReference source 45 | (_sourceCodeText, locations, hsSrcLocs) <- getSourceFromFullPak sourceRef 46 | let inModule pkg mod (_, SourceNote{..}) 47 | | RealSrcSpan'{..} <- sourceSpan 48 | , Just hsSrcDesc <- Bimap.lookup srcSpanFile haskellSrcPathMap 49 | = hsSrcDesc == Haskell pkg mod 50 | inModule _ _ _ = False 51 | 52 | stgPointLocs = filter ((== stgPoint) . fst) hsSrcLocs 53 | hsModLocs = filter (inModule packageName moduleName) stgPointLocs 54 | forM_ stgPointLocs $ \(_, tickish) -> liftIO $ print tickish 55 | {- 56 | source location priorities: 57 | - haskell module local 58 | - stg 59 | -} 60 | case hsModLocs of 61 | (_, SourceNote{..}) : _ 62 | | RealSrcSpan'{..} <- sourceSpan 63 | , Just hsSrcDesc <- Bimap.lookup srcSpanFile haskellSrcPathMap 64 | -> do 65 | sourceHs <- getSourceFromSourceCodeDescriptor hsSrcDesc 66 | pure (Just sourceHs, srcSpanSLine, srcSpanSCol, srcSpanELine, srcSpanECol) 67 | _ -> do 68 | case filter ((== stgPoint) . fst) locations of 69 | (_, ((line, column),(endLine, endColumn))) : _ -> do 70 | pure (Just source, line, column, endLine, endColumn) 71 | _ -> do 72 | pure (Just source, 0, 0, 0, 0) 73 | 74 | getStgSourceLocJSONText :: StgPoint -> Adaptor ESTG (Maybe Text) 75 | getStgSourceLocJSONText stgPoint = fmap (cs . Aeson.encode) <$> getStgSourceLocJSON stgPoint 76 | 77 | getStgSourceLocJSON :: StgPoint -> Adaptor ESTG (Maybe Aeson.Value) 78 | getStgSourceLocJSON stgPoint = do 79 | (mSource, startL, startC, endL, endC) <- getSourceAndPositionForStgPoint stgPoint 80 | let mkPosObject line column = Aeson.object 81 | [ ("line", Aeson.Number $ fromIntegral line) 82 | , ("column", Aeson.Number $ fromIntegral column) 83 | ] 84 | srcLocJson = do 85 | Source{..} <- mSource 86 | path <- sourcePath 87 | pure $ Aeson.object 88 | [ ("path", Aeson.String path) 89 | , ("start", mkPosObject startL startC) 90 | , ("end", mkPosObject endL endC) 91 | ] 92 | pure srcLocJson 93 | 94 | customCommandGetSourceLinks :: Adaptor ESTG () 95 | customCommandGetSourceLinks = do 96 | GetSourceLinksArguments {..} <- getArguments 97 | ESTG {..} <- getDebugSession 98 | sourceLinks <- case Bimap.lookup getSourceLinksArgumentsPath dapSourceNameMap of 99 | Just srcDesc@ExtStg{} -> do 100 | source <- getSourceFromSourceCodeDescriptor srcDesc 101 | let Just sourceRef = sourceSourceReference source 102 | (_sourceCodeText, locations, hsSrcLocs) <- getSourceFromFullPak sourceRef 103 | let hsTickishLocMap = Map.unionsWith mappend [Map.singleton stgPoint [tickish] | (stgPoint, tickish) <- hsSrcLocs] 104 | -- collect tickish locations 105 | estgLocMap = Map.unionsWith mappend 106 | [ Map.singleton stgPoint [range] 107 | | (SP_Tickish stgPoint, range) <- locations 108 | ] 109 | liftIO $ do 110 | print hsTickishLocMap 111 | print estgLocMap 112 | pure $ 113 | [ SourceLink 114 | { sourceLinkSourceLine = estgStartLine 115 | , sourceLinkSourceColumn = estgStartCol 116 | , sourceLinkSourceEndLine = estgEndLine 117 | , sourceLinkSourceEndColumn = estgEndCol 118 | , sourceLinkTargetLine = srcSpanSLine 119 | , sourceLinkTargetColumn = srcSpanSCol 120 | , sourceLinkTargetEndLine = srcSpanELine 121 | , sourceLinkTargetEndColumn = srcSpanECol 122 | , sourceLinkTargetPath = cs $ getSourceName hsCodeDesc 123 | } 124 | | (stgPoint, hsTickishList) <- Map.toList hsTickishLocMap 125 | , estgLocList <- maybeToList $ Map.lookup stgPoint estgLocMap 126 | , (((estgStartLine, estgStartCol),(estgEndLine, estgEndCol)), SourceNote{..}) <- zip estgLocList hsTickishList 127 | , let RealSrcSpan'{..} = sourceSpan 128 | , hsCodeDesc <- maybeToList $ Bimap.lookup srcSpanFile haskellSrcPathMap 129 | ] 130 | _ -> pure [] 131 | sendSuccesfulResponse . setBody $ GetSourceLinksResponse 132 | { getSourceLinksResponseSourceLinks = sourceLinks 133 | } 134 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | with (builtins.fromJSON (builtins.readFile ./nixpkgs.json)); 2 | 3 | { nixpkgs ? builtins.fetchTarball { 4 | url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz"; 5 | inherit sha256; 6 | } 7 | }: 8 | 9 | let 10 | # all the nix things 11 | pkgs = import nixpkgs {}; 12 | sources = builtins.fromJSON (builtins.readFile ./source.json); 13 | 14 | ghc-wpo-src = 15 | pkgs.fetchFromGitHub sources.ghc-whole-program-compiler-project; 16 | 17 | # this is the reachability analysis binary (cretaed by souffle) that runs 18 | # the mark n' sweep GC pass. This is call by the external-stg-intepreter. 19 | ext-stg-gc = 20 | pkgs.stdenv.mkDerivation { 21 | name = "ext-stg-gc"; 22 | src = "${ghc-wpo-src}/external-stg-interpreter"; 23 | buildInputs = with pkgs; [ souffle openmpi ]; 24 | buildPhase = '' 25 | mkdir -pv $out/bin 26 | g++ -fopenmp $src/datalog/ext-stg-gc.cpp \ 27 | -Wl,-u,__factory_Sf_ext_stg_gc_instance \ 28 | -std=c++17 \ 29 | -o $out/bin/ext-stg-gc 30 | ''; 31 | }; 32 | 33 | overrides = self: super: with pkgs.haskell.lib; { 34 | 35 | type-errors-pretty = dontCheck ( 36 | doJailbreak ( 37 | self.callCabal2nix 38 | "type-errors-pretty" 39 | (pkgs.fetchFromGitHub sources.type-errors-pretty) 40 | {} 41 | ) 42 | ); 43 | 44 | digest = 45 | self.callCabal2nix 46 | "digest" 47 | (pkgs.fetchFromGitHub sources.digest) 48 | {}; 49 | 50 | final-pretty-printer = doJailbreak ( 51 | self.callCabal2nix 52 | "final-pretty-printer" 53 | (pkgs.fetchFromGitHub sources.final-pretty-printer) 54 | {} 55 | ); 56 | 57 | dap = doJailbreak ( 58 | self.callCabal2nix 59 | "dap" 60 | (pkgs.fetchFromGitHub sources.dap) 61 | {} 62 | ); 63 | 64 | dap-estgi-server = 65 | self.callCabal2nix 66 | "dap-estgi-server" 67 | ./dap-estgi-server 68 | {}; 69 | 70 | external-stg = 71 | self.callCabal2nix 72 | "external-stg" 73 | "${ghc-wpo-src}/external-stg" 74 | {}; 75 | 76 | external-stg-syntax = 77 | self.callCabal2nix 78 | "external-stg-syntax" 79 | "${ghc-wpo-src}/external-stg-syntax" 80 | {}; 81 | 82 | external-stg-interpreter = 83 | self.callCabal2nixWithOptions 84 | "external-stg-interpreter" 85 | "${ghc-wpo-src}/external-stg-interpreter" 86 | "-fexternal-ext-stg-gc" 87 | {}; 88 | 89 | souffle-haskell = 90 | dontCheck 91 | (doJailbreak 92 | (self.callCabal2nix "souffle-haskell" 93 | (pkgs.fetchFromGitHub sources.souffle-haskell) {} 94 | )); 95 | }; 96 | 97 | hPkgs = 98 | pkgs.haskellPackages.override { inherit overrides; }; 99 | 100 | in 101 | 102 | # this is the set we export for CI, and for shell.nix 103 | { 104 | inherit (hPkgs) dap-estgi-server; 105 | inherit ext-stg-gc; 106 | inherit pkgs; 107 | } 108 | -------------------------------------------------------------------------------- /docs-images/dap-01-vscode-setup-5fps.avif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-debugger/haskell-estgi-debugger/604f40e57726818426f60ff5f3b89040a263effe/docs-images/dap-01-vscode-setup-5fps.avif -------------------------------------------------------------------------------- /docs-images/dap-02-run-dap-estgi-extension-5fps.avif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-debugger/haskell-estgi-debugger/604f40e57726818426f60ff5f3b89040a263effe/docs-images/dap-02-run-dap-estgi-extension-5fps.avif -------------------------------------------------------------------------------- /docs-images/dap-03-start-dap-estgi-server-5fps.avif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-debugger/haskell-estgi-debugger/604f40e57726818426f60ff5f3b89040a263effe/docs-images/dap-03-start-dap-estgi-server-5fps.avif -------------------------------------------------------------------------------- /docs-images/dap-04-compile-debuggee-5fps.avif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-debugger/haskell-estgi-debugger/604f40e57726818426f60ff5f3b89040a263effe/docs-images/dap-04-compile-debuggee-5fps.avif -------------------------------------------------------------------------------- /docs-images/dap-05-open-debuggee-in-vscode-5fps.avif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-debugger/haskell-estgi-debugger/604f40e57726818426f60ff5f3b89040a263effe/docs-images/dap-05-open-debuggee-in-vscode-5fps.avif -------------------------------------------------------------------------------- /nixpkgs.json: -------------------------------------------------------------------------------- 1 | { 2 | "rev" : "88e992074d86", 3 | "sha256" : "sha256:1k5iv13faiyar5bsfw5klaz898662kcfyn85w5jrl2qkavf6y0y7" 4 | } 5 | -------------------------------------------------------------------------------- /sample-program-to-debug/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2023, Csaba Hruska 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Csaba Hruska nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /sample-program-to-debug/Main.hs: -------------------------------------------------------------------------------- 1 | main = putStrLn "Hello Haskell Debugger!" 2 | -------------------------------------------------------------------------------- /sample-program-to-debug/hello.cabal: -------------------------------------------------------------------------------- 1 | -- Initial minigame.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: hello 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Csaba Hruska 11 | maintainer: csaba.hruska@gmail.com 12 | -- copyright: 13 | -- category: 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | executable hello 19 | main-is: Main.hs 20 | build-depends: base >=4.8 21 | -- hs-source-dirs: 22 | default-language: Haskell2010 23 | -------------------------------------------------------------------------------- /sample-program-to-debug/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-20.24 2 | 3 | packages: 4 | - '.' 5 | 6 | # use custom ext-stg whole program compiler GHC 7 | compiler: ghc-9.2.7 8 | compiler-check: match-exact 9 | ghc-variant: wpc 10 | setup-info: 11 | ghc: 12 | linux64-custom-wpc-tinfo6: 13 | 9.2.7: 14 | url: "https://github.com/grin-compiler/foundation-pak/releases/download/ghc-9.2.7/ghc-9.2.7-x86_64-unknown-linux.tar.xz" 15 | macosx-custom-wpc: 16 | 9.2.7: 17 | url: "https://github.com/grin-compiler/foundation-pak/releases/download/ghc-9.2.7/ghc-9.2.7-x86_64-apple-darwin.tar.xz" 18 | macosx-aarch64-custom-wpc: 19 | 9.2.7: 20 | url: "https://github.com/grin-compiler/foundation-pak/releases/download/ghc-9.2.7/ghc-9.2.7-aarch64-apple-darwin.tar.xz" 21 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | (import ./default.nix {}).dap-estgi-server.env 2 | -------------------------------------------------------------------------------- /source.json: -------------------------------------------------------------------------------- 1 | { 2 | "dap": { 3 | "fetchSubmodules": true, 4 | "leaveDotGit": false, 5 | "owner": "haskell-debugger", 6 | "repo": "dap", 7 | "rev": "56d44d27c0cc509fc3e8198de448dbb2e9a6380f", 8 | "sha256": "sha256-/FKfSyYJuzXqyBu/yFTlVBQYJ4SXgLGDzQ5xAdXajCE=" 9 | }, 10 | "digest": { 11 | "fetchSubmodules": true, 12 | "leaveDotGit": false, 13 | "owner": "TeofilC", 14 | "repo": "digest", 15 | "rev": "ac9616b94cb8c4a9e07188d19979a6225ebd5a10", 16 | "sha256": "sha256-2n2SV4GYAwd09QfWynlxgeCrsj49UI3He6X66ynqfSA=" 17 | }, 18 | "final-pretty-printer": { 19 | "fetchSubmodules": true, 20 | "leaveDotGit": false, 21 | "owner": "david-christiansen", 22 | "repo": "final-pretty-printer", 23 | "rev": "048e8fa2d8b2b7a6f9e4e209db4f67361321eec8", 24 | "sha256": "0d5ya1n85qgs59p2wlx501qa1nrlk7y20riydfknfqkr0fswcpnf" 25 | }, 26 | "ghc-whole-program-compiler-project": { 27 | "fetchSubmodules": true, 28 | "leaveDotGit": false, 29 | "owner": "haskell-debugger", 30 | "repo": "ghc-whole-program-compiler-project", 31 | "rev": "65ecaed", 32 | "sha256": "sha256-T9dUWUrGeva8ghwQ5Pu1paBbBgyjoTp3SQreHs94WRQ=" 33 | }, 34 | "souffle-haskell" : { 35 | "owner" : "luc-tielen", 36 | "repo" : "souffle-haskell", 37 | "rev" : "268a11283ca9293b5eacabf7a0b79d9368232478", 38 | "hash" : "sha256-n8qqNmrDNxLlM7FRfa1Da58jGCNWjBp9+B/yV3U98gg=" 39 | }, 40 | "type-errors-pretty": { 41 | "fetchSubmodules": false, 42 | "owner": "kowainik", 43 | "repo": "type-errors-pretty", 44 | "rev": "c85d6d0a7bf2278ddb03abddb5782a5b6095d343", 45 | "sha256": "1yylw5c8ffzybcv7cm6ff0k88an4iz0fhc59md09s9zlns03f3d0" 46 | } 47 | } 48 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-20.18 2 | 3 | packages: 4 | - dap-estgi-server 5 | 6 | extra-deps: 7 | - souffle-haskell-3.5.1 8 | - type-errors-pretty-0.0.1.2@sha256:9042b64d1ac2f69aa55690576504a2397ebea8a6a55332242c88f54027c7eb57,2781 9 | - async-pool-0.9.1@sha256:4015140f896c3f1652b06a679b0ade2717d05557970c283ea2c372a71be2a6a1,1605 10 | 11 | - git: https://github.com/TeofilC/digest 12 | commit: ac9616b94cb8c4a9e07188d19979a6225ebd5a10 13 | 14 | - git: https://github.com/haskell-debugger/dap 15 | commit: 31c114964e30b8c96279ddef6fbe8d6549b52e9e 16 | 17 | - git: https://github.com/grin-compiler/ghc-whole-program-compiler-project 18 | commit: 59aacc82f1d15e1534cbdd52cdce781cbd6c81dc 19 | subdirs: 20 | - external-stg 21 | - external-stg-syntax 22 | - external-stg-interpreter 23 | 24 | - github: csabahruska/final-pretty-printer 25 | commit: 5444974a2e0ee76abb790c85738a38f96696c908 26 | 27 | flags: 28 | digest: 29 | pkg-config: false 30 | 31 | nix: 32 | enable: false 33 | packages: [ zlib bzip2 ] 34 | 35 | allow-newer: true 36 | --------------------------------------------------------------------------------