├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── CONTRIBUTORS ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── cabal.haskell-ci ├── examples ├── circular_hos.hs ├── counter.hs ├── fac.hs ├── fix-fac.hs ├── graph.hs ├── head-map-repeat.hs ├── lazy-state.hs ├── length-acc-strict.hs ├── length-acc.hs ├── length-naive.hs ├── mapM_Maybe.hs ├── maybe-fac.hs ├── multi_level_heap.hs ├── multiple-beta.hs ├── mutual_rec.hs ├── open_rec_version0.hs ├── open_rec_version1.hs ├── open_rec_version2.hs ├── repmin.hs ├── selthunkopt.hs ├── selthunkopt2.hs ├── skim.hs ├── take.hs └── ticktock.hs ├── minimal.html ├── src ├── CBN │ ├── Closure.hs │ ├── Eval.hs │ ├── Free.hs │ ├── Heap.hs │ ├── InlineHeap.hs │ ├── Language.hs │ ├── Options.hs │ ├── Parser.hs │ ├── Pretty.hs │ ├── Pretty │ │ └── Precedence.hs │ ├── SelThunkOpt.hs │ ├── Subst.hs │ ├── Trace.hs │ ├── Trace │ │ ├── Graph.hs │ │ ├── HeapGraph.hs │ │ ├── JavaScript.hs │ │ └── Textual.hs │ └── Util │ │ ├── Doc.hs │ │ ├── Doc │ │ ├── Rendered.hs │ │ ├── Rendered │ │ │ ├── ANSI.hs │ │ │ ├── HTML.hs │ │ │ └── String.hs │ │ └── Style.hs │ │ ├── Map.hs │ │ └── Snoc.hs └── Main.hs └── visualize-cbn.cabal /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'visualize-cbn.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20250216 12 | # 13 | # REGENDATA ("0.19.20250216",["github","visualize-cbn.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | push: 18 | branches: 19 | - master 20 | pull_request: 21 | branches: 22 | - master 23 | jobs: 24 | linux: 25 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 26 | runs-on: ubuntu-24.04 27 | timeout-minutes: 28 | 60 29 | container: 30 | image: buildpack-deps:jammy 31 | continue-on-error: ${{ matrix.allow-failure }} 32 | strategy: 33 | matrix: 34 | include: 35 | - compiler: ghc-9.12.1 36 | compilerKind: ghc 37 | compilerVersion: 9.12.1 38 | setup-method: ghcup 39 | allow-failure: false 40 | - compiler: ghc-9.10.1 41 | compilerKind: ghc 42 | compilerVersion: 9.10.1 43 | setup-method: ghcup 44 | allow-failure: false 45 | - compiler: ghc-9.8.4 46 | compilerKind: ghc 47 | compilerVersion: 9.8.4 48 | setup-method: ghcup 49 | allow-failure: false 50 | - compiler: ghc-9.6.6 51 | compilerKind: ghc 52 | compilerVersion: 9.6.6 53 | setup-method: ghcup 54 | allow-failure: false 55 | - compiler: ghc-9.4.8 56 | compilerKind: ghc 57 | compilerVersion: 9.4.8 58 | setup-method: ghcup 59 | allow-failure: false 60 | - compiler: ghc-9.2.8 61 | compilerKind: ghc 62 | compilerVersion: 9.2.8 63 | setup-method: ghcup 64 | allow-failure: false 65 | - compiler: ghc-9.0.2 66 | compilerKind: ghc 67 | compilerVersion: 9.0.2 68 | setup-method: ghcup 69 | allow-failure: false 70 | - compiler: ghc-8.10.7 71 | compilerKind: ghc 72 | compilerVersion: 8.10.7 73 | setup-method: ghcup 74 | allow-failure: false 75 | fail-fast: false 76 | steps: 77 | - name: apt-get install 78 | run: | 79 | apt-get update 80 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 81 | - name: Install GHCup 82 | run: | 83 | mkdir -p "$HOME/.ghcup/bin" 84 | curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" 85 | chmod a+x "$HOME/.ghcup/bin/ghcup" 86 | - name: Install cabal-install 87 | run: | 88 | "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 89 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 90 | - name: Install GHC (GHCup) 91 | if: matrix.setup-method == 'ghcup' 92 | run: | 93 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 94 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 95 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 96 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 97 | echo "HC=$HC" >> "$GITHUB_ENV" 98 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 99 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 100 | env: 101 | HCKIND: ${{ matrix.compilerKind }} 102 | HCNAME: ${{ matrix.compiler }} 103 | HCVER: ${{ matrix.compilerVersion }} 104 | - name: Set PATH and environment variables 105 | run: | 106 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 107 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 108 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 109 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 110 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 111 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 112 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 113 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 114 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 115 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 116 | env: 117 | HCKIND: ${{ matrix.compilerKind }} 118 | HCNAME: ${{ matrix.compiler }} 119 | HCVER: ${{ matrix.compilerVersion }} 120 | - name: env 121 | run: | 122 | env 123 | - name: write cabal config 124 | run: | 125 | mkdir -p $CABAL_DIR 126 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 159 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 160 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 161 | rm -f cabal-plan.xz 162 | chmod a+x $HOME/.cabal/bin/cabal-plan 163 | cabal-plan --version 164 | - name: checkout 165 | uses: actions/checkout@v4 166 | with: 167 | path: source 168 | - name: initial cabal.project for sdist 169 | run: | 170 | touch cabal.project 171 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 172 | cat cabal.project 173 | - name: sdist 174 | run: | 175 | mkdir -p sdist 176 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 177 | - name: unpack 178 | run: | 179 | mkdir -p unpacked 180 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 181 | - name: generate cabal.project 182 | run: | 183 | PKGDIR_visualize_cbn="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/visualize-cbn-[0-9.]*')" 184 | echo "PKGDIR_visualize_cbn=${PKGDIR_visualize_cbn}" >> "$GITHUB_ENV" 185 | rm -f cabal.project cabal.project.local 186 | touch cabal.project 187 | touch cabal.project.local 188 | echo "packages: ${PKGDIR_visualize_cbn}" >> cabal.project 189 | echo "package visualize-cbn" >> cabal.project 190 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 191 | cat >> cabal.project <> cabal.project.local 194 | cat cabal.project 195 | cat cabal.project.local 196 | - name: dump install plan 197 | run: | 198 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 199 | cabal-plan 200 | - name: restore cache 201 | uses: actions/cache/restore@v4 202 | with: 203 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 204 | path: ~/.cabal/store 205 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 206 | - name: install dependencies 207 | run: | 208 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 209 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 210 | - name: build w/o tests 211 | run: | 212 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 213 | - name: build 214 | run: | 215 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 216 | - name: cabal check 217 | run: | 218 | cd ${PKGDIR_visualize_cbn} || false 219 | ${CABAL} -vnormal check 220 | - name: haddock 221 | run: | 222 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 223 | - name: unconstrained build 224 | run: | 225 | rm -f cabal.project.local 226 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 227 | - name: save cache 228 | if: always() 229 | uses: actions/cache/save@v4 230 | with: 231 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 232 | path: ~/.cabal/store 233 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | tags 2 | dist/ 3 | dist-newstyle/ 4 | .ghc.environment.* 5 | .stack-work 6 | .cabal-sandbox 7 | .stack-work 8 | .cabal.sandbox.config 9 | .envrc 10 | foo.js 11 | -------------------------------------------------------------------------------- /CONTRIBUTORS: -------------------------------------------------------------------------------- 1 | Contributors (in alphabetical order) 2 | 3 | * Alfredo Di Napoli 4 | * Andrew Butterfield 5 | * Edsko de Vries 6 | * Ramakrishnan Muthukrishnan 7 | * Tim Rakowski 8 | * Yiğit Özkavcı 9 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for visualize-cbn 2 | 3 | ## 0.2.1 -- 2024-01-10 4 | 5 | * Fixes to the selector thunk optimization: also apply it at the top-level, 6 | and correctly apply `--hide-selector-thunk-opt` (previously `--hide-gc` 7 | was hiding selector thunk optimization steps by mistake). 8 | 9 | ## 0.2.0 -- 2023-12-20 10 | 11 | * Support multiple (mutually recursive) bindings in `let` 12 | * Fix pattern matching on heap-allocated objects (we were losing sharing) 13 | * Support heap inlining 14 | * Support for selectors (`fst`, `snd`) 15 | * Support the selector thunk optimization 16 | * Add `--disable-ansi` command line 17 | * Improve trace summarization 18 | * Add some new primitive functions (`min`, `max`, `succ`) 19 | * Add option to hide the prelude only after a specified step 20 | 21 | ## 0.1.0.2 -- 2019-09-10 22 | 23 | * Newer GHC compatibility 24 | 25 | ## 0.1.0.1 -- 2018-03-04 26 | 27 | * Start maintaining ChangeLog file. 28 | * Minor improvement to the evaluation function: 29 | 30 | `let x = e1 in seq x e2` 31 | 32 | now takes a step to (provided that `e1 -> e1'`) 33 | 34 | `let x = e1' in seq x e2` 35 | 36 | this avoids moving `e1` to the heap (provided that there aren't multiple 37 | references to `x` from `e2`), clarifying the evaluation. 38 | * Added graph output (contributed by Yiğit Özkavcı). 39 | * Improved heap descriptions (contributed by Tim Rakowski). 40 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, Edsko de Vries 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 Edsko de Vries 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 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Call-by-name interpretation and visualization tool 2 | 3 | Haskell and other call-by-name languages use _lazy evaluation_ as their default evaluation strategy. For beginners and advanced programmers alike this can sometimes be confusing. The `visualize-cbn` tool is designed to help in such cases; it is a simple interpreter for a mini-Haskell-like language which outputs the state of the program at every step in a human readable format. It can also generate a HTML/JavaScript version with "Previous" and "Next" buttons to allow to step through a program. 4 | 5 | ## Example 6 | 7 | Consider the following example program: 8 | 9 | ``` haskell 10 | fac = (\n -> 11 | if le n 1 12 | then 1 13 | else mul (@fac (sub n 1)) n 14 | ) 15 | 16 | main = @fac 1 17 | ``` 18 | 19 | The syntax is not _quite_ Haskell, but hopefully it should be pretty self-explanatory. The parser is pretty finicky; look at some of the examples in `examples/` to deduce what the syntax is. The only somewhat odd feature is the identifies marked with an at-sign (`@`); these corresponds to pointers in the heap. For programs in their initial state (i.e., as written down), the only heap pointers we expect are to CAFs (constant applicative forms; values defined at the top-level of the program). 20 | 21 | ## Stepping through 22 | 23 | We can step through the evaluation of this program using 24 | 25 | ``` 26 | visualize-cbn -i examples/fac.hs --show-trace --hide-prelude 0 27 | ``` 28 | 29 | This will result in something like 30 | 31 | ``` 32 | ** 0 33 | 34 | fac 1 35 | 36 | (apply fac) 37 | 38 | ** 1 39 | 40 | if 1 <= 1 41 | then 1 42 | else fac (1 - 1) * 1 43 | 44 | (delta: 1 <= 1) 45 | 46 | ** 2 47 | 48 | if True 49 | then 1 50 | else fac (1 - 1) * 1 51 | 52 | (if True) 53 | 54 | ** 3 55 | 56 | 1 57 | 58 | (whnf) 59 | ``` 60 | 61 | At every step it lists the current state of the program, as well as the reduction rules that apply. There are some options for tweaking the output; see `--help`. 62 | 63 | ## Generating HTML/JavaScript 64 | 65 | The tool can also generate HTML/JavaScript: 66 | 67 | ``` 68 | cr visualize-cbn -i examples/fac.hs --javascript foo.js 69 | ``` 70 | 71 | The resulting `.js` file can be embedded in a HTML page (such as a blog post); a minimal HTML page illustrating how this is done is given by 72 | 73 | ``` html 74 | 75 | 76 | 77 | Prev 78 | Next 79 | (step Step, Status) 80 | 81 | 82 | 83 | 84 |
Term
Heap
85 | 86 | 87 | 88 | 89 | 90 | ``` 91 | 92 | (This `.html` file was not written to illustrate HTML best practices :-) ) See the [Well-Typed blog post about the tool](http://www.well-typed.com/blog/2017/09/visualize-cbn/) for an example output. 93 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | branches: master 2 | -------------------------------------------------------------------------------- /examples/circular_hos.hs: -------------------------------------------------------------------------------- 1 | -- See "Using Circular Programs for Higher-Order Syntax" 2 | -- by Emil Axelsson and Koen Claessen (ICFP 2013) 3 | -- 4 | -- 5 | -- See Unfolder episode 17 for more details. 6 | -- 7 | -- Suggested execution: 8 | -- 9 | -- > cabal run visualize-cbn -- \ 10 | -- > --show-trace \ 11 | -- > --hide-prelude=1 \ 12 | -- > --gc \ 13 | -- > --selector-thunk-opt \ 14 | -- > --inline-heap \ 15 | -- > --hide-inlining \ 16 | -- > --hide-gc \ 17 | -- > --hide-selector-thunk-opt \ 18 | -- > --javascript foo.js \ 19 | -- > -i examples/circular_hos.hs 20 | -- 21 | -- Annotated execution (as of dc51993): 22 | -- 23 | -- 2. As soon as we demand the value of @maxBV body_0@ to determine the 24 | -- variable to be used for the outer-most lambda, this will force the 25 | -- construction of the next term down. This happens recursively, so the 26 | -- entire term is build in memory. 27 | -- 10. This is an instructive subsequence: we will see the evaluation of 28 | -- the simple term @lam (\y -> y)@. 29 | -- 16. At this point this term is fully known: @Lam 1 (Var 1)@. 30 | -- 17. The computation is driven by the computation of the variable to be used 31 | -- for the outermost lambda; we can now continue this computation a little 32 | -- bit, because we now know the @maxBV@ of the subterm @Lam 1 (Var 1)@. 33 | -- 19. We repeat for the second simple term @lam (\z -> z)@. 34 | -- 27. At this point we're almost done: we need to know the @max@BV@ of the 35 | -- subterm @Var n_1@, but there aren't any, so that is just @0@. 36 | -- 33. At this point all bound variables are known, and the new term has been 37 | -- constructed. 38 | maxBV = (\exp -> 39 | case exp of { 40 | Var x -> 0 41 | ; App f e -> max (@maxBV f) (@maxBV e) 42 | ; Lam n f -> n 43 | } 44 | ) 45 | 46 | lam = (\f -> 47 | let { 48 | body = f (Var n) 49 | ; n = succ (@maxBV body) 50 | } 51 | in seq n (Lam n body) 52 | ) 53 | 54 | main = @lam (\x -> App (App (@lam (\y -> y)) (@lam (\z -> z))) x) 55 | -------------------------------------------------------------------------------- /examples/counter.hs: -------------------------------------------------------------------------------- 1 | fix = (\f -> f (@fix f)) 2 | 3 | mkCounter = (\self -> \n -> 4 | Counter (let n' = add n 1 in seq n' (self n')) 5 | n 6 | ) 7 | 8 | twice = (\self -> \n -> 9 | let c = @mkCounter self n 10 | in Counter (@tick c) (mul 2 n)) 11 | 12 | tick = (\c -> case c of { 13 | Counter t d -> t 14 | }) 15 | 16 | display = (\c -> case c of { 17 | Counter t d -> d 18 | }) 19 | 20 | main = @display (@tick (@tick (@tick (@fix @twice 0)))) 21 | -------------------------------------------------------------------------------- /examples/fac.hs: -------------------------------------------------------------------------------- 1 | fac = (\n -> 2 | if le n 1 3 | then 1 4 | else mul (@fac (sub n 1)) n 5 | ) 6 | 7 | main = @fac 1 8 | 9 | -------------------------------------------------------------------------------- /examples/fix-fac.hs: -------------------------------------------------------------------------------- 1 | 2 | fix = (\f -> f (@fix f)) 3 | 4 | fac = (\r -> \n -> 5 | if eq n 1 6 | then 1 7 | else let n' = sub n 1 in seq n' (mul n (r n'))) 8 | 9 | main = @fix @fac 5 10 | -------------------------------------------------------------------------------- /examples/graph.hs: -------------------------------------------------------------------------------- 1 | ls = (Cons 1 (Cons 2 (Cons 3 @ls))) 2 | 3 | double = (\n -> add n n) 4 | 5 | main = @double (add 1 2) 6 | -------------------------------------------------------------------------------- /examples/head-map-repeat.hs: -------------------------------------------------------------------------------- 1 | -- head (map (\x -> x + x) (repeat (10 + 1))) 2 | 3 | repeat = (\x -> let xs = @repeat x 4 | in Cons x xs) 5 | 6 | map = (\f -> (\xs -> case xs of { 7 | Nil -> Nil ; 8 | Cons x xs' -> let fx = f x 9 | in Cons fx (@map f xs') 10 | } )) 11 | head = (\xs -> case xs of { 12 | Cons x xs' -> x 13 | } ) 14 | 15 | main = @head (@map (\x -> add x x) (@repeat (add 10 1))) 16 | 17 | -------------------------------------------------------------------------------- /examples/lazy-state.hs: -------------------------------------------------------------------------------- 1 | -- Pairs 2 | 3 | fst = (\pair -> case pair of { Pair x y -> x }) 4 | snd = (\pair -> case pair of { Pair x y -> y }) 5 | 6 | -- Lazy state monad 7 | 8 | ret = (\a -> \s -> Pair a s) 9 | 10 | bind = (\x -> \f -> \s -> 11 | let a_s' = x s 12 | in f (@fst a_s') (@snd a_s') 13 | ) 14 | 15 | mapM = (\f -> \as -> 16 | case as of { 17 | Nil -> @ret Nil ; 18 | Cons a as' -> @bind (f a) (\b -> @bind (@mapM f as') (\bs -> @ret (Cons b bs))) 19 | } 20 | ) 21 | 22 | get = (\s -> Pair s s) 23 | 24 | put = (\new -> \old -> Pair Unit new) 25 | 26 | evalState = (\k -> \s -> @fst (k s)) 27 | 28 | -- The actual computations 29 | -- TODO: The "@"s here are the only difference from real haskell code; 30 | -- if we got rid of those, we could actually copy and paste these into ghc :/ 31 | 32 | foo1 = (\n -> 33 | @bind get (\sumSoFar -> 34 | @bind (if eq sumSoFar 0 35 | then let sumSoFar' = add sumSoFar 1 36 | in seq sumSoFar' (@put sumSoFar') 37 | else @ret Unit) (\unused -> 38 | ret n)) 39 | ) 40 | 41 | foo2 = (\n -> 42 | @bind get (\sumSoFar -> 43 | if eq sumSoFar 0 44 | then let sumSoFar' = add sumSoFar 1 45 | in seq sumSoFar' (@bind (@put sumSoFar') (\unused -> @ret n)) 46 | else @ret n) 47 | ) 48 | 49 | -- Top-level 50 | 51 | main = 1 52 | -------------------------------------------------------------------------------- /examples/length-acc-strict.hs: -------------------------------------------------------------------------------- 1 | enumFromTo = (\n -> \m -> 2 | if le n m then Cons n (@enumFromTo (add n 1) m) 3 | else Nil 4 | ) 5 | 6 | length = (\acc -> \xs -> 7 | case xs of { 8 | Nil -> acc ; 9 | Cons x xs' -> let acc' = add 1 acc in seq acc' (@length acc' xs') 10 | } 11 | ) 12 | 13 | main = @length 0 (@enumFromTo 1 3) 14 | -------------------------------------------------------------------------------- /examples/length-acc.hs: -------------------------------------------------------------------------------- 1 | enumFromTo = (\n -> \m -> 2 | if le n m then Cons n (@enumFromTo (add n 1) m) 3 | else Nil 4 | ) 5 | 6 | length = (\acc -> \xs -> 7 | case xs of { 8 | Nil -> acc ; 9 | Cons x xs' -> @length (add 1 acc) xs' 10 | } 11 | ) 12 | 13 | main = @length 0 (@enumFromTo 1 3) 14 | -------------------------------------------------------------------------------- /examples/length-naive.hs: -------------------------------------------------------------------------------- 1 | enumFromTo = (\n -> \m -> 2 | if le n m then Cons n (@enumFromTo (add n 1) m) 3 | else Nil 4 | ) 5 | 6 | length = (\xs -> 7 | case xs of { 8 | Nil -> 0 ; 9 | Cons x xs' -> add 1 (@length xs') 10 | } 11 | ) 12 | 13 | main = @length (@enumFromTo 1 3) 14 | -------------------------------------------------------------------------------- /examples/mapM_Maybe.hs: -------------------------------------------------------------------------------- 1 | bind = (\ma -> \f -> 2 | case ma of { 3 | Nothing -> Nothing ; 4 | Just a -> f a 5 | } 6 | ) 7 | 8 | return = (\a -> Just a) 9 | 10 | enumFromTo = (\n -> \m -> 11 | if le n m then Cons n (@enumFromTo (add n 1) m) 12 | else Nil 13 | ) 14 | 15 | mapM = (\f -> \xs -> 16 | case xs of { 17 | Nil -> @return Nil ; 18 | Cons x xs' -> @bind (f x) (\x' -> 19 | @bind (@mapM f xs') (\xs' -> 20 | @return (Cons x' xs') )) 21 | } 22 | ) 23 | 24 | main = @mapM @return (@enumFromTo 1 3) 25 | -------------------------------------------------------------------------------- /examples/maybe-fac.hs: -------------------------------------------------------------------------------- 1 | bind_Maybe = (\ma -> \f -> 2 | case ma of { 3 | Nothing -> Nothing ; 4 | Just a -> f a 5 | } 6 | ) 7 | 8 | return_Maybe = (\a -> Just a) 9 | 10 | fac = (\n -> 11 | if le n 1 12 | then Just 1 13 | else @bind_Maybe (@fac (sub n 1)) (\n' -> @return_Maybe (mul n n')) 14 | ) 15 | 16 | main = @fac 5 17 | -------------------------------------------------------------------------------- /examples/multi_level_heap.hs: -------------------------------------------------------------------------------- 1 | const = (\x -> \y -> x) 2 | 3 | main = (\x -> @const x x) ((\x -> @const x x) (@const 1 1)) 4 | -------------------------------------------------------------------------------- /examples/multiple-beta.hs: -------------------------------------------------------------------------------- 1 | f = (\x -> @g x) 2 | g = (\x -> @h x) 3 | h = (\x -> succ x) 4 | 5 | main = @f 1 6 | 7 | 8 | -------------------------------------------------------------------------------- /examples/mutual_rec.hs: -------------------------------------------------------------------------------- 1 | -- Simple example of two mutually recursive functions 2 | -- f x will return 0 if x is even and 1 if x is odd. 3 | main = 4 | let { 5 | f = (\x -> if eq x 0 then 0 else g (sub x 1)) 6 | ; g = (\x -> if eq x 0 then 1 else f (sub x 1)) 7 | } in f 2 -------------------------------------------------------------------------------- /examples/open_rec_version0.hs: -------------------------------------------------------------------------------- 1 | object = (\f -> f (@object f)) 2 | 3 | mkCounter = (\this -> \n -> 4 | Counter (this (add 1 n)) n 5 | ) 6 | 7 | tick = (\c -> case c of { 8 | Counter t d -> t 9 | }) 10 | 11 | value = (\c -> case c of { 12 | Counter t d -> d 13 | }) 14 | 15 | main = @value (@tick (@tick (@object @mkCounter 0))) 16 | -------------------------------------------------------------------------------- /examples/open_rec_version1.hs: -------------------------------------------------------------------------------- 1 | object = (\f -> f (@object f)) 2 | 3 | mkCounter = (\this -> \n -> 4 | Counter (this (add 1 n)) n 5 | ) 6 | 7 | faster = (\this -> \n -> 8 | let c = @mkCounter this n 9 | in Counter (this (add 2 n)) (@value c) 10 | ) 11 | 12 | tick = (\c -> case c of { 13 | Counter t d -> t 14 | }) 15 | 16 | value = (\c -> case c of { 17 | Counter t d -> d 18 | }) 19 | 20 | main = @value (@tick (@tick (@object @faster 0))) 21 | -------------------------------------------------------------------------------- /examples/open_rec_version2.hs: -------------------------------------------------------------------------------- 1 | object = (\f -> f undefined (@object f)) 2 | 3 | mkCounter = (\super -> \this -> \n -> 4 | Counter (this (add 1 n)) n 5 | ) 6 | 7 | faster = (\super -> \this -> \n -> 8 | let c = super n 9 | in Counter (this (add 2 n)) (@value c) 10 | ) 11 | 12 | tick = (\c -> case c of { 13 | Counter t d -> t 14 | }) 15 | 16 | value = (\c -> case c of { 17 | Counter t d -> d 18 | }) 19 | 20 | mixin = (\f -> \g -> \super -> \this -> 21 | f (g super this) this 22 | ) 23 | 24 | main = @value (@tick (@tick (@object (@mixin @faster @mkCounter) 0))) 25 | -------------------------------------------------------------------------------- /examples/repmin.hs: -------------------------------------------------------------------------------- 1 | -- The classic repMin circular program due to Richard Bird. 2 | -- See Unfolder episode 17 for more details. 3 | -- 4 | -- Suggested execution: 5 | -- 6 | -- > cabal run visualize-cbn -- \ 7 | -- > --show-trace \ 8 | -- > --hide-prelude=1 \ 9 | -- > --gc \ 10 | -- > --selector-thunk-opt \ 11 | -- > --inline-heap \ 12 | -- > --hide-inlining \ 13 | -- > --hide-gc \ 14 | -- > --hide-selector-thunk-opt \ 15 | -- > --javascript foo.js \ 16 | -- > -i examples/repmin.hs 17 | -- 18 | -- Annotated execution (as of dc51993): 19 | -- 20 | -- 1. One way to think about this circular program is to consider that it 21 | -- first creates a pointer to an int (the new value in the leaves), and 22 | -- then starts building up a tree with all leaves pointing to this int; 23 | -- as it builds the tree, it is also computing the value of this int. 24 | -- 6. We're starting to see the tree take shape here; the top-level structure 25 | -- of the tree is now known. 26 | -- 10. Similarly, we now see the shape of the left subtree. 27 | -- 13. Here we see the first @Leaf@, ponting to @m_1@; part of the computation 28 | -- of @m_1@ is now also known (@mb_7@). 29 | -- 16. The second @Leaf@ is known. 30 | -- 18. The minimum value of the left subtree is known (@mb_4@). 31 | -- 28. At this point the structure of the tree is mostly done. We can 32 | -- finish the value computation. 33 | worker = (\m -> \t -> 34 | case t of { 35 | Leaf x -> Pair x (Leaf m) 36 | ; Branch l r -> 37 | let { 38 | resultLeft = @worker m l 39 | ; resultRight = @worker m r 40 | ; mb = min (fst resultLeft) (fst resultRight) 41 | } 42 | in seq mb (Pair mb (Branch (snd resultLeft) (snd resultRight))) 43 | } 44 | ) 45 | 46 | repMin = (\t -> 47 | let result = @worker (fst result) t 48 | in snd result 49 | ) 50 | 51 | main = @repMin (Branch (Branch (Leaf 1) (Leaf 2)) (Branch (Leaf 3) (Leaf 4))) 52 | -------------------------------------------------------------------------------- /examples/selthunkopt.hs: -------------------------------------------------------------------------------- 1 | -- Demonstration of the need for the selector thunk optimization 2 | -- This is the example from "Fixing some space leaks with a garbage collector". 3 | 4 | break = (\xs -> 5 | case xs of { 6 | Nil -> Pair Nil Nil 7 | ; Cons x xs' -> 8 | if eq x 0 9 | then Pair Nil xs' 10 | else let b = @break xs' 11 | in Pair (Cons x (fst b)) (snd b) 12 | } 13 | ) 14 | 15 | -- strict version of concat (makes the example more clear) 16 | concat = (\xs -> \ys -> 17 | case xs of { 18 | Nil -> ys 19 | ; Cons x xs' -> let r = @concat xs' ys in seq r (Cons x r) 20 | } 21 | ) 22 | 23 | surprise = (\xs -> 24 | let b = @break xs 25 | in @concat (fst b) (@concat (Cons 4 (Cons 5 (Cons 6 Nil))) (snd b)) 26 | ) 27 | 28 | main = @surprise (Cons 1 (Cons 2 (Cons 3 (Cons 0 (Cons 7 (Cons 8 (Cons 9 Nil))))))) 29 | -------------------------------------------------------------------------------- /examples/selthunkopt2.hs: -------------------------------------------------------------------------------- 1 | break = (\xs -> 2 | case xs of { 3 | Nil -> Pair Nil Nil 4 | ; Cons x xs' -> 5 | if eq x 0 6 | then Pair Nil xs' 7 | else let b = @break xs' 8 | in Pair (Cons x (fst b)) (snd b) 9 | } 10 | ) 11 | 12 | last = (\def -> \xs -> 13 | case xs of { 14 | Nil -> def 15 | ; Cons x' xs' -> @last x' xs' 16 | } 17 | ) 18 | 19 | main = let broken = @break (Cons 1 (Cons 2 (Cons 3 (Cons 4 (Cons 0 (Cons 5 (Cons 6 (Cons 7 (Cons 8 Nil))))))))) 20 | in eq (@last 0 (fst broken)) (@last 0 (snd broken)) -------------------------------------------------------------------------------- /examples/skim.hs: -------------------------------------------------------------------------------- 1 | 2 | fix = (\f -> f (@fix f)) 3 | 4 | fac = (\r -> \n -> 5 | if eq n 1 6 | then 1 7 | else let n' = sub n 1 in seq n' (mul n (r n'))) 8 | 9 | skim = (\r -> \n -> 10 | if eq n 1 11 | then 1 12 | else sub (@fac r n) 1) 13 | 14 | main = @fix @skim 5 15 | -------------------------------------------------------------------------------- /examples/take.hs: -------------------------------------------------------------------------------- 1 | -- program starts here (lazy-ones.hs) 2 | enumFromTo = (\n -> \m -> 3 | if le n m then Cons n (@enumFromTo (add n 1) m) 4 | else Nil 5 | ) 6 | 7 | take = (\n -> \xs -> 8 | if eq n 0 9 | then Nil 10 | else case xs of { 11 | Nil -> Nil ; 12 | Cons x xs' -> Cons x (@take (sub n 1) xs') 13 | } 14 | ) 15 | 16 | main = @take 1 (@enumFromTo 1 10) 17 | -------------------------------------------------------------------------------- /examples/ticktock.hs: -------------------------------------------------------------------------------- 1 | tick = (\c -> case c of { 2 | Counter ti to d -> ti 3 | }) 4 | 5 | tock = (\c -> case c of { 6 | Counter ti to d -> to 7 | }) 8 | 9 | display = (\c -> case c of { 10 | Counter ti to d -> d 11 | }) 12 | 13 | fix = (\f -> f (@fix f)) 14 | 15 | mkCounter = (\self -> \n -> 16 | Counter (let n' = add n 1 in seq n' (self n')) 17 | (let n' = add n 1 in seq n' (self n')) 18 | n 19 | ) 20 | 21 | reconstruct = (\n -> Pair n 0) 22 | 23 | comp = (\f -> \g -> \x -> f (g x)) 24 | 25 | ticktock = (\self -> \pair -> 26 | case pair of { 27 | Pair x y -> @mkCounter (@comp self @reconstruct) x 28 | }) 29 | 30 | main = @display (@tick (@tock (@tick (@fix @ticktock (Pair 0 0))))) 31 | 32 | {- 33 | Here are the constructor calls after the first tick: 34 | 35 | fix ticktock (0, 0) 36 | ticktock (fix ticktock) (0, 0) 37 | mkCounter (fix ticktock . reconstruct) 0 38 | fix ticktock (reconstruct 1) 39 | -} 40 | -------------------------------------------------------------------------------- /minimal.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | Prev 6 | Next 7 | (step Step, Status) 8 | 9 | 10 | 11 | 12 |
Term
Heap
13 | 14 | 15 | 16 | 17 | 18 | -------------------------------------------------------------------------------- /src/CBN/Closure.hs: -------------------------------------------------------------------------------- 1 | module CBN.Closure (toClosureGraph, Closure(..), Id) where 2 | 3 | import Data.Maybe (fromJust) 4 | import Data.Graph as Graph hiding (edges) 5 | import Control.Monad.State 6 | import qualified Data.Set as Set 7 | import qualified Data.Map as Map 8 | import qualified Data.Tree as Tree 9 | 10 | import CBN.Language 11 | import CBN.Heap 12 | import CBN.Trace () 13 | 14 | -- Some Terms have a heap Pointer, but not an explicit CBN.Heap.Ptr. 15 | -- For example the closure `Cons 1 Nil` has a Pointer to `1` 16 | -- and to `Nil`. All values are assumed boxed. 17 | 18 | -- | Id is the unique id of each node. 19 | data Id = Id Ptr Int 20 | deriving (Eq, Ord) 21 | 22 | -- | The Id for objects with an explicit Heap.Ptr. 23 | defaultId :: Ptr -> Id 24 | defaultId p = Id p 0 25 | 26 | -- | Each Closure has a Header and some edges (the Payload). 27 | data Closure = 28 | ErrorClosure String 29 | | FunClosure Term [Ptr] 30 | | ConClosure Con [Term] 31 | 32 | -- IndirectionClosures can be ignored while looking at the graph. 33 | -- An idirection of a thunk is a thunk and an indirection to a 34 | -- whnf is whnf. Indirections are not yet eliminated because they can 35 | -- have loops, so this task is not trivial. 36 | | IndirectionClosure Ptr 37 | 38 | -- ThunkClosure also includes Closures for function application. 39 | -- This could be improved in the future. See also: 40 | -- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/HeapObjects#Genericapplication 41 | | ThunkClosure Term [Ptr] 42 | | PrimClosure Prim [Term] 43 | deriving (Show) 44 | 45 | -- | Eventually all edges are heap pointers. The distinction here is made 46 | -- because related terms don`t have an assigned Id when this function is used. 47 | extractEdges :: Closure -> ([Ptr], [Term]) 48 | extractEdges cl = case cl of 49 | ErrorClosure _ -> ([], []) 50 | FunClosure _ ls -> (ls, []) 51 | ConClosure _ ls -> ([], ls) 52 | IndirectionClosure ptr -> ([ptr], []) 53 | ThunkClosure _ ls -> (ls, []) 54 | PrimClosure _ ls -> ([], ls) 55 | 56 | thunk :: Term -> Closure 57 | thunk term = ThunkClosure term $ Set.toList $ pointers term 58 | 59 | -- Heap could be used in the future to eliminate Indirections. 60 | 61 | toClosure :: (Heap Term, Term) -> Closure 62 | toClosure (_heap, term) = case term of 63 | TVar (Var x) -> ErrorClosure $ "free variable " ++ show x 64 | TLam _ _ -> FunClosure term ls 65 | where ls = Set.toList $ pointers term 66 | TCon (ConApp con terms) -> ConClosure con terms 67 | TPtr ptr -> IndirectionClosure ptr 68 | TPrim (PrimApp p es) -> PrimClosure p es 69 | TLet _ _ -> thunk term 70 | TApp _ _ -> thunk term 71 | TCase _ _ -> thunk term 72 | TIf _ _ _ -> thunk term 73 | TSeq _ _ -> thunk term 74 | 75 | -- | Build a representation of the heap, including terms that don`t 76 | -- have an explicit Heap.Ptr. 77 | toClosureGraph :: (Heap Term, Term) -> (Graph, Graph.Vertex -> 78 | (Closure, Id, [Id]), Id -> Graph.Vertex) 79 | toClosureGraph (heap@(Heap _ hp), term) = 80 | let (graph, f, g) = Graph.graphFromEdges edges 81 | in (graph, f , fromJust . g) 82 | where 83 | main = (Ptr Nothing (Just "main"), term) 84 | 85 | edges :: [(Closure, Id, [Id])] 86 | edges = concatMap mkTree $ main : Map.toList hp 87 | 88 | -- If we ignore Heap.Ptrs, each heap term, defines a tree of other reachable 89 | -- terms. 90 | mkTree :: (Ptr, Term) -> [(Closure, Id, [Id])] 91 | mkTree (ptr, term') = Tree.flatten $ addInternalEdges tree 92 | where 93 | identify :: State Int Id 94 | identify = do 95 | myid <- get 96 | put $ myid + 1 97 | return $ Id ptr myid 98 | 99 | addInternalEdges :: Tree (Id, (Closure, [Id])) -> Tree (Closure, Id, [Id]) 100 | addInternalEdges (Node (myid, (cl, ids)) subTrees) = Node (cl, myid, newIds) cont 101 | where 102 | childIds = fmap (fst . Tree.rootLabel) subTrees 103 | newIds = ids ++ childIds 104 | cont = map addInternalEdges subTrees 105 | 106 | tree :: Tree (Id, (Closure, [Id])) 107 | tree = evalState (Tree.unfoldTreeM f term') 0 108 | 109 | -- The [Id] here contains only the pointer ids and 110 | -- Not the Ids of the same Tree, as those are not assigned yet. 111 | -- They are added at `addInternalEdges`, after the creation of the whole tree. 112 | 113 | f :: Term -> State Int ((Id, (Closure, [Id])), [Term]) 114 | f term'' = do 115 | myid <- identify 116 | let closure = toClosure (heap, term'') 117 | let (ptrs, terms) = extractEdges closure 118 | return ((myid, (closure, map defaultId ptrs)), terms) 119 | -------------------------------------------------------------------------------- /src/CBN/Eval.hs: -------------------------------------------------------------------------------- 1 | module CBN.Eval ( 2 | Error 3 | , Description(..) 4 | , DescriptionWithContext(..) 5 | , Step(..) 6 | , step 7 | -- * Case statements 8 | , findMatch 9 | , AllocdConArgs(..) 10 | , allocConArgs 11 | ) where 12 | 13 | import qualified Data.Map as M 14 | 15 | import CBN.Language 16 | import CBN.Heap 17 | import CBN.Subst 18 | 19 | {------------------------------------------------------------------------------- 20 | Small-step semantics 21 | -------------------------------------------------------------------------------} 22 | 23 | type Error = String 24 | 25 | -- | Description of a step: what happened? 26 | data Description = 27 | -- | We moved let-bound variables to the heap 28 | StepAlloc 29 | 30 | -- | Beta-reduction 31 | | StepBeta 32 | 33 | -- | Like beta-reduction, but apply a named function 34 | | StepApply Ptr 35 | 36 | -- | Delta-reduction 37 | | StepDelta PrimApp 38 | 39 | -- | Pattern-match 40 | | StepMatch Con 41 | 42 | -- | Evaluated conditional 43 | | StepIf Bool 44 | 45 | -- | Seq finished evaluating its left argument 46 | | StepSeq 47 | 48 | -- | We allocated constructor arguments to preserve sharing 49 | | StepAllocConArgs 50 | deriving (Show) 51 | 52 | data DescriptionWithContext = 53 | DescriptionWithContext Description Context 54 | deriving (Show) 55 | 56 | type Context = [Ptr] 57 | 58 | data Step = 59 | -- | Evaluation took a single step 60 | Step DescriptionWithContext (Heap Term, Term) 61 | 62 | -- | We have reached weak head normal form 63 | | WHNF Value 64 | 65 | -- | The evaluator got stuck 66 | | Stuck Error 67 | deriving (Show) 68 | 69 | emptyContext :: Description -> (Heap Term, Term) -> Step 70 | emptyContext descr = 71 | Step (DescriptionWithContext descr []) 72 | 73 | pushContext :: Ptr -> DescriptionWithContext -> (Heap Term, Term) -> Step 74 | pushContext ptr (DescriptionWithContext descr context) = 75 | Step (DescriptionWithContext descr (ptr:context)) 76 | 77 | -- | Single execution step (small step semantics) 78 | step :: (Heap Term, Term) -> Step 79 | step (_, TVar (Var x)) = Stuck $ "free variable " ++ show x 80 | step (_, TLam x e) = WHNF $ VLam x e 81 | step (_, TCon ces) = WHNF $ VCon ces 82 | step (_, TPrim (PrimApp p [])) = WHNF $ VPrim p 83 | step (hp, TPtr ptr) = 84 | case deref (hp, ptr) of 85 | Nothing -> let ptrs = M.keys $ heapEntries hp 86 | in 87 | Stuck $ "Invalid reference to symbol " 88 | ++ pprintPtr ptr 89 | ++ ". Valid symbol names are: " 90 | ++ show (map pprintPtr ptrs) 91 | Just p -> 92 | case step (hp, p) of 93 | Step d (hp', e') -> pushContext ptr d (mutate (hp', ptr) e', TPtr ptr) 94 | Stuck err -> Stuck err 95 | WHNF val -> WHNF val 96 | step (hp, TLet bound e) = 97 | emptyContext StepAlloc $ allocSubst bound (hp, e) 98 | step (hp, TApp e1 e2) = do 99 | let descr = case e1 of 100 | TPtr ptr -> StepApply ptr 101 | _otherwise -> StepBeta 102 | case step (hp, e1) of 103 | Step d (hp', e1') -> Step d (hp', TApp e1' e2) 104 | Stuck err -> Stuck err 105 | WHNF (VLam x e1') -> emptyContext descr $ allocSubst [(x,e2)] (hp, e1') 106 | WHNF _ -> Stuck "expected lambda" 107 | step (hp, TCase e ms) = 108 | case step (hp, e) of 109 | Step d (hp', e') -> Step d (hp', TCase e' ms) 110 | Stuck err -> Stuck err 111 | WHNF (VLam _ _) -> Stuck "cannot pattern match on lambda" 112 | WHNF (VPrim _) -> Stuck "cannot pattern match on primitive values" 113 | WHNF (VCon (ConApp c es)) -> 114 | case findMatch c ms of 115 | Nothing -> 116 | Stuck "Non-exhaustive pattern match" 117 | Just (xs, _) | length xs /= length es -> 118 | Stuck $ "Cannot match " ++ show (xs, es) 119 | Just (xs, rhs) -> 120 | -- We /know/ that e is a con-app or a pointer to a con-app, but we 121 | -- search /again/, this time with 'allocConArgs'. The reason we 122 | -- search twice is that the first search enables us to find the 123 | -- right variable names to use for allocation. This is not critical, 124 | -- but makes the variables in the heap more human-friendly. 125 | case allocConArgs xs (hp, e) of 126 | ConArgsAllocFailed -> 127 | error "step: impossible ConArgsAllocFailed" 128 | ConArgsAllocUnnecessary _ -> 129 | emptyContext (StepMatch c) $ allocSubst (zip xs es) (hp, rhs) 130 | ConArgsAllocDone (ctxt, hp', e') _ -> 131 | Step (DescriptionWithContext StepAllocConArgs ctxt) (hp', TCase e' ms) 132 | step (hp, TPrim (PrimApp p es)) = 133 | case stepPrimArgs hp es of 134 | PrimStep d hp' es' -> Step d (hp', TPrim (PrimApp p es')) 135 | PrimWHNF vs -> let descr = StepDelta (PrimApp p (map (valueToTerm . VPrim) vs)) 136 | in case delta p vs of 137 | Left err -> Stuck err 138 | Right e' -> emptyContext descr (hp, valueToTerm e') 139 | PrimStuck err -> Stuck err 140 | step (hp, TIf c t f) = 141 | case step (hp, c) of 142 | Step d (hp', c') -> Step d (hp', TIf c' t f) 143 | Stuck err -> Stuck err 144 | WHNF val | val == liftBool True -> emptyContext (StepIf True) (hp, t) 145 | | val == liftBool False -> emptyContext (StepIf False) (hp, f) 146 | | otherwise -> Stuck "expected bool" 147 | step (hp, TSeq e1 e2) = 148 | case step (hp, e1) of 149 | Step d (hp', e1') -> Step d (hp', TSeq e1' e2) 150 | Stuck err -> Stuck err 151 | WHNF _ -> emptyContext StepSeq (hp, e2) 152 | 153 | {------------------------------------------------------------------------------- 154 | Case statements 155 | -------------------------------------------------------------------------------} 156 | 157 | findMatch :: Con -> Branches -> Maybe ([Var], Term) 158 | findMatch c (Matches ms) = go ms 159 | where 160 | go :: [Match] -> Maybe ([Var], Term) 161 | go [] = Nothing 162 | go (Match (Pat c' xs) e:ms') | c == c' = Just (xs, e) 163 | | otherwise = go ms' 164 | findMatch c (Selector s) = 165 | findMatch c $ Matches [selectorMatch s] 166 | 167 | data AllocdConArgs = 168 | -- | No allocation was necessary 169 | ConArgsAllocUnnecessary ConApp 170 | 171 | -- | The constructor arguments were heap-allocated 172 | | ConArgsAllocDone (Context, Heap Term, Term) ConApp 173 | 174 | -- | The term was not a constructor application in WHNF or a pointer to 175 | -- such a term 176 | | ConArgsAllocFailed 177 | 178 | -- | Allocate constructor arguments 179 | -- 180 | -- This is necessary when doing a case statement on a value in the heap, to 181 | -- avoid losing sharing. 182 | allocConArgs :: 183 | [Var] 184 | -> (Heap Term, Term) 185 | -> AllocdConArgs 186 | allocConArgs xs = 187 | go True 188 | where 189 | go :: Bool -> (Heap Term, Term) -> AllocdConArgs 190 | go isTopLevel (hp, term) = 191 | case term of 192 | TPtr ptr | Just p <- deref (hp, ptr) -> do 193 | case go False (hp, p) of 194 | ConArgsAllocUnnecessary conApp -> 195 | ConArgsAllocUnnecessary conApp 196 | ConArgsAllocFailed -> 197 | ConArgsAllocFailed 198 | ConArgsAllocDone (ctxt, hp', e') conApp -> 199 | ConArgsAllocDone 200 | (ptr : ctxt, mutate (hp', ptr) e', TPtr ptr) 201 | conApp 202 | TCon conApp@(ConApp con args) | length args == length xs -> 203 | if isTopLevel || all termIsSimple args then 204 | ConArgsAllocUnnecessary conApp 205 | else do 206 | let (hp', args') = 207 | allocMany 208 | (zipWith prepareHeapEntry xs args) 209 | processHeapEntries 210 | hp 211 | conApp' = ConApp con args' 212 | ConArgsAllocDone ([], hp', TCon conApp') conApp' 213 | _ -> 214 | ConArgsAllocFailed 215 | 216 | prepareHeapEntry :: Var -> Term -> (Maybe String, Ptr -> (Ptr, Term)) 217 | prepareHeapEntry x t = (Just (varName x), \ptr -> (ptr, t)) 218 | 219 | processHeapEntries :: [(Ptr, Term)] -> ([(Ptr, Term)], [Term]) 220 | processHeapEntries entries = (entries, map (TPtr . fst) entries) 221 | 222 | {------------------------------------------------------------------------------- 223 | Primitive operations 224 | -------------------------------------------------------------------------------} 225 | 226 | -- | The result of stepping the arguments to an n-ary primitive function 227 | data StepPrimArgs = 228 | -- Some term took a step 229 | PrimStep DescriptionWithContext (Heap Term) [Term] 230 | 231 | -- All terms were already in WHNF 232 | | PrimWHNF [Prim] 233 | 234 | -- A term tried to take a step but got stuck 235 | | PrimStuck Error 236 | 237 | -- | Step the first argument that can step 238 | stepPrimArgs :: Heap Term -> [Term] -> StepPrimArgs 239 | stepPrimArgs hp = go [] 240 | where 241 | go :: [Prim] -> [Term] -> StepPrimArgs 242 | go acc [] = PrimWHNF (reverse acc) 243 | go acc (e:es) = 244 | case step (hp, e) of 245 | WHNF (VPrim p) -> go (p:acc) es 246 | WHNF _ -> PrimStuck "Invalid argument to primitive function" 247 | Stuck err -> PrimStuck err 248 | Step d (hp', e') -> PrimStep d hp' (acc' ++ [e'] ++ es) 249 | where 250 | acc' = map (valueToTerm . VPrim) (reverse acc) 251 | 252 | delta :: Prim -> [Prim] -> Either Error Value 253 | delta PISucc [PInt n] = Right $ liftInt $ n + 1 254 | delta PIAdd [PInt n1, PInt n2] = Right $ liftInt $ n1 + n2 255 | delta PISub [PInt n1, PInt n2] = Right $ liftInt $ n1 - n2 256 | delta PIMul [PInt n1, PInt n2] = Right $ liftInt $ n1 * n2 257 | delta PIMin [PInt n1, PInt n2] = Right $ liftInt $ n1 `min` n2 258 | delta PIMax [PInt n1, PInt n2] = Right $ liftInt $ n1 `max` n2 259 | delta PIEq [PInt n1, PInt n2] = Right $ liftBool $ n1 == n2 260 | delta PILt [PInt n1, PInt n2] = Right $ liftBool $ n1 < n2 261 | delta PILe [PInt n1, PInt n2] = Right $ liftBool $ n1 <= n2 262 | delta _op _args = Left $ "delta: cannot evaluate" 263 | 264 | -------------------------------------------------------------------------------- /src/CBN/Free.hs: -------------------------------------------------------------------------------- 1 | module CBN.Free ( 2 | Count 3 | , Free(..) 4 | , Pointers(..) 5 | ) where 6 | 7 | import Data.Map (Map) 8 | import qualified Data.Map as Map 9 | import qualified Data.Set as Set 10 | 11 | import CBN.Language 12 | import CBN.Heap 13 | import qualified CBN.Util.Map as Map 14 | 15 | type Count = Int 16 | 17 | {------------------------------------------------------------------------------- 18 | Free variables 19 | -------------------------------------------------------------------------------} 20 | 21 | -- | Compute free variables 22 | class Free a where 23 | free :: a -> Map Var Count 24 | 25 | instance Free Var where 26 | free x = Map.singleton x 1 27 | 28 | instance Free a => Free [a] where 29 | free = Map.unionsWith (+) . map free 30 | 31 | instance (Free a, Free b) => Free (a, b) where 32 | free (a, b) = Map.unionWith (+) (free a) (free b) 33 | 34 | instance Free Match where 35 | free (Match (Pat _ xs) e) = Map.deleteKeys xs $ free e 36 | 37 | instance Free ConApp where 38 | free (ConApp _ es) = free es 39 | 40 | instance Free PrimApp where 41 | free (PrimApp _ es) = free es 42 | 43 | instance Free Term where 44 | free (TVar x) = free x 45 | free (TApp e1 e2) = free [e1, e2] 46 | free (TLam x e) = Map.delete x $ free e 47 | free (TPtr _) = Map.empty 48 | free (TCon ces) = free ces 49 | free (TCase e ms) = free (e, ms) 50 | free (TLet bound e2) = Map.filterWithKey (\x _ -> x `notElem` map fst bound) $ 51 | free (map snd bound, e2) 52 | free (TPrim pes) = free pes 53 | free (TIf c t f) = free [c, t, f] 54 | free (TSeq e1 e2) = free [e1, e2] 55 | 56 | instance Free Branches where 57 | free (Matches ms) = free ms 58 | free (Selector s) = free s 59 | 60 | instance Free Selector where 61 | free _ = Map.empty 62 | 63 | {------------------------------------------------------------------------------- 64 | Used pointers 65 | -------------------------------------------------------------------------------} 66 | 67 | instance Pointers Ptr where 68 | pointers = Set.singleton 69 | 70 | instance Pointers a => Pointers [a] where 71 | pointers = Set.unions . map pointers 72 | 73 | instance (Pointers a, Pointers b) => Pointers (a, b) where 74 | pointers (a, b) = Set.union (pointers a) (pointers b) 75 | 76 | instance Pointers Match where 77 | pointers (Match _pat e) = pointers e 78 | 79 | instance Pointers ConApp where 80 | pointers (ConApp _ es) = pointers es 81 | 82 | instance Pointers PrimApp where 83 | pointers (PrimApp _ es) = pointers es 84 | 85 | instance Pointers Term where 86 | pointers (TVar _) = Set.empty 87 | pointers (TApp e1 e2) = pointers [e1, e2] 88 | pointers (TLam _ e) = pointers e 89 | pointers (TPtr ptr) = pointers ptr 90 | pointers (TCon ces) = pointers ces 91 | pointers (TCase e ms) = pointers (e, ms) 92 | pointers (TLet bound e) = pointers (map snd bound, e) 93 | pointers (TPrim pes) = pointers pes 94 | pointers (TIf c t f) = pointers [c, t, f] 95 | pointers (TSeq e1 e2) = pointers [e1, e2] 96 | 97 | instance Pointers Branches where 98 | pointers (Matches ms) = pointers ms 99 | pointers (Selector s) = pointers s 100 | 101 | instance Pointers Selector where 102 | pointers _ = Set.empty 103 | 104 | -------------------------------------------------------------------------------- /src/CBN/Heap.hs: -------------------------------------------------------------------------------- 1 | -- | Heap 2 | -- 3 | -- Intended for unqualified import 4 | module CBN.Heap ( 5 | -- * Heap 6 | Ptr(..) 7 | , Heap(..) 8 | , emptyHeap 9 | , deref 10 | , alloc 11 | , allocMany 12 | , mutate 13 | , initHeap 14 | , pprintPtr 15 | -- * Garbage collection 16 | , Pointers(..) 17 | , markAndSweep 18 | ) where 19 | 20 | import Data.Data (Data) 21 | import Data.Map (Map) 22 | import Data.Maybe (fromJust) 23 | import Data.Set (Set) 24 | import Data.Graph (Graph) 25 | import qualified Data.Foldable as Foldable 26 | import qualified Data.Map as Map 27 | import qualified Data.Set as Set 28 | import qualified Data.Graph as Graph 29 | 30 | {------------------------------------------------------------------------------- 31 | Heap 32 | -------------------------------------------------------------------------------} 33 | 34 | -- | Heap pointer 35 | -- 36 | -- To improve readability, we keep an optional name for pointers that correspond 37 | -- to variables in the user's code. 38 | -- 39 | -- The @Int@ part is intentionally first so that pointers introduced earlier 40 | -- will be sorted first, independent of their name. This keeps the display of 41 | -- the heap in chronological order. 42 | -- 43 | -- The @Int@ part becauses we don't use it for elements added to the initial 44 | -- heap. 45 | data Ptr = Ptr (Maybe Int) (Maybe String) 46 | deriving (Show, Eq, Ord, Data) 47 | 48 | pprintPtr :: Ptr -> String 49 | pprintPtr (Ptr _ Nothing) = "" 50 | pprintPtr (Ptr Nothing (Just s)) = "@" ++ s 51 | pprintPtr (Ptr (Just _) (Just s)) = s 52 | 53 | -- | Heap 54 | -- 55 | -- NOTE: We will use the convention that if a particular term or pointer is 56 | -- to be interpreted in a specific heap, we will tuple the two. 57 | data Heap a = Heap { 58 | -- | Next available pointer 59 | -- 60 | -- We separately store the next available heap pointer, because when we 61 | -- do garbage collection working out which pointer is available is 62 | -- non-trivial. It's less confusing as well when pointers are never reused. 63 | heapNextAvailable :: Int 64 | 65 | -- | The actual entries on the heap 66 | , heapEntries :: Map Ptr a 67 | } 68 | deriving (Show) 69 | 70 | emptyHeap :: Heap a 71 | emptyHeap = Heap 0 Map.empty 72 | 73 | -- | Allocate a new value on the heap 74 | -- 75 | -- The value is allowed to depend on the new heap pointer. 76 | alloc :: forall a. Maybe String -> Heap a -> (Ptr -> a) -> (Heap a, Ptr) 77 | alloc name hp e = 78 | allocMany [(name, \ptr -> (ptr, e ptr))] aux hp 79 | where 80 | aux :: [(Ptr, a)] -> ([(Ptr, a)], Ptr) 81 | aux [(ptr, a)] = ([(ptr, a)], ptr) 82 | aux _ = error "alloc: impossible" 83 | 84 | -- | Generalization of 'alloc' to multiple bindings 85 | -- 86 | -- This signature is carefully constructed such the allocation for each binding 87 | -- can affect /all/ other bindings 88 | allocMany :: forall a b r. 89 | [(Maybe String, Ptr -> b)] -- ^ New entries (with to-be-allocated pointers) 90 | -> ([b] -> ([(Ptr, a)], r)) -- ^ Process all bindings at once 91 | -> Heap a -> (Heap a, r) 92 | allocMany toAlloc procAllBindings (Heap next hp) = ( 93 | Heap { 94 | heapNextAvailable = next + length newEntries 95 | , heapEntries = Map.union (Map.fromList newEntries) hp 96 | } 97 | , result 98 | ) 99 | where 100 | newEntries :: [(Ptr, a)] 101 | result :: r 102 | (newEntries, result) = 103 | procAllBindings $ zipWith aux toAlloc [next..] 104 | where 105 | aux :: (Maybe String, Ptr -> b) -> Int -> b 106 | aux (name, f) n = f $ Ptr (Just n) name 107 | 108 | deref :: (Heap a, Ptr) -> Maybe a 109 | deref (Heap _ hp, ptr) = Map.lookup ptr hp 110 | 111 | mutate :: (Heap a, Ptr) -> a -> Heap a 112 | mutate (Heap next hp, ptr) term = Heap next (Map.insert ptr term hp) 113 | 114 | initHeap :: [(String, a)] -> Heap a 115 | initHeap = Heap 0 . Map.fromList . map aux 116 | where 117 | aux :: (String, a) -> (Ptr, a) 118 | aux (name, a) = (Ptr Nothing (Just name), a) 119 | 120 | {------------------------------------------------------------------------------- 121 | Garbage collection 122 | -------------------------------------------------------------------------------} 123 | 124 | class Pointers a where 125 | pointers :: a -> Set Ptr 126 | 127 | -- | Find all reachable pointers given a set of roots 128 | mark :: Pointers a => Set Ptr -> Heap a -> Set Ptr 129 | mark roots heap = 130 | let (gr, toPtr, toVertex) = toGraph heap 131 | in Set.fromList $ map toPtr 132 | $ concatMap Foldable.toList 133 | $ Graph.dfs gr (map toVertex (Set.toList roots)) 134 | 135 | -- | Given a set of reachable pointers, remove all unreachable pointers 136 | -- 137 | -- Entries from the prelude are never collected (are always considered to 138 | -- be reachable). 139 | -- 140 | -- Returns the new heap and the set of removed pointers 141 | sweep :: Show a => Set Ptr -> Heap a -> (Heap a, Set Ptr) 142 | sweep reachable (Heap next hp) = ( 143 | Heap next $ Map.filterWithKey (\ptr _a -> isReachable ptr) hp 144 | , Set.filter (not . isReachable) $ Map.keysSet hp 145 | ) 146 | where 147 | isReachable :: Ptr -> Bool 148 | isReachable (Ptr Nothing _) = True 149 | isReachable ptr = ptr `Set.member` reachable 150 | 151 | -- | Mark-and-sweep garbage collection given a set of roots 152 | -- 153 | -- Returns the new heap as well as the set of removed pointers 154 | markAndSweep :: (Pointers a, Show a) => Set Ptr -> Heap a -> (Heap a, Set Ptr) 155 | markAndSweep roots hp = sweep (mark roots hp) hp 156 | 157 | {------------------------------------------------------------------------------- 158 | Auxiliary 159 | -------------------------------------------------------------------------------} 160 | 161 | -- | Build an explicit graph representation of the heap 162 | toGraph :: forall a. Pointers a 163 | => Heap a -> (Graph, Graph.Vertex -> Ptr, Ptr -> Graph.Vertex) 164 | toGraph (Heap _ hp) = 165 | let (graph, f, g) = Graph.graphFromEdges edges 166 | in ( graph 167 | , \v -> case f v of ((), ptr, _ptrs) -> ptr 168 | , fromJust . g 169 | ) 170 | where 171 | edges :: [((), Ptr, [Ptr])] 172 | edges = map mkEdge (Map.toList hp) 173 | 174 | mkEdge :: (Ptr, a) -> ((), Ptr, [Ptr]) 175 | mkEdge (ptr, a) = ((), ptr, Set.toList (pointers a)) 176 | -------------------------------------------------------------------------------- /src/CBN/InlineHeap.hs: -------------------------------------------------------------------------------- 1 | module CBN.InlineHeap (inlineHeap) where 2 | 3 | import Data.Bifunctor 4 | import Data.Set (Set) 5 | import Data.List (partition) 6 | 7 | import qualified Data.Map as Map 8 | import qualified Data.Set as Set 9 | 10 | import CBN.Heap 11 | import CBN.Language 12 | import CBN.Subst 13 | 14 | {------------------------------------------------------------------------------- 15 | Simplification 16 | 17 | We only heap allocate non-simple terms, to keep things readable. However, 18 | during evaluation previously heap-allocated terms may /become/ simple. If 19 | simplification is enabled, we then "remove" these from the heap by inlining 20 | them. 21 | -------------------------------------------------------------------------------} 22 | 23 | inlineHeap :: Heap Term -> Term -> (Heap Term, Term, Set Ptr) 24 | inlineHeap (Heap next entries) e = ( 25 | Heap { 26 | heapNextAvailable = next 27 | , heapEntries = Map.fromList $ 28 | map (second (substPtrs toInline)) toKeep 29 | } 30 | , substPtrs toInline e 31 | , Set.fromList $ map fst toInline 32 | ) 33 | where 34 | toInline, toKeep :: [(Ptr, Term)] 35 | (toInline, toKeep) = partition (canInline . snd) (Map.toList entries) 36 | 37 | canInline :: Term -> Bool 38 | canInline TVar{} = False 39 | canInline TApp{} = False 40 | canInline TLam{} = False 41 | canInline TLet{} = False 42 | canInline TPtr{} = True 43 | canInline TCase{} = False 44 | canInline TIf{} = False 45 | canInline TSeq{} = False 46 | canInline (TPrim (PrimApp _ es)) = null es -- if args then is application 47 | canInline (TCon (ConApp _ es)) = all canInline es -------------------------------------------------------------------------------- /src/CBN/Language.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | module CBN.Language ( 3 | -- * Variables 4 | Var(..) 5 | -- * Terms 6 | , Con(..) 7 | , Pat(..) 8 | , Match(..) 9 | , Prim(..) 10 | , ConApp(..) 11 | , PrimApp(..) 12 | , Term(..) 13 | , Branches(..) 14 | , Selector(..) 15 | -- * Classification 16 | , termIsSimple 17 | -- * Interpretation of selectors 18 | , selectorCon 19 | , selectorVars 20 | , selectorIndex 21 | , selectorMatch 22 | -- * Values 23 | , Value(..) 24 | , valueToTerm 25 | -- * Auxiliary 26 | , nTApp 27 | , collectArgs 28 | -- * Lifting from the meta language to the object language 29 | , liftInt 30 | , liftBool 31 | ) where 32 | 33 | import Data.Bifunctor 34 | import Data.Data (Data(..)) 35 | import Data.String (IsString) 36 | 37 | import CBN.Heap 38 | import CBN.Util.Snoc (Snoc) 39 | 40 | import qualified CBN.Util.Snoc as Snoc 41 | 42 | {------------------------------------------------------------------------------- 43 | Variables 44 | -------------------------------------------------------------------------------} 45 | 46 | -- | Variable 47 | newtype Var = Var { varName :: String } 48 | deriving (Show, Data, Eq, Ord, IsString) 49 | 50 | {------------------------------------------------------------------------------- 51 | Terms 52 | -------------------------------------------------------------------------------} 53 | 54 | -- | Constructor name 55 | newtype Con = Con { conName :: String } 56 | deriving (Show, Data, Eq, Ord) 57 | 58 | -- | Pattern 59 | data Pat = Pat Con [Var] 60 | deriving (Show, Data, Eq) 61 | 62 | -- | A single match in a case statement 63 | data Match = Match Pat Term 64 | deriving (Show, Data, Eq) 65 | 66 | -- | Primitives 67 | data Prim = 68 | PInt Integer 69 | | PISucc 70 | | PIAdd 71 | | PISub 72 | | PIMul 73 | | PIMin 74 | | PIMax 75 | | PIEq 76 | | PILt 77 | | PILe 78 | deriving (Show, Data, Eq) 79 | 80 | -- | Application of a constructor to some arguments 81 | data ConApp = ConApp Con [Term] 82 | deriving (Show, Data, Eq) 83 | 84 | -- | Application of a primitive to some arguments 85 | data PrimApp = PrimApp Prim [Term] 86 | deriving (Show, Data, Eq) 87 | 88 | -- | Term 89 | data Term = 90 | TVar Var -- ^ Variable 91 | | TApp Term Term -- ^ Application 92 | | TLam Var Term -- ^ Lambda abstraction 93 | | TLet [(Var, Term)] Term -- ^ (Mutually recursive) let binding 94 | | TPtr Ptr -- ^ Heap pointer 95 | | TCon ConApp -- ^ Constructor application 96 | | TCase Term Branches -- ^ Pattern match 97 | | TPrim PrimApp -- ^ Primitives (built-ins) 98 | | TIf Term Term Term -- ^ Conditional 99 | | TSeq Term Term -- ^ Force evaluation 100 | deriving (Show, Data, Eq) 101 | 102 | -- | Branches of a case statement 103 | data Branches = 104 | -- | User-defined branches (normal case statement) 105 | Matches [Match] 106 | 107 | -- | Selector 108 | | Selector Selector 109 | deriving (Show, Data, Eq) 110 | 111 | -- | Selectors 112 | data Selector = 113 | Fst 114 | | Snd 115 | deriving (Show, Data, Eq) 116 | 117 | {------------------------------------------------------------------------------- 118 | Classification 119 | -------------------------------------------------------------------------------} 120 | 121 | -- | Is this a "simple" term? 122 | -- 123 | -- A simple term is one that we can substitute freely, even if multiple times, 124 | -- without losing sharing. 125 | termIsSimple :: Term -> Bool 126 | termIsSimple (TPtr _) = True 127 | termIsSimple (TCon (ConApp _ [])) = True 128 | termIsSimple (TPrim (PrimApp _ [])) = True 129 | termIsSimple _ = False 130 | 131 | {------------------------------------------------------------------------------- 132 | Interpretation of selectors 133 | -------------------------------------------------------------------------------} 134 | 135 | -- | Constructor name this selector matches against 136 | selectorCon :: Selector -> Con 137 | selectorCon Fst = Con "Pair" 138 | selectorCon Snd = Con "Pair" 139 | 140 | -- | Variable names for the implied case statement of this selector 141 | selectorVars :: Selector -> [Var] 142 | selectorVars Fst = [Var "x", Var "y"] 143 | selectorVars Snd = [Var "x", Var "y"] 144 | 145 | -- | Which argument does this selector extract? 146 | selectorIndex :: Selector -> Int 147 | selectorIndex Fst = 0 148 | selectorIndex Snd = 1 149 | 150 | selectorMatch :: Selector -> Match 151 | selectorMatch s = 152 | Match 153 | (Pat (selectorCon s) (selectorVars s)) 154 | (TVar $ selectorVars s !! selectorIndex s) 155 | 156 | {------------------------------------------------------------------------------- 157 | Values 158 | -------------------------------------------------------------------------------} 159 | 160 | -- | Values (terms in weak head normal form) 161 | data Value = 162 | -- | Lambda abstractions are values 163 | VLam Var Term 164 | 165 | -- | Constructor applications are values 166 | | VCon ConApp 167 | 168 | -- | Primitive values are values 169 | -- 170 | -- Note that an application of a primitive value to some term is NOT a 171 | -- value: primitive functions are assumed strict in all arguments 172 | | VPrim Prim 173 | deriving (Show, Eq) 174 | 175 | valueToTerm :: Value -> Term 176 | valueToTerm (VLam x e) = TLam x e 177 | valueToTerm (VCon ces) = TCon ces 178 | valueToTerm (VPrim p) = TPrim (PrimApp p []) 179 | 180 | {------------------------------------------------------------------------------- 181 | Auxiliary 182 | -------------------------------------------------------------------------------} 183 | 184 | -- | n-ary application 185 | nTApp :: [Term] -> Term 186 | nTApp = go . Snoc.fromList 187 | where 188 | go :: Snoc Term -> Term 189 | go Snoc.Nil = error "impossible" 190 | go (Snoc.Cons Snoc.Nil t) = t 191 | go (Snoc.Cons ts t) = go ts `TApp` t 192 | 193 | -- | Collect all arguments for a lambda application 194 | -- (as if we had n-ary lambdas) 195 | collectArgs :: Term -> ([Var], Term) 196 | collectArgs (TLam x e) = first (x:) $ collectArgs e 197 | collectArgs e = ([], e) 198 | 199 | {------------------------------------------------------------------------------- 200 | Lifting from Haskell to our object language 201 | -------------------------------------------------------------------------------} 202 | 203 | liftInt :: Integer -> Value 204 | liftInt = VPrim . PInt 205 | 206 | liftBool :: Bool -> Value 207 | liftBool True = VCon $ ConApp (Con "True") [] 208 | liftBool False = VCon $ ConApp (Con "False") [] 209 | -------------------------------------------------------------------------------- /src/CBN/Options.hs: -------------------------------------------------------------------------------- 1 | module CBN.Options ( 2 | Options(..) 3 | , getOptions 4 | ) where 5 | 6 | import Options.Applicative 7 | import CBN.Trace 8 | 9 | data Options = Options { 10 | optionsInput :: FilePath 11 | , optionsShowTrace :: Bool 12 | , optionsGC :: Bool 13 | , optionsSelThunkOpt :: Bool 14 | , optionsInlineHeap :: Bool 15 | , optionsSummarize :: SummarizeOptions 16 | , optionsJsOutput :: Maybe FilePath 17 | , optionsJsName :: String 18 | , optionsGraphOutput :: Maybe FilePath 19 | , optionsGraphTermsOutput :: Maybe FilePath 20 | , optionsDisableAnsi :: Bool 21 | } 22 | deriving (Show) 23 | 24 | getOptions :: IO Options 25 | getOptions = execParser $ info (helper <*> parseOptions) fullDesc 26 | 27 | parseOptions :: Parser Options 28 | parseOptions = Options 29 | <$> (strOption $ mconcat [ 30 | short 'i' 31 | , help "Input file" 32 | , metavar "INPUT-FILE" 33 | ]) 34 | <*> (switch $ mconcat [ 35 | long "show-trace" 36 | , help "Write trace to console" 37 | ]) 38 | <*> (switch $ mconcat [ 39 | long "gc" 40 | , help "GC after each step" 41 | ]) 42 | <*> (switch $ mconcat [ 43 | long "selector-thunk-opt" 44 | , help "Enable the selector thunk optimization" 45 | ]) 46 | <*> (switch $ mconcat [ 47 | long "inline-heap" 48 | , help "Simplify the heap by inlining simple terms after each step" 49 | ]) 50 | <*> parseSummarizeOptions 51 | <*> (optional . strOption $ mconcat [ 52 | long "javascript" 53 | , help "Generate JavaScript output" 54 | , metavar "JS-FILE" 55 | ]) 56 | <*> (strOption $ mconcat [ 57 | long "javascript-function" 58 | , help "Function name prefix in the JavaScript output" 59 | , metavar "JS-NAME" 60 | , showDefault 61 | , value "cbn" 62 | ]) 63 | <*> (optional . strOption $ mconcat [ 64 | long "graph" 65 | , help "Generate a graph output in dot format" 66 | , metavar "GRAPH-FILE" 67 | ]) 68 | <*> (optional . strOption $ mconcat [ 69 | long "heap-graph" 70 | , help "Generate one graph representation file for each step" 71 | , metavar "PATH/FILES-PREFIX" 72 | ]) 73 | <*> (switch $ mconcat [ 74 | long "disable-ansi" 75 | , help "Disable ANSI escapes codes for terminal output (no color)" 76 | ]) 77 | 78 | parseSummarizeOptions :: Parser SummarizeOptions 79 | parseSummarizeOptions = SummarizeOptions 80 | <$> (switch $ mconcat [ 81 | long "collapse-beta" 82 | , help "Collapse adjacent beta steps" 83 | ]) 84 | <*> (option auto $ mconcat [ 85 | long "max-num-steps" 86 | , help "Maximum number of steps" 87 | , showDefault 88 | , value 1000 89 | , metavar "N" 90 | ]) 91 | <*> (optional $ option auto $ mconcat [ 92 | long "hide-prelude" 93 | , metavar "STEP" 94 | , help "Hide the prelude from the help from the given step" 95 | ]) 96 | <*> (many $ option str $ mconcat [ 97 | long "hide-term" 98 | , help "Hide specific term from the prelude (can be used multiple times)" 99 | ]) 100 | <*> (switch $ mconcat [ 101 | long "hide-gc" 102 | , help "Hide GC steps" 103 | ]) 104 | <*> (switch $ mconcat [ 105 | long "hide-selector-thunk-opt" 106 | , help "Hide steps where the selector thunk optimization gets applied" 107 | ]) 108 | <*> (switch $ mconcat [ 109 | long "hide-inlining" 110 | , help "Hide heap inlining steps" 111 | ]) 112 | -------------------------------------------------------------------------------- /src/CBN/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 2 | module CBN.Parser ( 3 | parseTerm 4 | , parseModule 5 | , term 6 | , parseIO 7 | ) where 8 | 9 | import Control.Exception 10 | import Control.Monad 11 | import Data.Bifunctor 12 | import Data.Foldable (asum) 13 | import Language.Haskell.TH (Q) 14 | import Language.Haskell.TH.Quote 15 | import Text.Parsec 16 | import Text.Parsec.Language (haskellDef) 17 | import Text.Parsec.Pos (newPos) 18 | import Text.Parsec.String 19 | 20 | import qualified Language.Haskell.TH as TH 21 | import qualified Text.Parsec.Token as P 22 | 23 | import CBN.Language 24 | import CBN.Heap 25 | 26 | {------------------------------------------------------------------------------- 27 | Quasi-quotation 28 | -------------------------------------------------------------------------------} 29 | 30 | term :: QuasiQuoter 31 | term = QuasiQuoter { 32 | quoteExp = \str -> do 33 | l <- location 34 | c <- TH.runIO $ parseIO "splice" (setPosition l *> parseTerm) str 35 | dataToExpQ (const Nothing) c 36 | , quotePat = undefined 37 | , quoteType = undefined 38 | , quoteDec = undefined 39 | } 40 | 41 | {------------------------------------------------------------------------------- 42 | Individual parsers 43 | -------------------------------------------------------------------------------} 44 | 45 | parseVar :: Parser Var 46 | parseVar = Var <$> identifier "variable" 47 | 48 | parseCon :: Parser Con 49 | parseCon = (lexeme $ mkCon <$> upper <*> many alphaNum) "constructor" 50 | where 51 | mkCon x xs = Con (x:xs) 52 | 53 | parsePat :: Parser Pat 54 | parsePat = Pat <$> parseCon <*> many parseVar 55 | 56 | parseMatch :: Parser Match 57 | parseMatch = Match <$> parsePat <* reservedOp "->" <*> parseTerm 58 | 59 | -- | Parse a pointer 60 | -- 61 | -- The only pointers we expect in initial terms are ones that refer to the 62 | -- initial heap (the prelude) 63 | parsePtr :: Parser Ptr 64 | parsePtr = mkPtr <$ char '@' <*> identifier 65 | where 66 | mkPtr name = Ptr Nothing (Just name) 67 | 68 | parseConApp :: Parser ConApp 69 | parseConApp = ConApp <$> parseCon <*> many parseTermNoApp 70 | 71 | parsePrimApp :: Parser PrimApp 72 | parsePrimApp = PrimApp <$> parsePrim <*> many parseTermNoApp 73 | 74 | parseTerm :: Parser Term 75 | parseTerm = msum [ 76 | TCon <$> parseConApp 77 | , TPrim <$> parsePrimApp 78 | , TSeq <$ reservedOp "seq" <*> parseTermNoApp <*> parseTermNoApp 79 | , nTApp <$> many1 parseTermNoApp 80 | ] "term" 81 | 82 | -- | Parser for terms without allowing for top-level application 83 | parseTermNoApp :: Parser Term 84 | parseTermNoApp = msum [ 85 | unaryTPrim <$> parsePrim 86 | , unaryTCon <$> parseCon 87 | , TPtr <$> parsePtr 88 | , TLam <$ reservedOp "\\" 89 | <*> parseVar 90 | <* reservedOp "->" 91 | <*> parseTerm 92 | , TLet <$ reserved "let" 93 | <*> parseLetBound 94 | <* reservedOp "in" 95 | <*> parseTerm 96 | , TIf <$ reserved "if" 97 | <*> parseTerm 98 | <* reserved "then" 99 | <*> parseTerm 100 | <* reserved "else" 101 | <*> parseTerm 102 | , case1 <$ reserved "case" 103 | <*> parseTerm 104 | <* reserved "of" 105 | <*> braces (parseMatch `sepBy` reservedOp ";") 106 | , case2 <$> parseSelector 107 | <*> parseTerm 108 | , TVar <$> parseVar 109 | , parens parseTerm 110 | ] 111 | where 112 | unaryTPrim :: Prim -> Term 113 | unaryTPrim p = TPrim (PrimApp p []) 114 | 115 | unaryTCon :: Con -> Term 116 | unaryTCon c = TCon (ConApp c []) 117 | 118 | case1 :: Term -> [Match] -> Term 119 | case1 t ms = TCase t (Matches ms) 120 | 121 | case2 :: Selector -> Term -> Term 122 | case2 s t = TCase t (Selector s) 123 | 124 | parseSelector :: Parser Selector 125 | parseSelector = msum [ 126 | Fst <$ reserved "fst" 127 | , Snd <$ reserved "snd" 128 | ] 129 | 130 | parseLetBound :: Parser [(Var, Term)] 131 | parseLetBound = asum [ 132 | (:[]) <$> parseOne 133 | , braces (parseOne `sepBy` reservedOp ";") 134 | ] 135 | where 136 | parseOne :: Parser (Var, Term) 137 | parseOne = 138 | (,) <$> parseVar 139 | <* reservedOp "=" 140 | <*> parseTerm 141 | 142 | parsePrim :: Parser Prim 143 | parsePrim = msum [ 144 | PInt <$> natural 145 | , PISucc <$ reserved "succ" 146 | , PIAdd <$ reserved "add" 147 | , PISub <$ reserved "sub" 148 | , PIMul <$ reserved "mul" 149 | , PIMin <$ reserved "min" 150 | , PIMax <$ reserved "max" 151 | , PILt <$ reserved "lt" 152 | , PIEq <$ reserved "eq" 153 | , PILe <$ reserved "le" 154 | ] 155 | 156 | -- | Our input files consist of an initial heap and the term to be evaluated 157 | parseModule :: Parser (Heap Term, Term) 158 | parseModule = (,) <$> (mkHeap <$> many parseFunDef) <*> parseMain 159 | where 160 | parseFunDef :: Parser (Var, Term) 161 | parseFunDef = (,) <$> parseVar 162 | <* reservedOp "=" 163 | <*> parseTermNoApp 164 | "function definition" 165 | 166 | parseMain :: Parser Term 167 | parseMain = reserved "main" >> reservedOp "=" *> parseTerm 168 | 169 | mkHeap :: [(Var, Term)] -> Heap Term 170 | mkHeap = initHeap . map (first varName) 171 | 172 | {------------------------------------------------------------------------------- 173 | Lexical analysis 174 | -------------------------------------------------------------------------------} 175 | 176 | lexer = P.makeTokenParser haskellDef { 177 | P.reservedNames = [ 178 | "case" 179 | , "of" 180 | , "let" 181 | , "in" 182 | , "succ" 183 | , "add" 184 | , "sub" 185 | , "mul" 186 | , "max" 187 | , "lt" 188 | , "eq" 189 | , "le" 190 | , "if" 191 | , "then" 192 | , "else" 193 | , "main" 194 | , "seq" 195 | , "fst" 196 | , "snd" 197 | ] 198 | , P.reservedOpNames = [ 199 | "\\" 200 | , "->" 201 | , ";" 202 | , "@" 203 | , "=" 204 | ] 205 | } 206 | 207 | braces = P.braces lexer 208 | identifier = P.identifier lexer 209 | lexeme = P.lexeme lexer 210 | natural = P.natural lexer 211 | parens = P.parens lexer 212 | reservedOp = P.reservedOp lexer 213 | reserved = P.reserved lexer 214 | whiteSpace = P.whiteSpace lexer 215 | 216 | {------------------------------------------------------------------------------- 217 | Auxiliary 218 | -------------------------------------------------------------------------------} 219 | 220 | parseTopLevel :: Parser a -> Parser a 221 | parseTopLevel p = whiteSpace *> p <* eof 222 | 223 | parseIO :: String -> Parser a -> String -> IO a 224 | parseIO input p str = 225 | case parse (parseTopLevel p) input str of 226 | Left err -> throwIO (userError (show err)) 227 | Right a -> return a 228 | 229 | location :: Q SourcePos 230 | location = aux <$> TH.location 231 | where 232 | aux :: TH.Loc -> SourcePos 233 | aux loc = uncurry (newPos (TH.loc_filename loc)) (TH.loc_start loc) 234 | -------------------------------------------------------------------------------- /src/CBN/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module CBN.Pretty (ToDoc, toDoc, heapToDoc) where 3 | 4 | import Data.List (intersperse) 5 | import Data.Set (Set) 6 | 7 | import qualified Data.Map as Map 8 | import qualified Data.Set as Set 9 | 10 | import CBN.Closure 11 | import CBN.Eval 12 | import CBN.Heap 13 | import CBN.Language 14 | import CBN.Pretty.Precedence as P 15 | import CBN.Util.Doc 16 | import CBN.Util.Doc.Style 17 | 18 | class ToDoc a where 19 | toDoc :: a -> Doc Style String 20 | toDoc = toDoc' Top 21 | 22 | toDoc' :: FixityContext -> a -> Doc Style String 23 | toDoc' _fc = toDoc 24 | 25 | -- | For convenience, 'ToDoc' is idempotent 26 | instance ToDoc (Doc Style String) where 27 | toDoc = id 28 | 29 | instance ToDoc Var where 30 | toDoc (Var x) = style (\st -> st { styleItalic = True }) $ doc x 31 | 32 | instance ToDoc Con where 33 | toDoc (Con "Nil") = doc "[]" 34 | toDoc (Con "Unit") = doc "()" 35 | toDoc (Con c) = style (\st -> st { styleForeground = Just Red }) $ doc c 36 | 37 | instance ToDoc Prim where 38 | toDoc (PInt n) = doc (show n) 39 | toDoc PISucc = doc "succ" 40 | toDoc PIAdd = doc "add" 41 | toDoc PISub = doc "sub" 42 | toDoc PIMul = doc "mul" 43 | toDoc PIMin = doc "min" 44 | toDoc PIMax = doc "max" 45 | toDoc PIEq = doc "eq" 46 | toDoc PILt = doc "lt" 47 | toDoc PILe = doc "le" 48 | 49 | instance ToDoc PrimApp where 50 | toDoc' fc (PrimApp PIAdd [a, b]) = parensIf (needsParens fc Add) $ 51 | toDoc' (L Add) a <+> doc "+" <+> toDoc' (R Add) b 52 | toDoc' fc (PrimApp PISub [a, b]) = parensIf (needsParens fc Sub) $ 53 | toDoc' (L Sub) a <+> doc "-" <+> toDoc' (R Sub) b 54 | toDoc' fc (PrimApp PIMul [a, b]) = parensIf (needsParens fc Mul) $ 55 | toDoc' (L Mul) a <+> doc "*" <+> toDoc' (R Mul) b 56 | toDoc' fc (PrimApp PILe [a, b]) = parensIf (needsParens fc Le) $ 57 | toDoc' (L Le) a <+> doc "<=" <+> toDoc' (R Le) b 58 | toDoc' fc (PrimApp PILt [a, b]) = parensIf (needsParens fc Lt) $ 59 | toDoc' (L Lt) a <+> doc "<" <+> toDoc' (R Lt) b 60 | toDoc' fc (PrimApp PIEq [a, b]) = parensIf (needsParens fc Eq) $ 61 | toDoc' (L Eq) a <+> doc "==" <+> toDoc' (R Eq) b 62 | toDoc' fc (PrimApp p es) = parensIf (needsParens fc P.Ap && not (null es)) $ 63 | hsep (toDoc p : map (toDoc' (R P.Ap)) es) 64 | 65 | instance ToDoc ConApp where 66 | toDoc' fc (ConApp (Con "Cons") [x, xs]) = parensIf (needsParens fc Cons) $ 67 | toDoc' (L Cons) x <+> doc ":" <+> toDoc' (R Cons) xs 68 | toDoc' _fc (ConApp (Con "Pair") [x, xs]) = parensIf True $ 69 | toDoc' Top x <> doc "," <+> toDoc' Top xs 70 | toDoc' fc (ConApp c es) = parensIf (needsParens fc P.Ap && not (null es)) $ 71 | hsep (toDoc c : map (toDoc' (R P.Ap)) es) 72 | 73 | instance ToDoc Pat where 74 | toDoc (Pat (Con "Cons") [x, xs]) = 75 | toDoc x <> doc ":" <> toDoc xs 76 | toDoc (Pat (Con "Pair") [x, xs]) = parensIf True $ 77 | toDoc x <> doc "," <+> toDoc xs 78 | toDoc (Pat c xs) = 79 | hsep (toDoc c : map toDoc xs) 80 | 81 | instance ToDoc Match where 82 | toDoc' fc = mconcat . matchRow fc 83 | 84 | -- | Table-row for a match statement 85 | -- 86 | -- Used when using a vertical layout for a case statement 87 | matchRow :: FixityContext -> Match -> [Doc Style String] 88 | matchRow fc (Match p rhs) = [toDoc p, doc " -> ", toDoc' fc rhs] 89 | 90 | -- | Table-row for a multiple-binder let statement 91 | letRow :: (Var, Term) -> [Doc Style String] 92 | letRow (x, t) = [toDoc x, doc " = ", toDoc t] 93 | 94 | -- | We make elements from the prelude blue 95 | instance ToDoc Ptr where 96 | toDoc (Ptr Nothing Nothing) = error "invalid pointer" 97 | toDoc (Ptr (Just n) Nothing) = doc (show n) 98 | toDoc (Ptr Nothing (Just name)) = style (\st -> st { styleForeground = Just Blue }) 99 | $ doc name 100 | toDoc (Ptr (Just n) (Just name)) = doc name <> doc "_" <> doc (show n) 101 | 102 | instance ToDoc Term where 103 | toDoc' _ (TVar x) = toDoc x 104 | toDoc' _ (TPtr n) = toDoc n 105 | toDoc' fc (TPrim pes ) = toDoc' fc pes 106 | toDoc' fc (TCon ces) = toDoc' fc ces 107 | 108 | -- special case for @bind e1 (\x -> e2)@ 109 | toDoc' fc (TApp (TApp (TPtr bind@(Ptr Nothing (Just "bind"))) e1) (TLam x e2)) = 110 | parensIfChoice (needsParens fc P.Ap) $ [ 111 | stack [ 112 | toDoc bind <+> toDoc' (R P.Ap) e1 <+> doc "(\\" <> toDoc x <+> doc "->" 113 | , toDoc' (R Lam) e2 <> doc ")" 114 | ] 115 | ] 116 | 117 | -- standard rendering 118 | toDoc' fc (TApp e1 e2) = parensIf (needsParens fc P.Ap) $ 119 | toDoc' (L P.Ap) e1 <+> toDoc' (R P.Ap) e2 120 | toDoc' fc (TSeq e1 e2) = parensIf (needsParens fc P.Ap) $ 121 | kw "seq" <+> toDoc' (R P.Ap) e1 <+> toDoc' (R P.Ap) e2 122 | toDoc' fc (TLam x e) = parensIf (needsParens fc Lam) $ 123 | doc "\\" <> hsep (map toDoc (x:xs)) <+> doc "->" <+> toDoc' (R Lam) e' 124 | where 125 | (xs, e') = collectArgs e 126 | toDoc' fc (TLet [(x, e1)] e2) = parensIfChoice (needsParens fc Let) [ 127 | stack [ 128 | kw "let" <+> x' <+> doc "=" <+> e1' <+> kw "in" 129 | , e2' 130 | ] 131 | , kw "let" <+> x' <+> doc "=" <+> e1' <+> kw "in" <+> e2' 132 | ] 133 | where 134 | x' = toDoc x 135 | e1' = toDoc' Top e1 136 | e2' = toDoc' (R Let) e2 137 | toDoc' fc (TLet bound e) = parensIf (needsParens fc Let) $ 138 | stack [ 139 | kw "let" <+> doc "{" 140 | , indent $ table $ map letRow bound 141 | , doc "}" <+> kw "in" <+> toDoc' (R Let) e 142 | ] 143 | toDoc' fc (TCase e (Matches ms)) = parensIfChoice (needsParens fc Case) [ 144 | stack [ 145 | kw "case" <+> e' <+> kw "of" <+> doc "{" 146 | , indent $ table $ map (matchRow (R Case)) ms 147 | , doc "}" 148 | ] 149 | , kw "case" <+> e' <+> kw "of" <+> wrap "{ " " }" (punctuate " ; " ms') 150 | ] 151 | where 152 | e' = toDoc' (L Case) e 153 | ms' = map (toDoc' (R Case)) ms 154 | toDoc' fc (TCase e (Selector s)) = parensIf (needsParens fc P.Ap) $ 155 | toDoc' (L P.Ap) s <+> toDoc' (R P.Ap) e 156 | toDoc' fc (TIf c t f) = parensIfChoice (needsParens fc If) [ 157 | stack [ 158 | kw "if" <+> c' 159 | , indent $ stack [ 160 | kw "then" <+> t' 161 | , kw "else" <+> f' 162 | ] 163 | ] 164 | , kw "if" <+> c' <+> kw "then" <+> t' <+> kw "else" <+> f' 165 | ] 166 | where 167 | c' = toDoc' Top c 168 | t' = toDoc' (R If) t 169 | f' = toDoc' (R If) f 170 | 171 | instance ToDoc Selector where 172 | toDoc Fst = doc "fst" 173 | toDoc Snd = doc "snd" 174 | 175 | instance ToDoc Closure where 176 | toDoc cl = case cl of 177 | ErrorClosure str -> doc "Error :" <+> doc str 178 | FunClosure term _ -> doc "Function :" <+> toDoc term 179 | ConClosure con _ -> doc "Constructor :" <+> toDoc con 180 | IndirectionClosure _ -> doc "Indirection " -- <+> toDoc ptr 181 | ThunkClosure term _ -> doc "Thunk :" <+> toDoc term 182 | PrimClosure prim _ -> doc "Primary :" <+> toDoc prim 183 | 184 | instance ToDoc Description where 185 | toDoc StepAlloc = doc "allocate" 186 | toDoc StepBeta = doc "beta reduction" 187 | toDoc (StepApply f) = doc "apply" <+> toDoc f 188 | toDoc (StepDelta pes) = doc "delta:" <+> toDoc pes 189 | toDoc (StepMatch c) = doc "match" <+> toDoc c 190 | toDoc (StepIf b) = doc "if" <+> doc (show b) 191 | toDoc StepSeq = doc "seq" 192 | toDoc StepAllocConArgs = doc "allocate constructor arguments" 193 | 194 | -- | Based on purescript implementation 195 | mintersperse :: (Monoid m) => m -> [m] -> m 196 | mintersperse _ [] = mempty 197 | mintersperse _ [x] = x 198 | mintersperse sep (x:xs) = x <> sep <> mintersperse sep xs 199 | 200 | instance ToDoc DescriptionWithContext where 201 | toDoc (DescriptionWithContext descr []) = toDoc descr 202 | toDoc (DescriptionWithContext descr context) = mconcat [ 203 | toDoc descr 204 | , doc " in [" 205 | , mintersperse (doc ", ") $ map toDoc context 206 | , doc "]" 207 | ] 208 | 209 | -- | For the heap we need to know which pointers we are about to collect 210 | heapToDoc :: forall a. ToDoc a 211 | => Set Ptr -- ^ To be collected 212 | -> Maybe Ptr -- ^ Focus (where are we going to take a step?) 213 | -> Heap a -> Doc Style String 214 | heapToDoc garbage focus (Heap _next heap) = 215 | table $ map go (Map.toList heap) 216 | where 217 | go :: (Ptr, a) -> [Doc Style String] 218 | go (ptr, a) = [mark ptr $ toDoc ptr, doc " = ", toDoc a] 219 | 220 | mark :: Ptr -> Doc Style String -> Doc Style String 221 | mark ptr 222 | | ptr `Set.member` garbage = style $ \st -> st { styleBackground = Just Red } 223 | | Just ptr == focus = style $ \st -> st { styleBackground = Just Green } 224 | | otherwise = id 225 | 226 | {------------------------------------------------------------------------------- 227 | Auxiliary 228 | -------------------------------------------------------------------------------} 229 | 230 | kw :: String -> Doc Style String 231 | kw = style (\st -> st { styleBold = True }) . doc 232 | 233 | parensIf :: Bool -> Doc Style String -> Doc Style String 234 | parensIf False = id 235 | parensIf True = wrap "(" ")" 236 | 237 | -- | Swap the order of the choices if we need parentheses 238 | -- 239 | -- The idea is that we prefer a multi-line layout normally, but if we 240 | -- need to insert parentheses we prefer a single-line layout. 241 | parensIfChoice :: Bool -> [Doc Style String] -> Doc Style String 242 | parensIfChoice p ds = parensIf p $ choice $ (if p then reverse else id) ds 243 | 244 | wrap :: String -> String -> Doc Style String -> Doc Style String 245 | wrap lft rgt d = doc lft <> d <> doc rgt 246 | 247 | punctuate :: String -> [Doc Style String] -> Doc Style String 248 | punctuate sep = mconcat . intersperse (doc sep) 249 | 250 | hsep :: [Doc Style String] -> Doc Style String 251 | hsep = punctuate " " 252 | 253 | indent :: Doc Style String -> Doc Style String 254 | indent = (doc " " <>) 255 | 256 | (<+>) :: Doc Style String -> Doc Style String -> Doc Style String 257 | (<+>) d1 d2 = d1 <> doc " " <> d2 258 | -------------------------------------------------------------------------------- /src/CBN/Pretty/Precedence.hs: -------------------------------------------------------------------------------- 1 | -- | Dealing with precedence 2 | -- 3 | -- Adapted from 4 | -- . 5 | module CBN.Pretty.Precedence ( 6 | FixityContext(..) 7 | , Operator(..) 8 | , needsParens 9 | ) where 10 | 11 | type PartialOrdering = Maybe Ordering 12 | 13 | -- | The operators we use in our language 14 | data Operator = 15 | Ap 16 | | Lam 17 | | Let 18 | | Case 19 | | If 20 | | Cons 21 | | Add 22 | | Sub 23 | | Mul 24 | | Le 25 | | Lt 26 | | Eq 27 | deriving Eq 28 | 29 | -- | Associativty 30 | data Assoc = 31 | AssocLeft 32 | | AssocRight 33 | | AssocNone 34 | deriving Eq 35 | 36 | -- | The context in which we are pretty-printing a term 37 | data FixityContext = Top | L Operator | R Operator 38 | 39 | assoc :: Operator -> Assoc 40 | assoc Ap = AssocLeft 41 | assoc Lam = AssocRight 42 | assoc Case = AssocRight 43 | assoc Let = AssocRight 44 | assoc If = AssocRight 45 | assoc Cons = AssocRight 46 | assoc Add = AssocRight 47 | assoc Mul = AssocRight 48 | assoc Sub = AssocNone 49 | assoc Le = AssocNone 50 | assoc Lt = AssocNone 51 | assoc Eq = AssocNone 52 | 53 | comparePrec :: Operator -> Operator -> PartialOrdering 54 | comparePrec op1 op2 | op1 == op2 = Just EQ 55 | comparePrec Ap _ = Just GT 56 | comparePrec _ Ap = Just LT 57 | comparePrec _ _ = Just EQ 58 | 59 | needsParens :: FixityContext -> Operator -> Bool 60 | needsParens Top _ = False 61 | needsParens (L ctxt) op 62 | | comparePrec ctxt op == Just LT = False 63 | | comparePrec ctxt op == Just GT = True 64 | | comparePrec ctxt op == Nothing = True 65 | -- otherwise the two operators have the same precedence 66 | | assoc ctxt /= assoc op = True 67 | | assoc ctxt == AssocLeft = False 68 | | otherwise = True 69 | needsParens (R ctxt) op 70 | | comparePrec ctxt op == Just LT = False 71 | | comparePrec ctxt op == Just GT = True 72 | | comparePrec ctxt op == Nothing = True 73 | -- otherwise the two operators have the same precedence 74 | | assoc ctxt /= assoc op = True 75 | | assoc ctxt == AssocRight = False 76 | | otherwise = True 77 | -------------------------------------------------------------------------------- /src/CBN/SelThunkOpt.hs: -------------------------------------------------------------------------------- 1 | {------------------------------------------------------------------------------- 2 | Selector (thunk) optimization 3 | 4 | References: 5 | 6 | - "Fixing some space leaks with a garbage collector", Philip Walder 7 | 8 | 9 | - "A Concurrent Garbage Collector for the Glasgow Haskell Compiler", Ben Gamari 10 | 11 | Specifically section 2.5.7, "Selector optimization" 12 | 13 | - "Three runtime optimizations done by GHC's GC", Ömer Sinan Ağacan 14 | 15 | Specifically section 3, "Selector thunk evaluation" 16 | 17 | - "GHC Commentary: The Layout of Heap Objects", section "Selector thunks" 18 | 19 | -------------------------------------------------------------------------------} 20 | 21 | module CBN.SelThunkOpt (selThunkOpt) where 22 | 23 | import Control.Monad 24 | import Control.Monad.State 25 | import Data.Foldable (asum) 26 | import Data.Set (Set) 27 | 28 | import qualified Data.Map as Map 29 | import qualified Data.Set as Set 30 | 31 | import CBN.Eval 32 | import CBN.Heap 33 | import CBN.Language 34 | 35 | -- | Apply selector thunk optimization 36 | selThunkOpt :: Heap Term -> Term -> (Heap Term, Term, Bool, Set Ptr) 37 | selThunkOpt hp0 e0 = 38 | let (hp1, e1, atToplevel) = case applyInTerm hp0 e0 of 39 | Nothing -> (hp0, e0, False) 40 | Just (hp', e') -> (hp', e', True) 41 | (hp2, ptrs) = applyInHeap hp1 42 | 43 | in (hp2, e1, atToplevel, ptrs) 44 | 45 | -- | Apply selector thunk optimization 46 | applyInHeap :: Heap Term -> (Heap Term, Set Ptr) 47 | applyInHeap = findAll Set.empty 48 | where 49 | findAll :: Set Ptr -> Heap Term -> (Heap Term, Set Ptr) 50 | findAll acc hp = 51 | case asum $ map (findOne hp) (Map.toList $ heapEntries hp) of 52 | Nothing -> (hp, acc) 53 | Just (ptr, hp') -> findAll (Set.insert ptr acc) hp' 54 | 55 | -- Find one term to step 56 | findOne :: Heap Term -> (Ptr, Term) -> Maybe (Ptr, Heap Term) 57 | findOne hp (ptr, e) = do 58 | (hp', e') <- applyInTerm hp e 59 | return (ptr, mutate (hp', ptr) e') 60 | 61 | -- | Apply selector-thunk optimization in this term 62 | -- 63 | -- Returns 'Nothing' if there were no opportunities to apply the optimization. 64 | applyInTerm :: Heap Term -> Term -> Maybe (Heap Term, Term) 65 | applyInTerm = \hp term -> do 66 | let (term', (hp', isChanged)) = runState (go term) (hp, False) 67 | guard isChanged 68 | return (hp', term') 69 | where 70 | go :: Term -> State (Heap Term, Bool) Term 71 | 72 | -- Term that cannot change 73 | 74 | go term@TVar{} = return term 75 | go term@TLam{} = return term -- We don't look inside binders 76 | go term@TPtr{} = return term 77 | 78 | -- Propagation 79 | 80 | go (TCon (ConApp con args)) = 81 | TCon . ConApp con <$> mapM go args 82 | go (TPrim (PrimApp prim args)) = 83 | TPrim . PrimApp prim <$> mapM go args 84 | go (TLet bound e) = 85 | TLet <$> mapM (\(x, t) -> (x,) <$> go t) bound <*> go e 86 | go (TApp e1 e2) = 87 | TApp <$> go e1 <*> go e2 88 | go (TIf c t f) = 89 | TIf <$> go c <*> go t <*> go f 90 | go (TSeq e1 e2) = 91 | TSeq <$> go e1 <*> go e2 92 | go (TCase e (Matches ms)) = 93 | TCase <$> go e <*> (Matches <$> mapM goMatch ms) 94 | where 95 | goMatch :: Match -> State (Heap Term, Bool) Match 96 | goMatch (Match pat rhs) = Match pat <$> go rhs 97 | 98 | -- The interesting case 99 | -- 100 | -- This code is a bit simpler than the corresponding code in evaluation, 101 | -- because we /only/ deal with selectors, not general case statements. This 102 | -- means we don't need to care about substitution, but can literally just 103 | -- select the right argument. 104 | 105 | go term@(TCase e (Selector s)) = do 106 | (hp, _) <- get 107 | mConApp <- 108 | case allocConArgs (selectorVars s) (hp, e) of 109 | ConArgsAllocFailed -> 110 | return Nothing 111 | ConArgsAllocUnnecessary conApp -> 112 | return $ Just conApp 113 | ConArgsAllocDone (_ctxt, hp', _e') conApp -> do 114 | put (hp', True) 115 | return $ Just conApp 116 | case mConApp of 117 | Just (ConApp con args) | con == selectorCon s -> do 118 | modify $ \(hp', _) -> (hp', True) 119 | return $ args !! selectorIndex s 120 | _otherwise -> 121 | return term 122 | 123 | -------------------------------------------------------------------------------- /src/CBN/Subst.hs: -------------------------------------------------------------------------------- 1 | module CBN.Subst ( 2 | subst 3 | , substVar 4 | , substPtr 5 | , substVars 6 | , substPtrs 7 | , allocSubst 8 | ) where 9 | 10 | import Data.Bifunctor 11 | import Data.List (partition) 12 | import Data.Map (Map) 13 | 14 | import qualified Data.Map as Map 15 | 16 | import CBN.Free 17 | import CBN.Heap 18 | import CBN.Language 19 | 20 | {------------------------------------------------------------------------------- 21 | Substitution 22 | -------------------------------------------------------------------------------} 23 | 24 | -- | Substitution 25 | -- 26 | -- NOTE: Although we deal with shadowing here @(\x -> .. (\x -> .. ))@, we 27 | -- do NOT implement capture avoiding substitution. Since we never reduce 28 | -- under binders, we can never have free variables, and hence this is not 29 | -- something we need to worry about. 30 | class Subst a where 31 | subst :: Either Ptr Var -> Term -> a -> a 32 | 33 | substVar :: Subst a => Var -> Term -> a -> a 34 | substVar = subst . Right 35 | 36 | substPtr :: Subst a => Ptr -> Term -> a -> a 37 | substPtr = subst . Left 38 | 39 | {------------------------------------------------------------------------------- 40 | Instances 41 | -------------------------------------------------------------------------------} 42 | 43 | instance Subst a => Subst [a] where 44 | subst x e = map (subst x e) 45 | 46 | instance Subst Term where 47 | subst x e term = 48 | case term of 49 | TPtr x' -> if x == Left x' then e else term 50 | TVar x' -> if x == Right x' then e else term 51 | TLam x' e1 -> if x == Right x' 52 | then term 53 | else TLam x' (subst x e e1) 54 | TLet bound e' -> if x `elem` map (Right . fst) bound 55 | then term 56 | else TLet (map (second (subst x e)) bound) 57 | (subst x e e') 58 | TCon ces -> TCon (subst x e ces) 59 | TPrim pes -> TPrim (subst x e pes) 60 | TApp e1 e2 -> TApp (subst x e e1) (subst x e e2) 61 | TCase e1 ms -> TCase (subst x e e1) (subst x e ms) 62 | TSeq e1 e2 -> TSeq (subst x e e1) (subst x e e2) 63 | TIf c t f -> TIf (subst x e c) (subst x e t) (subst x e f) 64 | 65 | instance Subst ConApp where 66 | subst x e (ConApp c es) = ConApp c (subst x e es) 67 | 68 | instance Subst PrimApp where 69 | subst x e (PrimApp p es) = PrimApp p (subst x e es) 70 | 71 | instance Subst Match where 72 | subst x e (Match (Pat c xs) e') = 73 | if x `elem` map Right xs 74 | then Match (Pat c xs) e' 75 | else Match (Pat c xs) (subst x e e') 76 | 77 | instance Subst Branches where 78 | subst x e (Matches ms) = Matches (map (subst x e) ms) 79 | subst x e (Selector s) = Selector (subst x e s) 80 | 81 | instance Subst Selector where 82 | subst _ _ = id 83 | 84 | {------------------------------------------------------------------------------- 85 | Many-variable substitution 86 | -------------------------------------------------------------------------------} 87 | 88 | substMany :: Subst a => [(Either Ptr Var, Term)] -> a -> a 89 | substMany [] = id 90 | substMany ((x, e):s) = substMany (map (second (subst x e)) s) . subst x e 91 | 92 | substVars :: Subst a => [(Var, Term)] -> a -> a 93 | substVars = substMany . map (first Right) 94 | 95 | substPtrs :: Subst a => [(Ptr, Term)] -> a -> a 96 | substPtrs = substMany . map (first Left) 97 | 98 | {------------------------------------------------------------------------------- 99 | Heap allocation 100 | -------------------------------------------------------------------------------} 101 | 102 | allocSubst :: [(Var, Term)] -> (Heap Term, Term) -> (Heap Term, Term) 103 | allocSubst bindings (heap, body) = 104 | let toAlloc, toSubst :: [(Var, Term)] 105 | (toAlloc, toSubst) = partition requiresAlloc bindings 106 | 107 | body' :: Term 108 | body' = substVars toSubst body 109 | 110 | heap' :: Heap Term 111 | substAlloc :: [(Var, Term)] 112 | (heap', substAlloc) = 113 | allocMany 114 | (map prepareHeapEntry $ map (second (substVars toSubst)) toAlloc) 115 | processHeapEntries 116 | heap 117 | 118 | in (heap', substVars substAlloc body') 119 | where 120 | -- We all all post-processing in 'processHeapEntries' 121 | prepareHeapEntry :: (Var, Term) -> (Maybe String, Ptr -> (Var, Term, Ptr)) 122 | prepareHeapEntry (x, t) = ( 123 | Just (varName x) 124 | , \ptr -> (x, t, ptr) 125 | ) 126 | 127 | -- New heap entries, along with substitution for all heap-allocated vars 128 | processHeapEntries :: [(Var, Term, Ptr)] -> ([(Ptr, Term)], [(Var, Term)]) 129 | processHeapEntries entries = ( 130 | map (\(_, t, ptr) -> (ptr, substVars substAlloc t)) entries 131 | , substAlloc 132 | ) 133 | where 134 | substAlloc :: [(Var, Term)] 135 | substAlloc = map (\(x, _, ptr) -> (x, TPtr ptr)) entries 136 | 137 | -- Do we need to allocate this term? 138 | requiresAlloc :: (Var, Term) -> Bool 139 | requiresAlloc (x, t) = and [ 140 | not $ termIsSimple t 141 | , not $ isUsedOnceInBody x 142 | ] 143 | 144 | -- Is this binding used only once, and only in the body? 145 | isUsedOnceInBody :: Var -> Bool 146 | isUsedOnceInBody x = and [ 147 | x `notElem` Map.keys freeInBindings 148 | , Map.findWithDefault 0 x freeInBody <= 1 149 | ] 150 | where 151 | freeInBindings, freeInBody :: Map Var Count 152 | freeInBindings = free $ map snd bindings 153 | freeInBody = free body 154 | 155 | 156 | 157 | 158 | 159 | 160 | -------------------------------------------------------------------------------- /src/CBN/Trace.hs: -------------------------------------------------------------------------------- 1 | module CBN.Trace ( 2 | -- * Traces 3 | Trace(..) 4 | , TraceCont(..) 5 | , traceTerm 6 | -- * Summarizing 7 | , SummarizeOptions(..) 8 | , summarize 9 | ) where 10 | 11 | import Data.Set (Set) 12 | import qualified Data.Map as Map 13 | import qualified Data.Set as Set 14 | 15 | import CBN.Eval 16 | import CBN.Free 17 | import CBN.Heap 18 | import CBN.InlineHeap 19 | import CBN.Language 20 | import CBN.SelThunkOpt 21 | 22 | {------------------------------------------------------------------------------- 23 | Constructing the trace 24 | -------------------------------------------------------------------------------} 25 | 26 | data Trace = Trace (Heap Term, Term) TraceCont 27 | 28 | data TraceCont = 29 | -- | The trace finished on a weak head normal form 30 | TraceWHNF Value 31 | 32 | -- | The trace got stuck 33 | | TraceStuck Error 34 | 35 | -- | The trace was stopped because the maximum number of steps was reached 36 | | TraceStopped 37 | 38 | -- | We took one reduction step 39 | | TraceStep DescriptionWithContext Trace 40 | 41 | -- | The garbage collector removed some pointers 42 | | TraceGC (Set Ptr) Trace 43 | 44 | -- | The selector thunk optimization was applied 45 | -- 46 | -- We separately record if the selector thunk was applied at the top-level. 47 | | TraceSelThunk Bool (Set Ptr) Trace 48 | 49 | -- | We simplified the heap by inlining some definitions 50 | | TraceInline (Set Ptr) Trace 51 | 52 | traceTerm :: Bool -> Bool -> Bool -> (Heap Term, Term) -> Trace 53 | traceTerm shouldGC shouldInline enableSelThunkOpt = go 54 | where 55 | go :: (Heap Term, Term) -> Trace 56 | go (hp, e) = Trace (hp, e) $ 57 | case step (hp, e) of 58 | WHNF val -> TraceWHNF val 59 | Stuck err -> TraceStuck err 60 | Step d (hp1, e1) -> 61 | let (traceSelThunkOpt, hp2, e2) 62 | | enableSelThunkOpt 63 | = let (hp', e', atToplevel, optimized) = selThunkOpt hp1 e1 64 | in if not atToplevel && Set.null optimized then 65 | (id, hp1, e1) 66 | else 67 | (Trace (hp1, e1) . TraceSelThunk atToplevel optimized, hp', e') 68 | | otherwise 69 | = (id, hp1, e1) in 70 | 71 | let (traceGC, hp3, e3) 72 | | shouldGC 73 | = let (hp', collected) = gc e2 hp2 74 | in if Set.null collected then 75 | (id, hp2, e2) 76 | else 77 | (Trace (hp2, e2) . TraceGC collected, hp', e2) 78 | 79 | | otherwise 80 | = (id, hp2, e2) in 81 | 82 | let (traceInlining, hp4, e4) 83 | | shouldInline 84 | = let (hp', e', inlined) = inlineHeap hp3 e3 85 | in if Set.null inlined then 86 | (id, hp3, e3) 87 | else 88 | (Trace (hp3, e3) . TraceInline inlined, hp', e') 89 | 90 | | otherwise 91 | = (id, hp3, e3) in 92 | 93 | TraceStep d 94 | $ traceSelThunkOpt . traceGC . traceInlining 95 | $ go (hp4, e4) 96 | 97 | gc :: Term -> Heap Term -> (Heap Term, Set Ptr) 98 | gc = markAndSweep . pointers 99 | 100 | {------------------------------------------------------------------------------- 101 | Summarizing traces 102 | -------------------------------------------------------------------------------} 103 | 104 | data SummarizeOptions = SummarizeOptions { 105 | summarizeCollapseBeta :: Bool 106 | , summarizeMaxNumSteps :: Int 107 | , summarizeHidePrelude :: Maybe Int 108 | , summarizeHideTerms :: [String] 109 | , summarizeHideGC :: Bool 110 | , summarizeHideSelThunk :: Bool 111 | , summarizeHideInlining :: Bool 112 | } 113 | deriving (Show) 114 | 115 | summarize :: SummarizeOptions -> Trace -> Trace 116 | summarize SummarizeOptions{..} = go 0 117 | where 118 | -- If we have 119 | -- 120 | -- > step1 step2 121 | -- > x ------> y ------> z 122 | -- 123 | -- and we want to hide step2 (say, GC), then we want to get 124 | -- 125 | -- > x step1 126 | -- > x -------> z 127 | -- 128 | -- We will realize we want to hide this step when we look at @step2@; this 129 | -- means that we may want to hide the /source/ of the step (@y@), and 130 | -- instead show the destination (@z@). 131 | go :: Int -> Trace -> Trace 132 | go n (Trace (hp, e) c) = 133 | case c of 134 | -- End of the trace 135 | 136 | TraceWHNF v -> showSrc $ TraceWHNF v 137 | TraceStuck err -> showSrc $ TraceStuck err 138 | TraceStopped -> showSrc $ TraceStopped 139 | TraceStep{} 140 | | n > summarizeMaxNumSteps 141 | -> showSrc $ TraceStopped 142 | 143 | 144 | -- Potential hiding steps 145 | 146 | TraceGC ps t' -> 147 | if summarizeHideGC 148 | then go (n + 1) t' 149 | else showSrc $ TraceGC ps $ go (n + 1) t' 150 | TraceSelThunk atToplevel ps t' -> 151 | if summarizeHideSelThunk 152 | then go (n + 1) t' 153 | else showSrc $ TraceSelThunk atToplevel ps $ go (n + 1) t' 154 | TraceInline ps t' -> 155 | if summarizeHideInlining 156 | then go (n + 1) t' 157 | else showSrc $ TraceInline ps $ go (n + 1) t' 158 | 159 | -- Collapsing multiple beta-reductions 160 | -- 161 | -- This is a little different because we don't want to hide the 162 | -- step from the trace entirely; we just want to collapse multiple 163 | -- steps into one, but still marking that as a beta step. 164 | 165 | TraceStep dwc t' -> 166 | if summarizeCollapseBeta && isBetaStep dwc 167 | then Trace (hp, e) $ goBeta (n + 1) t' 168 | else showSrc $ TraceStep dwc $ go (n + 1) t' 169 | 170 | where 171 | showSrc :: TraceCont -> Trace 172 | showSrc = Trace (goHeap n hp, e) 173 | 174 | -- | We already saw one beta reduction; skip any subsequent ones 175 | goBeta :: Int -> Trace -> TraceCont 176 | goBeta n t@(Trace _ c) = 177 | case c of 178 | TraceStep dwc t' | isBetaStep dwc -> 179 | goBeta (n + 1) t' 180 | _otherwise -> 181 | TraceStep (DescriptionWithContext StepBeta []) $ go n t 182 | 183 | isBetaStep :: DescriptionWithContext -> Bool 184 | isBetaStep (DescriptionWithContext d _ctxt) = 185 | case d of 186 | StepBeta -> True 187 | StepApply{} -> True 188 | _otherwise -> False 189 | 190 | -- | Cleanup the heap 191 | goHeap :: Int -> Heap Term -> Heap Term 192 | goHeap n (Heap next heap) = 193 | Heap next $ Map.filterWithKey shouldShow heap 194 | where 195 | shouldShow :: Ptr -> Term -> Bool 196 | shouldShow (Ptr Nothing (Just name)) _ = and [ 197 | case summarizeHidePrelude of 198 | Nothing -> True 199 | Just n' -> n < n' 200 | , not (name `elem` summarizeHideTerms) 201 | ] 202 | shouldShow (Ptr _ _) _ = True 203 | 204 | 205 | -------------------------------------------------------------------------------- /src/CBN/Trace/Graph.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module CBN.Trace.Graph (render) where 4 | 5 | import Data.Set (Set) 6 | import Data.Maybe (listToMaybe) 7 | 8 | import qualified Data.Set as Set 9 | import qualified Data.Text as T 10 | 11 | import CBN.Eval 12 | import CBN.Heap 13 | import CBN.Pretty 14 | import CBN.Trace 15 | import CBN.Util.Doc.Style 16 | 17 | import qualified CBN.Util.Doc as Doc 18 | import qualified CBN.Util.Doc.Rendered as Rendered 19 | 20 | render :: Trace -> String 21 | render tr = 22 | "digraph G {\n" 23 | ++ "node [ fontname=monospace, shape=plaintext ];\n" 24 | ++ go 0 tr 25 | ++ "}" 26 | where 27 | go :: Int -> Trace -> String 28 | go index (Trace (hp, t) cont) = 29 | case cont of 30 | TraceWHNF _ -> mkFrame Set.empty Nothing "whnf" 31 | TraceStuck err -> mkFrame Set.empty Nothing (mkErr err) 32 | TraceStopped -> mkFrame Set.empty Nothing "stopped" 33 | TraceStep d tr' -> mkFrame Set.empty (mkFocus d) (mkDesc d) ++ go (index + 1) tr' 34 | TraceGC ps tr' -> mkFrame ps Nothing "gc" ++ go (index + 1) tr' 35 | TraceSelThunk _ ps tr' -> mkFrame ps Nothing "selector" ++ go (index + 1) tr' 36 | TraceInline ps tr' -> mkFrame ps Nothing "inline" ++ go (index + 1) tr' 37 | where 38 | mkFrame :: Set Ptr -> Maybe Ptr -> T.Text -> String 39 | mkFrame garbage focus status = 40 | T.unpack $ 41 | setLabel index ("<" <> rows <> "
>") 42 | <> "\n" 43 | <> mkConnection index 44 | where 45 | rows :: T.Text 46 | rows = mkRow (pretty t) 47 | <> mkRow (pretty (heapToDoc garbage focus hp)) 48 | <> mkRow status 49 | 50 | mkRow :: T.Text -> T.Text 51 | mkRow content = "" <> content <> "" 52 | 53 | escapeChars :: String -> String 54 | escapeChars = 55 | T.unpack 56 | . T.replace "\n" "
" 57 | . T.replace ">" ">" 58 | . T.replace "<" "<" 59 | . T.replace " " " " 60 | . T.pack 61 | 62 | setLabel :: Int -> T.Text -> T.Text 63 | setLabel n label = mkNode n <> "[label=" <> label <> "];" 64 | 65 | mkConnection :: Int -> T.Text 66 | mkConnection n 67 | | n == 0 = mkNode 0 <> ";\n" 68 | | otherwise = mkNode (n - 1) <> " -> " <> mkNode n <> ";\n" 69 | 70 | mkNode :: Int -> T.Text 71 | mkNode n = "s" <> T.pack (show n) 72 | 73 | mkErr :: String -> T.Text 74 | mkErr = ("error: " <>) . T.pack 75 | 76 | mkDesc :: DescriptionWithContext -> T.Text 77 | mkDesc (DescriptionWithContext d _) = "next step: " <> pretty d 78 | 79 | pretty :: ToDoc a => a -> T.Text 80 | pretty = T.pack . goRendered . Rendered.rendered . Doc.render (\r -> Rendered.width r <= 80) . toDoc 81 | 82 | goRendered :: [[Maybe (Style, Char)]] -> String 83 | goRendered [] = "" 84 | goRendered (row:xs) = goRow row ++ "
" ++ goRendered xs 85 | 86 | goRow :: [Maybe (Style, Char)] -> String 87 | goRow = mconcat . map toDotHtml . groupByStyle 88 | 89 | toDotHtml :: (Style, String) -> String 90 | toDotHtml (Style Nothing _ True _, str) = "" <> escapeChars str <> "" 91 | toDotHtml (Style Nothing _ _ True, str) = "" <> escapeChars str <> "" 92 | toDotHtml (Style (Just fg) _ _ _, str) = 93 | let color = case fg of 94 | Blue -> "blue" 95 | Red -> "red" 96 | Green -> "green" 97 | in 98 | " color <> "\">" <> escapeChars str <> "" 99 | toDotHtml (Style Nothing _ False False, str) = escapeChars str 100 | 101 | mkFocus :: DescriptionWithContext -> Maybe Ptr 102 | mkFocus (DescriptionWithContext _ ctxt) = listToMaybe (reverse ctxt) 103 | 104 | -------------------------------------------------------------------------------- /src/CBN/Trace/HeapGraph.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- This module was inspired by CBN.Trace.Graph and has a lot of code repetition. 4 | 5 | module CBN.Trace.HeapGraph (toGraphFiles) where 6 | 7 | import Control.Monad 8 | import Data.Graph (Graph) 9 | import qualified Data.Graph as Graph 10 | import qualified Data.Text as T 11 | 12 | import CBN.Closure 13 | import CBN.Pretty 14 | import CBN.Trace 15 | import CBN.Util.Doc.Style 16 | import qualified CBN.Util.Doc as Doc 17 | import qualified CBN.Util.Doc.Rendered as Rendered 18 | 19 | toGraphFiles :: Trace -> FilePath -> IO () 20 | toGraphFiles trace pathAndPrefix = forM_ (renderMemoryTrace trace) $ 21 | \(k,v) -> writeFile (pathAndPrefix ++ show k ++ ".dot") v 22 | 23 | renderMemoryTrace :: Trace -> [(Int,String)] 24 | renderMemoryTrace = go 0 25 | where 26 | go n (Trace (hp, t) cont) = (n,x):xs 27 | where 28 | x = renderMemoryGraph $ toClosureGraph (hp, t) 29 | xs = case cont of 30 | TraceStep _ tr' -> go (n + 1) tr' 31 | TraceGC _ tr' -> go (n + 1) tr' 32 | _ -> [] 33 | 34 | renderMemoryGraph :: (Graph, Graph.Vertex -> 35 | (Closure, Id, [Id]), Id -> Graph.Vertex) -> String 36 | renderMemoryGraph (graph, f, g) = 37 | "digraph G {\n" 38 | ++ "node [ fontname=monospace, shape=plaintext ];\n" 39 | ++ concatMap mkFrame (Graph.vertices graph) 40 | ++ "}" 41 | where 42 | mkFrame :: Graph.Vertex -> String 43 | mkFrame vertex = 44 | let (closure, _, ids) = f vertex 45 | rows :: T.Text 46 | rows = mkRow (pretty closure) 47 | in T.unpack $ 48 | setLabel vertex ("<" <> rows <> "
>") 49 | <> "\n" 50 | <> mkConnections vertex (map g ids) 51 | 52 | mkRow :: T.Text -> T.Text 53 | mkRow content = "" <> content <> "" 54 | 55 | setLabel :: Graph.Vertex -> T.Text -> T.Text 56 | setLabel n label = mkNode n <> "[label=" <> label <> "];" 57 | 58 | mkConnections :: Graph.Vertex -> [Graph.Vertex] -> T.Text 59 | mkConnections n [] = mkNode n <> ";\n" 60 | mkConnections n adj = mkNode n <> " -> " <> T.intercalate ", " (map mkNode adj) <> ";\n" 61 | 62 | mkNode :: Graph.Vertex -> T.Text 63 | mkNode n = "s" <> T.pack (show n) 64 | 65 | pretty :: ToDoc a => a -> T.Text 66 | pretty = T.pack . goRendered . Rendered.rendered . Doc.render (\r -> Rendered.width r <= 80) . toDoc 67 | 68 | goRendered :: [[Maybe (Style, Char)]] -> String 69 | goRendered [] = "" 70 | goRendered (row:xs) = goRow row ++ "
" ++ goRendered xs 71 | 72 | goRow :: [Maybe (Style, Char)] -> String 73 | goRow = mconcat . map toDotHtml . groupByStyle 74 | 75 | toDotHtml :: (Style, String) -> String 76 | toDotHtml (Style Nothing _ True _, str) = "" <> escapeChars str <> "" 77 | toDotHtml (Style Nothing _ _ True, str) = "" <> escapeChars str <> "" 78 | toDotHtml (Style (Just fg) _ _ _, str) = 79 | let color = case fg of 80 | Blue -> "blue" 81 | Red -> "red" 82 | Green -> "green" 83 | in 84 | " color <> "\">" <> escapeChars str <> "" 85 | toDotHtml (Style Nothing _ False False, str) = escapeChars str 86 | 87 | escapeChars :: String -> String 88 | escapeChars = 89 | T.unpack 90 | . T.replace "\n" "
" 91 | . T.replace ">" ">" 92 | . T.replace "<" "<" 93 | . T.replace " " " " 94 | . T.pack 95 | -------------------------------------------------------------------------------- /src/CBN/Trace/JavaScript.hs: -------------------------------------------------------------------------------- 1 | module CBN.Trace.JavaScript (render) where 2 | 3 | import Data.Maybe (listToMaybe) 4 | import Data.Set (Set) 5 | import Text.Blaze.Html.Renderer.String 6 | import Text.Blaze.Html5 (toHtml) 7 | 8 | import qualified Data.Set as Set 9 | 10 | import CBN.Eval 11 | import CBN.Heap 12 | import CBN.Pretty 13 | import CBN.Trace 14 | import CBN.Util.Doc.Rendered.HTML () 15 | 16 | import qualified CBN.Util.Doc as Doc 17 | import qualified CBN.Util.Doc.Rendered as Rendered 18 | 19 | render :: String -> Maybe FilePath -> Trace -> String 20 | render name graph = \tr -> 21 | "function " ++ name ++ "(frame) {\n" 22 | ++ innerHTML "step" ++ " = frame;\n" 23 | ++ mkGraph 24 | ++ go 0 tr 25 | ++ "}\n" 26 | ++ "var " ++ name ++ "_frame = 0;\n" 27 | ++ "function " ++ name ++ "Next() {\n" 28 | ++ name ++ "(++" ++ name ++ "_frame" ++ ");\n" 29 | ++ "}\n" 30 | ++ "function " ++ name ++ "Prev() {\n" 31 | ++ name ++ "(--" ++ name ++ "_frame" ++ ");\n" 32 | ++ "}\n" 33 | ++ name ++ "(" ++ name ++ "_frame);\n" 34 | where 35 | mkGraph :: String 36 | mkGraph = case graph of 37 | Nothing -> "" 38 | Just g -> 39 | innerHTML "graph" ++ " = \'';\n" 41 | 42 | go :: Int -> Trace -> String 43 | go n (Trace (hp, e) c) = 44 | case c of 45 | TraceWHNF _ -> mkFrame Set.empty Nothing "whnf" 46 | TraceStuck err -> mkFrame Set.empty Nothing (mkErr err) 47 | TraceStopped -> mkFrame Set.empty Nothing "stopped" 48 | TraceStep d tr' -> mkFrame Set.empty (mkFocus d) (mkDesc d) ++ go (n + 1) tr' 49 | TraceGC ps tr' -> mkFrame ps Nothing "gc" ++ go (n + 1) tr' 50 | TraceSelThunk _ ps tr' -> mkFrame ps Nothing "selector" ++ go (n + 1) tr' 51 | TraceInline ps tr' -> mkFrame ps Nothing "inline" ++ go (n + 1) tr' 52 | where 53 | mkFrame :: Set Ptr -> Maybe Ptr -> String -> String 54 | mkFrame garbage focus status = 55 | "if(frame == " ++ show n ++ ") {\n" 56 | ++ set "heap" (pretty (heapToDoc garbage focus hp)) 57 | ++ set "term" (pretty e) 58 | ++ set "status" status 59 | ++ "}\n" 60 | 61 | mkErr :: String -> String 62 | mkErr = ("error: " ++) 63 | 64 | mkDesc :: DescriptionWithContext -> String 65 | mkDesc d = "next step: " ++ pretty d 66 | 67 | set :: String -> String -> String 68 | set suffix val = innerHTML suffix ++ " = " ++ show val ++ ";\n" 69 | 70 | innerHTML :: String -> String 71 | innerHTML suffix = "document.getElementById(\"" ++ name ++ "_" ++ suffix ++ "\").innerHTML" 72 | 73 | pretty :: ToDoc a => a -> String 74 | pretty = renderHtml 75 | . toHtml 76 | . Doc.render (\r -> Rendered.width r <= 80) 77 | . toDoc 78 | 79 | mkFocus :: DescriptionWithContext -> Maybe Ptr 80 | mkFocus (DescriptionWithContext _ ctxt) = listToMaybe (reverse ctxt) 81 | -------------------------------------------------------------------------------- /src/CBN/Trace/Textual.hs: -------------------------------------------------------------------------------- 1 | module CBN.Trace.Textual (renderIO) where 2 | 3 | import Data.List (intersperse) 4 | import Data.Maybe (listToMaybe) 5 | import Data.Set (Set) 6 | 7 | import qualified Data.Set as Set 8 | 9 | import CBN.Eval 10 | import CBN.Heap 11 | import CBN.Pretty 12 | import CBN.Trace 13 | 14 | import qualified CBN.Util.Doc as Doc 15 | import qualified CBN.Util.Doc.Rendered as Rendered 16 | import qualified CBN.Util.Doc.Rendered.ANSI as ANSI 17 | import qualified CBN.Util.Doc.Rendered.String as String 18 | 19 | renderIO :: Bool -> Trace -> IO () 20 | renderIO disableAnsi = go 0 21 | where 22 | go :: Int -> Trace -> IO () 23 | go n (Trace (hp, e) c) = do 24 | case c of 25 | TraceWHNF _ -> mkFrame Set.empty Nothing (putStr $ "whnf") 26 | TraceStuck err -> mkFrame Set.empty Nothing (putStr $ "stuck: " ++ err) 27 | TraceStopped -> mkFrame Set.empty Nothing (putStr $ "stopped") 28 | TraceStep d tr' -> mkFrame Set.empty (mkFocus d) (pretty d) >> go (n + 1) tr' 29 | TraceGC ps tr' -> mkFrame ps Nothing (ptrs False "collecting" ps) >> go (n + 1) tr' 30 | TraceSelThunk top ps tr' -> mkFrame ps Nothing (ptrs top "apply selectors" ps) >> go (n + 1) tr' 31 | TraceInline ps tr' -> mkFrame ps Nothing (ptrs False "inlining" ps) >> go (n + 1) tr' 32 | where 33 | mkFrame :: Set Ptr -> Maybe Ptr -> IO () -> IO () 34 | mkFrame garbage focus msg = do 35 | putStrLn $ "** " ++ show n 36 | pretty (heapToDoc garbage focus hp) ; putChar '\n' 37 | pretty e ; putChar '\n' 38 | putChar '\n' 39 | putStr "(" ; msg ; putStrLn ")\n" 40 | 41 | ptrs :: Bool -> String -> Set Ptr -> IO () 42 | ptrs atToplevel label ps = do 43 | putStr (label ++ " ") 44 | sequence_ . intersperse (putStr ", ") $ concat [ 45 | [putStr "top-level" | atToplevel] 46 | , map pretty $ Set.toList ps 47 | ] 48 | 49 | pretty :: ToDoc a => a -> IO () 50 | pretty = 51 | ( if disableAnsi 52 | then putStr . String.toString 53 | else ANSI.write 54 | ) 55 | . Doc.render (\r -> Rendered.width r <= 80) 56 | . toDoc 57 | 58 | mkFocus :: DescriptionWithContext -> Maybe Ptr 59 | mkFocus (DescriptionWithContext _ ctxt) = listToMaybe (reverse ctxt) 60 | -------------------------------------------------------------------------------- /src/CBN/Util/Doc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module CBN.Util.Doc ( 3 | Table 4 | , Doc -- opaque 5 | , doc 6 | , table 7 | , choice 8 | , style 9 | , stack 10 | , render 11 | , renderAll 12 | ) where 13 | 14 | import Data.Default 15 | import Data.Foldable (asum) 16 | import Data.List (find) 17 | import Data.Maybe (fromMaybe) 18 | import Data.Semigroup as Sem 19 | 20 | import CBN.Util.Doc.Rendered (Table, Rendered) 21 | import qualified CBN.Util.Doc.Rendered as Rendered 22 | 23 | {------------------------------------------------------------------------------- 24 | Documents 25 | -------------------------------------------------------------------------------} 26 | 27 | -- | Abstract description of a document 28 | -- 29 | -- The two type parameters are the type of the styling applied to the document 30 | -- and the type of primitive documents. 31 | data Doc st a = 32 | -- | Primitive document 33 | Doc a 34 | 35 | -- | Append two documents 36 | | Append (Doc st a) (Doc st a) 37 | 38 | -- | Align a bunch of documents like in a table 39 | -- 40 | -- Outermost list: rows; innermost list: columns 41 | | Table [[Doc st a]] 42 | 43 | -- | Alternative renderings 44 | | Choice [Doc st a] 45 | 46 | -- | Apply style 47 | | Style (st -> st) (Doc st a) 48 | 49 | instance Sem.Semigroup (Doc st a) where 50 | (<>) = Append 51 | 52 | -- | The standard monoidal corresponds to horizontal composition 53 | instance Monoid a => Monoid (Doc st a) where 54 | mempty = Doc mempty 55 | #if !(MIN_VERSION_base(4,11,0)) 56 | mappend = (<>) 57 | #endif 58 | 59 | -- | Primitive document 60 | doc :: a -> Doc st a 61 | doc = Doc 62 | 63 | -- | Table of documents 64 | table :: [[Doc st a]] -> Doc st a 65 | table = Table 66 | 67 | -- | Multiple alternative renderings 68 | choice :: [Doc st a] -> Doc st a 69 | choice = Choice 70 | 71 | -- | Apply style 72 | style :: (st -> st) -> Doc st a -> Doc st a 73 | style = Style 74 | 75 | -- | Vertical composition of documents 76 | stack :: [Doc st a] -> Doc st a 77 | stack = Table . map (:[]) 78 | 79 | {------------------------------------------------------------------------------- 80 | Rendering 81 | -------------------------------------------------------------------------------} 82 | 83 | -- | Compute all possible ways to render this document 84 | renderAll :: Default st => Doc st String -> [Rendered st] 85 | renderAll (Doc str) = return $ Rendered.fromString str 86 | renderAll (Choice ds) = asum (map renderAll ds) 87 | renderAll (Append d1 d2) = mappend <$> renderAll d1 <*> renderAll d2 88 | renderAll (Table dss) = Rendered.table <$> mapM (mapM renderAll) dss 89 | renderAll (Style st d) = fmap st <$> renderAll d 90 | 91 | render :: Default st => (Rendered st -> Bool) -> Doc st String -> Rendered st 92 | render p d = fromMaybe (head $ renderAll d) (find p $ renderAll d) 93 | -------------------------------------------------------------------------------- /src/CBN/Util/Doc/Rendered.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | Rendered documents 3 | -- 4 | -- Intended for qualified import 5 | -- 6 | -- > import CBN.Util.Doc.Rendered (Rendered) 7 | -- > import qualified CBN.Util.Doc.Rendered as Rendered 8 | module CBN.Util.Doc.Rendered ( 9 | Table 10 | , Rendered(..) 11 | , fromString 12 | , table 13 | -- * Auxiliary 14 | , rTrim 15 | ) where 16 | 17 | import Data.Bifunctor 18 | import Data.Default 19 | import Data.List (transpose) 20 | import Data.Maybe (isNothing) 21 | import Data.Semigroup as Sem 22 | 23 | -- | A table in rows-of-columns format 24 | -- 25 | -- For example, every element of @Table Char@ is a 'String' (such as a line 26 | -- in a rendered document); i.e., 27 | -- 28 | -- > [['a', 'b', 'c']] 29 | -- 30 | -- corresponds to 31 | -- 32 | -- > +---+---+---+ 33 | -- > | a | b | c | 34 | -- > +---+---+---+ 35 | -- 36 | -- Conversely, 37 | -- 38 | -- > [['a'],['b'],['c']] 39 | -- 40 | -- corresponds to 41 | -- 42 | -- > +---+ 43 | -- > | a | 44 | -- > +---+ 45 | -- > | b | 46 | -- > +---+ 47 | -- > | c | 48 | -- > +---+ 49 | -- 50 | -- Finally, we have that 51 | -- 52 | -- > [['a', 'b'], ['c', 'd']] 53 | -- 54 | -- corresponds to 55 | -- 56 | -- > +---+---+ 57 | -- > | a | b | 58 | -- > +---+---+ 59 | -- > | c | d | 60 | -- > +---+---+ 61 | type Table a = [[a]] 62 | 63 | -- | Rendered document 64 | -- 65 | -- This is parameterized by the style of each character. 66 | -- 67 | -- INVARIANT: All lines must be of the same length ('rendered' is a rectangle). 68 | data Rendered st = Rendered { 69 | width :: Int 70 | , height :: Int 71 | , rendered :: [[Maybe (st, Char)]] -- ^ 'Nothing' indicates padding 72 | } 73 | deriving (Show) 74 | 75 | instance Functor Rendered where 76 | fmap f r = r { rendered = map (map (fmap (first f))) (rendered r) } 77 | 78 | instance Sem.Semigroup (Rendered st) where 79 | (<>) = nestle 80 | 81 | -- | Like the instance for 'Doc', this corresponds to horizontal composition 82 | instance Monoid (Rendered st) where 83 | mempty = empty 84 | #if !(MIN_VERSION_base(4,11,0)) 85 | mappend = (<>) 86 | #endif 87 | mconcat = nestles 88 | 89 | -- | Empty rendered documents 90 | empty :: Rendered st 91 | empty = Rendered { 92 | width = 0 93 | , height = 0 94 | , rendered = [] 95 | } 96 | 97 | -- | Construct rendered document from a string (possibly containing linebreaks) 98 | fromString :: Default st => String -> Rendered st 99 | fromString str = Rendered { 100 | width = newWidth 101 | , height = length ss 102 | , rendered = map (padTo newWidth . map (\c -> Just (def, c))) ss 103 | } 104 | where 105 | ss = lines str 106 | newWidth = maximum $ map length ss 107 | 108 | -- | Set the width of a rendered document (by padding where necessary) 109 | setWidth :: Int -> Rendered st -> Rendered st 110 | setWidth n r = Rendered { 111 | width = newWidth 112 | , height = height r 113 | , rendered = map (padTo newWidth) (rendered r) 114 | } 115 | where 116 | newWidth = max n (width r) 117 | 118 | -- | Vertical composition of rendered documents 119 | -- 120 | -- Vertical composition is straight-forward; we just have to make sure to 121 | -- pad the documents. 122 | stack :: Rendered st -> Rendered st -> Rendered st 123 | stack r1 r2 = Rendered { 124 | width = newWidth 125 | , height = newHeight 126 | , rendered = map (padTo newWidth) (rendered r1 ++ rendered r2) 127 | } 128 | where 129 | newWidth = max (width r1) (width r2) 130 | newHeight = height r1 + height r2 131 | 132 | stacks :: [Rendered st] -> Rendered st 133 | stacks = foldr stack empty 134 | 135 | -- | Horizontal composition of rendered documents 136 | -- 137 | -- Since we are dealing with source code, horizontal composition of documents 138 | -- is somewhat peculiar. It will look like this: 139 | -- 140 | -- > +-----------+ 141 | -- > | | 142 | -- > | | 143 | -- > | | +--------------+ 144 | -- > | | | | 145 | -- > +-----------+ | | 146 | -- > | | 147 | -- > | | 148 | -- > +--------------| 149 | -- 150 | -- so that the last line of the first box lines up with the first line of the 151 | -- second box. To see this, consider something like 152 | -- 153 | -- > +------------------+ 154 | -- > | case xs of | 155 | -- > | Nil -> 0 | +-----------------------+ 156 | -- > | Cons x xs' -> | | let xs'' = map foo xs | 157 | -- > +------------------+ | in bar xs'' | 158 | -- > +-----------------------| 159 | -- 160 | -- See also 'nestle', which can often result in a more natural layout 161 | -- (but is less useful when rendering tables). 162 | stagger :: Rendered st -> Rendered st -> Rendered st 163 | stagger r1 r2 164 | | height r1 == 0 = r2 165 | | height r2 == 0 = r1 166 | | otherwise = Rendered { 167 | width = newWidth 168 | , height = newHeight 169 | , rendered = zipWith (++) (rendered r1 ++ padding r1) 170 | (padding r2 ++ rendered r2) 171 | } 172 | where 173 | newWidth = width r1 + width r2 174 | newHeight = height r1 + height r2 - 1 -- they overlap by one line 175 | padding r = replicate (newHeight - height r) 176 | (replicate (width r) Nothing) 177 | 178 | staggers :: [Rendered st] -> Rendered st 179 | staggers = foldr stagger empty 180 | 181 | -- | Like 'stagger', but reduce the horizontal space 182 | -- 183 | -- > +-----------+ 184 | -- > | | 185 | -- > | | 186 | -- > | +--------------+ 187 | -- > | | | 188 | -- > +-------| | 189 | -- > | | 190 | -- > | | 191 | -- > +--------------| 192 | -- 193 | -- For example: 194 | -- 195 | -- > +-------------------+ 196 | -- > | case xs of | 197 | -- > | Cons x xs' -> 0 |-----------+ 198 | -- > | Nil -> | case ys of | 199 | -- > +----------| Cons y ys' -> .. | 200 | -- > | Nil -> .. | 201 | -- > +--------------------| 202 | -- 203 | -- This generally leads to a more natural layout then 'stagger'. 204 | nestle :: Rendered st -> Rendered st -> Rendered st 205 | nestle r1 r2 206 | | height r1 == 0 = r2 207 | | height r2 == 0 = r1 208 | | otherwise = Rendered { 209 | width = newWidth 210 | , height = newHeight 211 | , rendered = map (padTo newWidth) $ concat [ 212 | init (rendered r1) 213 | , [lastLine_r1 ++ head (rendered r2)] 214 | , map (replicate lastWidth_r1 Nothing ++) (tail (rendered r2)) 215 | ] 216 | } 217 | where 218 | newWidth = max (lastWidth_r1 + width r2) (width r1) 219 | newHeight = height r1 + height r2 - 1 -- they overlap by one line 220 | lastLine_r1 = rTrim $ last (rendered r1) 221 | lastWidth_r1 = length lastLine_r1 222 | 223 | nestles :: [Rendered st] -> Rendered st 224 | nestles = foldr nestle empty 225 | 226 | -- | Render a table 227 | -- 228 | -- A table must be rendered such that cells in the same column are lined up 229 | -- horizontally; cells in a row must be lined up in the usual staggered 230 | -- manner (see 'rStagger'). 231 | table :: forall st. Table (Rendered st) -> Rendered st 232 | table rss = 233 | stacks (map staggers paddedCols) 234 | where 235 | -- Number of columns in the table 236 | numCols :: Int 237 | numCols = maximum (map length rss) 238 | 239 | -- Pad table so that every row has same number of columns 240 | square :: [[Rendered st]] 241 | square = map (padWith numCols empty) rss 242 | 243 | -- Transpose the table so we now have columns of rows of documents 244 | squareT :: [[Rendered st]] 245 | squareT = transpose square 246 | 247 | -- Pair every column with its desired width 248 | columnWidthsT :: [(Int, [Rendered st])] 249 | columnWidthsT = map (\rs -> (maximum $ map width rs, rs)) squareT 250 | 251 | -- Pad every cell in a single column to the width of that column 252 | paddedColsT :: [[Rendered st]] 253 | paddedColsT = map (\(w, rs) -> map (setWidth w) rs) columnWidthsT 254 | 255 | -- Transpose back 256 | paddedCols :: [[Rendered st]] 257 | paddedCols = transpose paddedColsT 258 | 259 | {------------------------------------------------------------------------------- 260 | Auxiliary 261 | -------------------------------------------------------------------------------} 262 | 263 | padTo :: Int -> [Maybe (st, Char)] -> [Maybe (st, Char)] 264 | padTo n = padWith n Nothing 265 | 266 | padWith :: Int -> a -> [a] -> [a] 267 | padWith n x xs = xs ++ replicate (n - length xs) x 268 | 269 | -- | Remove padding 270 | rTrim :: [Maybe (st, Char)] -> [Maybe (st, Char)] 271 | rTrim = reverse . dropWhile isNothing . reverse 272 | -------------------------------------------------------------------------------- /src/CBN/Util/Doc/Rendered/ANSI.hs: -------------------------------------------------------------------------------- 1 | module CBN.Util.Doc.Rendered.ANSI ( 2 | write 3 | ) where 4 | 5 | import Control.Monad 6 | import Data.Default 7 | import Data.IORef 8 | import Data.List (intersperse) 9 | import qualified System.Console.ANSI as ANSI 10 | 11 | import CBN.Util.Doc.Rendered 12 | import CBN.Util.Doc.Style 13 | 14 | write :: Rendered Style -> IO () 15 | write r = do 16 | stRef <- newIORef def 17 | go stRef $ rendered r 18 | ANSI.setSGR [ANSI.Reset] 19 | where 20 | go :: IORef Style -> [[Maybe (Style, Char)]] -> IO () 21 | go ref = sequence_ . intersperse (putChar '\n') . map (goLine ref) 22 | 23 | goLine :: IORef Style -> [Maybe (Style, Char)] -> IO () 24 | goLine ref = mapM_ (goChar ref) . rTrim 25 | 26 | goChar :: IORef Style -> Maybe (Style, Char) -> IO () 27 | goChar _ Nothing = putChar ' ' 28 | goChar ref (Just (st, c)) = do 29 | activeStyle <- readIORef ref 30 | when (activeStyle /= st) $ do 31 | ANSI.setSGR (styleToSGR st) 32 | writeIORef ref st 33 | putChar c 34 | 35 | styleToSGR :: Style -> [ANSI.SGR] 36 | styleToSGR Style{..} = mconcat [ 37 | [ ANSI.Reset ] 38 | , [ ANSI.SetConsoleIntensity ANSI.BoldIntensity 39 | | styleBold 40 | ] 41 | , [ ANSI.SetItalicized True 42 | | styleItalic 43 | ] 44 | , [ ANSI.SetColor ANSI.Foreground ANSI.Dull (toAnsiColor c) 45 | | Just c <- [styleForeground] 46 | ] 47 | , [ ANSI.SetColor ANSI.Background ANSI.Dull (toAnsiColor c) 48 | | Just c <- [styleBackground] 49 | ] 50 | ] 51 | 52 | toAnsiColor :: Color -> ANSI.Color 53 | toAnsiColor Blue = ANSI.Blue 54 | toAnsiColor Red = ANSI.Red 55 | toAnsiColor Green = ANSI.Green 56 | -------------------------------------------------------------------------------- /src/CBN/Util/Doc/Rendered/HTML.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module CBN.Util.Doc.Rendered.HTML () where 3 | 4 | import Control.Monad (replicateM_) 5 | import Data.Char (isSpace) 6 | import Data.Default 7 | import Data.Function (on) 8 | import Data.List (intersperse, groupBy) 9 | import Text.Blaze.Html5 (Html, toHtml, (!)) 10 | import Text.Blaze (ToMarkup(..)) 11 | 12 | import qualified Text.Blaze.Html5 as H 13 | import qualified Text.Blaze.Html5.Attributes as A 14 | 15 | import CBN.Util.Doc.Rendered 16 | import CBN.Util.Doc.Style 17 | 18 | instance ToMarkup (Rendered Style) where 19 | toMarkup = go . rendered 20 | where 21 | go :: [[Maybe (Style, Char)]] -> Html 22 | go = sequence_ . intersperse H.br . map goLine 23 | 24 | goLine :: [Maybe (Style, Char)] -> Html 25 | goLine = 26 | mapM_ goGroup . groupByStyle . rTrim 27 | 28 | goGroup :: (Style, String) -> Html 29 | goGroup (st, str) 30 | | st == def = goString str 31 | | otherwise = H.span ! A.style (styleToCss st) $ goString str 32 | 33 | -- Make all spaces non-breaking so that layout works as expected 34 | goString :: String -> Html 35 | goString = sequence_ . map aux . groupBy ((==) `on` isSpace) 36 | where 37 | aux :: String -> Html 38 | aux [] = error "impossible (groupBy)" 39 | aux cs@(c:_) = if isSpace c 40 | then replicateM_ (length cs) nbsp 41 | else toHtml cs 42 | 43 | styleToCss :: Style -> H.AttributeValue 44 | styleToCss Style{..} = (mconcat . concat) [ 45 | [ "font-weight: bold;" 46 | | styleBold 47 | ] 48 | , [ "font-style: italic;" 49 | | styleItalic 50 | ] 51 | , [ "color: " <> toCssColor c <> ";" 52 | | Just c <- [styleForeground] 53 | ] 54 | , [ "background-color: " <> toCssColor c <> ";" 55 | | Just c <- [styleBackground] 56 | ] 57 | ] 58 | 59 | toCssColor :: Color -> H.AttributeValue 60 | toCssColor Blue = "darkblue" 61 | toCssColor Red = "darkred" 62 | toCssColor Green = "lightgreen" 63 | 64 | nbsp :: Html 65 | nbsp = preEscapedToMarkup (" " :: String) 66 | -------------------------------------------------------------------------------- /src/CBN/Util/Doc/Rendered/String.hs: -------------------------------------------------------------------------------- 1 | module CBN.Util.Doc.Rendered.String (toString) where 2 | 3 | import Data.List (intercalate) 4 | 5 | import CBN.Util.Doc.Rendered 6 | 7 | toString :: Rendered style -> String 8 | toString = intercalate "\n" . map (map (maybe ' ' snd)) . rendered 9 | -------------------------------------------------------------------------------- /src/CBN/Util/Doc/Style.hs: -------------------------------------------------------------------------------- 1 | module CBN.Util.Doc.Style ( 2 | Style(..) 3 | , Color(..) 4 | , groupByStyle 5 | ) where 6 | 7 | import Data.Default 8 | import Data.List (groupBy) 9 | 10 | data Style = Style { 11 | styleForeground :: Maybe Color 12 | , styleBackground :: Maybe Color 13 | , styleBold :: Bool 14 | , styleItalic :: Bool 15 | } 16 | deriving (Eq) 17 | 18 | data Color = 19 | Blue 20 | | Red 21 | | Green 22 | deriving (Eq) 23 | 24 | instance Default Style where 25 | def = Style { 26 | styleForeground = Nothing 27 | , styleBackground = Nothing 28 | , styleBold = False 29 | , styleItalic = False 30 | } 31 | 32 | -- Are two characters the same style? 33 | -- 34 | -- We regard padding as having a different style from everything else; 35 | -- although it doesn't really matter what style we use for padding, if 36 | -- we don't do this then something like 37 | -- 38 | -- > (style1, "foo") `padding` (style2, "bar") 39 | -- 40 | -- will not be rendered correctly, since @style1@ would be considered 41 | -- equal to @padding@ which would in turn be considered equal to @style2@. 42 | sameStyle :: Maybe (Style, Char) -> Maybe (Style, Char) -> Bool 43 | sameStyle Nothing _ = False 44 | sameStyle _ Nothing = False 45 | sameStyle (Just (st, _)) (Just (st', _)) = st == st' 46 | 47 | groupByStyle :: [Maybe (Style, Char)] -> [(Style, String)] 48 | groupByStyle = map aux . groupBy sameStyle 49 | where 50 | -- After grouping, find each group and its style 51 | aux :: [Maybe (Style, Char)] -> (Style, String) 52 | aux [] = (def, "") 53 | aux (Nothing : cs) = let (st, str) = aux cs in (st, ' ':str) 54 | aux (Just (st,c) : cs) = (st, c:map toChar cs) 55 | 56 | toChar :: Maybe (Style, Char) -> Char 57 | toChar Nothing = ' ' 58 | toChar (Just (_,c)) = c 59 | -------------------------------------------------------------------------------- /src/CBN/Util/Map.hs: -------------------------------------------------------------------------------- 1 | module CBN.Util.Map ( 2 | deleteKeys 3 | ) where 4 | 5 | import Data.Map (Map) 6 | import qualified Data.Map as Map 7 | 8 | deleteKeys :: Ord k => [k] -> Map k a -> Map k a 9 | deleteKeys [] = id 10 | deleteKeys (k:ks) = deleteKeys ks . Map.delete k 11 | -------------------------------------------------------------------------------- /src/CBN/Util/Snoc.hs: -------------------------------------------------------------------------------- 1 | -- | Snoc-lists 2 | -- 3 | -- Intended for double import 4 | -- 5 | -- > import CBN.Util.Snoc (Snoc) 6 | -- > import qualified CBN.Util.Snoc as Snoc 7 | module CBN.Util.Snoc ( 8 | Snoc(..) 9 | , fromList 10 | ) where 11 | 12 | data Snoc a = Nil | Cons (Snoc a) a 13 | deriving (Show, Eq, Ord) 14 | 15 | fromList :: [a] -> Snoc a 16 | fromList = foldl Cons Nil 17 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Control.Monad 4 | 5 | import CBN.Options 6 | import CBN.Parser 7 | import CBN.Trace 8 | import CBN.Trace.HeapGraph as Trace.HeapGraph 9 | import CBN.Trace.JavaScript as Trace.JavaScript 10 | import CBN.Trace.Textual as Trace.Textual 11 | import CBN.Trace.Graph as Trace.Graph 12 | 13 | main :: IO () 14 | main = do 15 | Options{..} <- getOptions 16 | input <- parseIO optionsInput parseModule =<< readFile optionsInput 17 | let trace = summarize optionsSummarize $ 18 | traceTerm 19 | optionsGC 20 | optionsInlineHeap 21 | optionsSelThunkOpt 22 | input 23 | when optionsShowTrace $ 24 | Trace.Textual.renderIO optionsDisableAnsi trace 25 | forM_ optionsJsOutput $ \file -> 26 | writeFile file $ Trace.JavaScript.render optionsJsName optionsGraphOutput trace 27 | forM_ optionsGraphOutput $ \file -> 28 | writeFile file $ Trace.Graph.render trace 29 | forM_ optionsGraphOutput $ toGraphFiles trace 30 | -------------------------------------------------------------------------------- /visualize-cbn.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: visualize-cbn 3 | version: 0.2.1 4 | synopsis: Visualize CBN reduction 5 | description: CBN interpretation and visualization tool. 6 | Exports in text format, coloured text (ANSI) or HTML/JavaScript. 7 | license: BSD3 8 | license-file: LICENSE 9 | author: Edsko de Vries 10 | maintainer: edsko@well-typed.com 11 | copyright: Well-Typed LLP 12 | category: Development 13 | build-type: Simple 14 | extra-source-files: ChangeLog.md README.md CONTRIBUTORS 15 | 16 | tested-with: 17 | GHC == 9.12.1 18 | GHC == 9.10.1 19 | GHC == 9.8.4 20 | GHC == 9.6.6 21 | GHC == 9.4.8 22 | GHC == 9.2.8 23 | GHC == 9.0.2 24 | GHC == 8.10.7 25 | 26 | source-repository head 27 | type: git 28 | location: https://github.com/well-typed/visualize-cbn 29 | 30 | executable visualize-cbn 31 | main-is: Main.hs 32 | other-modules: CBN.Closure 33 | CBN.Eval 34 | CBN.Free 35 | CBN.Heap 36 | CBN.InlineHeap 37 | CBN.Language 38 | CBN.Options 39 | CBN.Parser 40 | CBN.Pretty 41 | CBN.Pretty.Precedence 42 | CBN.SelThunkOpt 43 | CBN.Subst 44 | CBN.Trace 45 | CBN.Trace.HeapGraph 46 | CBN.Trace.JavaScript 47 | CBN.Trace.Textual 48 | CBN.Trace.Graph 49 | CBN.Util.Doc 50 | CBN.Util.Doc.Rendered 51 | CBN.Util.Doc.Rendered.ANSI 52 | CBN.Util.Doc.Rendered.HTML 53 | CBN.Util.Doc.Rendered.String 54 | CBN.Util.Doc.Style 55 | CBN.Util.Map 56 | CBN.Util.Snoc 57 | build-depends: base >= 4.14 && < 4.22 58 | , ansi-terminal >= 1.0 && < 1.2 59 | , blaze-html >= 0.9 && < 0.10 60 | , blaze-markup >= 0.8 && < 0.9 61 | , containers >= 0.6 && < 0.9 62 | , data-default >= 0.7 && < 0.9 63 | , mtl >= 2.2 && < 2.4 64 | , optparse-applicative >= 0.18 && < 0.19 65 | , parsec >= 3.1 && < 3.2 66 | , template-haskell >= 2.16 && < 2.24 67 | , text >= 1.2 && < 2.2 68 | hs-source-dirs: src 69 | default-language: Haskell2010 70 | default-extensions: DeriveDataTypeable 71 | ExistentialQuantification 72 | FlexibleInstances 73 | LambdaCase 74 | RecordWildCards 75 | ScopedTypeVariables 76 | StandaloneDeriving 77 | TupleSections 78 | other-extensions: GeneralizedNewtypeDeriving 79 | OverloadedStrings 80 | TemplateHaskell 81 | ghc-options: -Wall 82 | -fno-warn-orphans 83 | -rtsopts 84 | "-with-rtsopts=-M128M" 85 | --------------------------------------------------------------------------------