grin-compiler/grin
1
1
Fork 0
mirror of https://github.com/grin-compiler/grin.git synced 2024-09-11 07:25:28 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into update-nix-setup

Browse Source
This commit is contained in:
Luc Tielen 2019-12-07 06:53:38 +01:00
commit 9ac2ec72f4
No known key found for this signature in database
GPG Key ID: 30A4D06ACE9EBD3C
133 changed files with 6737 additions and 1126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
.github/FUNDING.yml vendored Normal file
View File

@ -0,0 +1,13 @@
# These are supported funding model platforms
#github: # Replace with up to 4 GitHub Sponsors-enabled usernames e.g., [user1, user2]
patreon: csaba_hruska
# Replace with a single Patreon username
#open_collective: # Replace with a single Open Collective username
#ko_fi: # Replace with a single Ko-fi username
#tidelift: # Replace with a single Tidelift platform-name/package-name e.g., npm/babel
#community_bridge: # Replace with a single Community Bridge project-name e.g., cloud-foundry
#liberapay: # Replace with a single Liberapay username
#issuehunt: # Replace with a single IssueHunt username
#otechie: # Replace with a single Otechie username
#custom: # Replace with a single custom sponsorship URL

4
.gitignore vendored
View File

@ -24,3 +24,7 @@ output/
*.agdai
.output
.grin-output/
.vscode/
*.out
*.out.ll
*.out.s

9
.travis.yml
View File

@ -6,7 +6,7 @@ env:
global:
- GCC=gcc-5
- GXX=g++-5
- LLVM_VER=7.0.0
- LLVM_VER=7.1.0
cache:
directories:
@ -32,13 +32,12 @@ before_install:
install:
- stack update
- travis_wait 120 stack --no-terminal --install-ghc test --only-dependencies
- travis_wait 120 stack --no-terminal --install-ghc test --only-dependencies --coverage
script:
- mkdir .output
- stack --no-terminal test --coverage
- stack exec grin -- grin/grin/sum_simple.grin
- stack test grin:grin-end-to-end-test grin:grin-test --coverage
after_script:
- travis_retry curl -L https://github.com/rubik/stack-hpc-coveralls/releases/download/v0.0.4.0/shc-linux-x64-8.0.1.tar.bz2 | tar -xj
- ./shc grin grin-test
- ./shc --repo-token=8QkWaPJlRbej9X5N5AaXSommTtN7uEqRT combined all

55
BACKERS.md Normal file
View File

@ -0,0 +1,55 @@
<h1 align="center">Sponsors &amp; Backers</h1>
<h2 align="center">Silver via Patreon</h2>
- Sam Griffin
- Timothy Klim
<h2 align="center">Bronze via Patreon</h2>
- Stephen Diehl
- Christopher Goes
<h2 align="center">Generous Backers via Patreon ($50+)</h2>
<!--50 start-->
- A
- Daniel Pek
- Peter Kadlot
- Michael Koloberdin
- William Harvey
- Steven Kane
<!--50 end-->
<h2 align="center">Backers via Patreon</h2>
<!--10 start-->
- Hécate
- Joe Vargas
- Vilem Liepelt
- Jonathan King
- Sergey Homa
- Marietta Le
- Adam Piper
- Leon Coto
- Balaji
- Alex Mason
- Felix Schröter
- Péter Diviánszky
- glaebhoerl
- David Curran
- Alex B
- Kametrixom Tikara
- Denis Redozubov
- Andrei Dziahel
- Oleh Stolyar
- Alberto Centelles
- Tom Hunger
- Mirzhan Irkegulov
- James MacAulay
- Adam S E
- Michael
- Chai T. Rex
- Malte Brandy
- Tanner Doshier
<!--10 end-->

172
README.md
View File

@ -1,25 +1,45 @@
# GRIN
[![Build Status](https://travis-ci.org/grin-tech/grin.svg?branch=master)](https://travis-ci.org/grin-tech/grin) [![Coverage Status](https://coveralls.io/repos/github/grin-tech/grin/badge.svg?branch=master)](https://coveralls.io/github/grin-tech/grin?branch=master)
[![Gitter chat](https://badges.gitter.im/grin-tech/grin.png)](https://gitter.im/Grin-Development/Lobby)
[![Build Status](https://travis-ci.org/grin-compiler/grin.svg?branch=master)](https://travis-ci.org/grin-compiler/grin) [![Coverage Status](https://coveralls.io/repos/github/grin-compiler/grin/badge.svg?branch=master)](https://coveralls.io/github/grin-compiler/grin?branch=master)
[![Gitter chat](https://badges.gitter.im/grin-compiler/grin.png)](https://gitter.im/Grin-Development/Lobby)
The name GRIN is short for *Graph Reduction Intermediate Notation*, and it is an intermediate language for graph reduction.
For an overview read
<a href="http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/The GRIN Project.pdf">
The name GRIN is short for *Graph Reduction Intermediate Notation*, and it is an intermediate language for graph reduction. GRIN is the optimizer and code generator component of the GRIN Compiler project which includes language frontends for *Haskell*, *Idris* and *Agda*.
To get the big picture of the project check the [project website](https://grin-compiler.github.io/).
For an overview of the optimizer read
<a href="http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/The GRIN Project.pdf">
The GRIN Project
</a> article. To grasp the details take your time and read Urban Boquist's PhD thesis on
<a href="http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf">
</a> paper. To grasp the details take your time and read Urban Boquist's PhD thesis on
<a href="http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf">
Code Optimisation Techniques for Lazy Functional Languages
</a>.
We presented the core ideas of GRIN at Haskell Exchange 2018. [slides](https://docs.google.com/presentation/d/1QsZ3Kyy3XIco-qba1biRmzuMzz8o2uCBqA9DMtnqP2c/edit?usp=sharing) [video](https://skillsmatter.com/skillscasts/12390-grin-an-alternative-haskell-compiler-backend)
Also check the GRIN transformation [example from Boquist PhD](http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf#page=317) and an [example from our imlementation](https://github.com/grin-tech/grin/tree/master/grin/grin/sum-simple-output).
Read our paper [A modern look at GRIN, an optimizing functional language back end](http://nbviewer.jupyter.org/github/Anabra/grin/blob/fd9de6d3b9c7ec5f4aa7d6be41285359a73494e3/papers/stcs-2019/article/tex/main.pdf) (2019) to get an overview of GRIN related projects and other whole program compilers i.e. *Boquist GRIN, UHC, JHC, LHC, HRC, MLton*
<a href="http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf#page=41">
<img src="https://raw.githubusercontent.com/grin-tech/grin/master/images/grin-syntax.png" width="500" >
Also check the GRIN transformation [example from Boquist PhD](http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf#page=317) and an [example from our implementation](https://github.com/grin-compiler/grin/tree/master/grin/grin/sum-simple-output).
## Support
The project is supported by these awesome [backers](https://github.com/grin-compiler/grin/blob/master/BACKERS.md).
If you'd like to join them, please consider become a backer or sponsor on [Patreon](https://www.patreon.com/csaba_hruska).
<a href="https://www.patreon.com/csaba_hruska">
<img src="https://c5.patreon.com/external/logo/become_a_patron_button.png" width="150" >
</a>
### GRIN IR
<a href="http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf#page=41">
<img src="https://raw.githubusercontent.com/grin-compiler/grin/master/images/grin-syntax.png" width="500" >
</a>
## Showcase
![](https://pbs.twimg.com/media/Dpasi9OW4AAxpwi.jpg)
## Setup
### Installing LLVM
@ -29,7 +49,7 @@ Also check the GRIN transformation [example from Boquist PhD](http://nbviewer.ju
Example using Homebrew on macOS:
```bash
$ brew install llvm-hs/llvm/llvm-7.0
$ brew install llvm-hs/llvm/llvm-7
```
#### Debian/Ubuntu
@ -76,18 +96,18 @@ stack build
stack exec -- grin grin/grin/opt-stages-high-level/stage-00.grin
```
## How to Contribute
See: [Issues / Tasks for new contributors](https://github.com/grin-tech/grin/issues/3)
See: [Issues / Tasks for new contributors](https://github.com/grin-compiler/grin/issues/3)
Keep it simple: We follow the fundamentals laid down in [HaskellerZ - Feb 2018 - Getting things done in Haskell](https://www.youtube.com/watch?v=-X1vrxQUETM)
## Example Front-End
Read about how to <a href="http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf#page=64">generate GRIN code</a> from a frontend language.
Read about how to <a href="http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf#page=64">generate GRIN code</a> from a frontend language.
Also check the corresponding [source code](https://github.com/grin-tech/ghc-grin/tree/master/lambda-grin/src/Lambda).
Also check the corresponding [source code](https://github.com/grin-compiler/ghc-grin/tree/master/lambda-grin/src/Lambda).
i.e.
- [Lambda/Syntax.hs](https://github.com/grin-tech/ghc-grin/tree/master/lambda-grin/src/Lambda/Syntax.hs) - front-end language defintion
- [Lambda/GrinCodeGenBoxed.hs](https://github.com/grin-tech/ghc-grin/tree/master/lambda-grin/src/Lambda/GrinCodeGenBoxed.hs) - code generator from front-end language to grin
- [Lambda/Syntax.hs](https://github.com/grin-compiler/ghc-grin/tree/master/lambda-grin/src/Lambda/Syntax.hs) - front-end language defintion
- [Lambda/GrinCodeGenBoxed.hs](https://github.com/grin-compiler/ghc-grin/tree/master/lambda-grin/src/Lambda/GrinCodeGenBoxed.hs) - code generator from front-end language to grin
## Simplifying Transformations
@ -101,17 +121,17 @@ Transformation | Schema
[register introduction][126] <br><br> _source code:_ <br> [RegisterIntroduction.hs] | [<img src="images/register-introduction.png" width="500">][126]
[113]: http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf#page=113
[116]: http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf#page=116
[118]: http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf#page=118
[123]: http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf#page=123
[126]: http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf#page=126
[113]: http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf#page=113
[116]: http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf#page=116
[118]: http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf#page=118
[123]: http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf#page=123
[126]: http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf#page=126
[Vectorisation2.hs]: https://github.com/grin-tech/grin/blob/master/grin/src/Transformations/Simplifying/Vectorisation2.hs
[CaseSimplification.hs]: https://github.com/grin-tech/grin/blob/master/grin/src/Transformations/Simplifying/CaseSimplification.hs
[SplitFetch.hs]: https://github.com/grin-tech/grin/blob/master/grin/src/Transformations/Simplifying/SplitFetch.hs
[RightHoistFetch2.hs]: https://github.com/grin-tech/grin/blob/master/grin/src/Transformations/Simplifying/RightHoistFetch2.hs
[RegisterIntroduction.hs]: https://github.com/grin-tech/grin/blob/master/grin/src/Transformations/Simplifying/RegisterIntroduction.hs
[Vectorisation2.hs]: https://github.com/grin-compiler/grin/blob/master/grin/src/Transformations/Simplifying/Vectorisation2.hs
[CaseSimplification.hs]: https://github.com/grin-compiler/grin/blob/master/grin/src/Transformations/Simplifying/CaseSimplification.hs
[SplitFetch.hs]: https://github.com/grin-compiler/grin/blob/master/grin/src/Transformations/Simplifying/SplitFetch.hs
[RightHoistFetch2.hs]: https://github.com/grin-compiler/grin/blob/master/grin/src/Transformations/Simplifying/RightHoistFetch2.hs
[RegisterIntroduction.hs]: https://github.com/grin-compiler/grin/blob/master/grin/src/Transformations/Simplifying/RegisterIntroduction.hs
## Optimising Transformations
@ -130,56 +150,56 @@ Transformation | Schema
[case hoisting][153] <br><br> _source code:_ <br> [CaseHoisting.hs] <br><br> _test:_ <br> [CaseHoistingSpec.hs] | [<img src="images/case-hoisting.png" width="500">][153]
[whnf update elimination][149] <br><br> _source code:_ <br> __TODO__ <br><br> _test:_ <br> __TODO__ | [<img src="images/whnf-update-elimination.png" width="500">][149]
[common sub-expression elimination][164] <br><br> _source code:_ <br> [CSE.hs] <br><br> _test:_ <br> [CSESpec.hs] | [<img src="images/common-sub-expression-elimination-1.png" width="500"><img src="images/common-sub-expression-elimination-2.png" width="500">][164]
[constant propagation][159] <br><br> _source code:_ <br> [ConstantPropagation.hs] <br><br> _test:_ <br> [ConstantPropagationSpec.hs] |
[dead function elimination][169] <br><br> _source code:_ <br> [SimpleDeadFunctionElimination.hs] <br><br> _test:_ <br> [SimpleDeadFunctionEliminationSpec.hs] |
[dead variable elimination][170] <br><br> _source code:_ <br> [SimpleDeadVariableElimination.hs] <br><br> _test:_ <br> [SimpleDeadVariableEliminationSpec.hs] |
[dead parameter elimination][171] <br><br> _source code:_ <br> [SimpleDeadParameterElimination.hs] <br><br> _test:_ <br> [SimpleDeadParameterEliminationSpec.hs] |
[constant propagation][159] <br><br> _source code:_ <br> [ConstantPropagation.hs] <br><br> _test:_ <br> [ConstantPropagationSpec.hs] |
[dead function elimination][169] <br><br> _source code:_ <br> [SimpleDeadFunctionElimination.hs] <br><br> _test:_ <br> [SimpleDeadFunctionEliminationSpec.hs] |
[dead variable elimination][170] <br><br> _source code:_ <br> [SimpleDeadVariableElimination.hs] <br><br> _test:_ <br> [SimpleDeadVariableEliminationSpec.hs] |
[dead parameter elimination][171] <br><br> _source code:_ <br> [SimpleDeadParameterElimination.hs] <br><br> _test:_ <br> [SimpleDeadParameterEliminationSpec.hs] |
[129]: http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf#page=129
[134]: http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf#page=134
[141]: http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf#page=141
[142]: http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf#page=142
[143]: http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf#page=143
[144]: http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf#page=144
[148]: http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf#page=148
[149]: http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf#page=149
[151]: http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf#page=151
[153]: http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf#page=153
[159]: http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf#page=159
[160]: http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf#page=160
[164]: http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf#page=164
[169]: http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf#page=169
[170]: http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf#page=170
[171]: http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/boquist.pdf#page=171
[129]: http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf#page=129
[134]: http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf#page=134
[141]: http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf#page=141
[142]: http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf#page=142
[143]: http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf#page=143
[144]: http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf#page=144
[148]: http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf#page=148
[149]: http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf#page=149
[151]: http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf#page=151
[153]: http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf#page=153
[159]: http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf#page=159
[160]: http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf#page=160
[164]: http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf#page=164
[169]: http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf#page=169
[170]: http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf#page=170
[171]: http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/boquist.pdf#page=171
[ArityRaising.hs]: https://github.com/grin-tech/grin/blob/master/grin/src/Transformations/Optimising/ArityRaising.hs
[ConstantPropagation.hs]: https://github.com/grin-tech/grin/blob/master/grin/src/Transformations/Optimising/ConstantPropagation.hs
[CopyPropagation.hs]: https://github.com/grin-tech/grin/blob/master/grin/src/Transformations/Optimising/CopyPropagation.hs
[CaseCopyPropagation.hs]: https://github.com/grin-tech/grin/blob/master/grin/src/Transformations/Optimising/CaseCopyPropagation.hs
[CaseHoisting.hs]: https://github.com/grin-tech/grin/blob/master/grin/src/Transformations/Optimising/CaseHoisting.hs
[CSE.hs]: https://github.com/grin-tech/grin/blob/master/grin/src/Transformations/Optimising/CSE.hs
[EvaluatedCaseElimination.hs]: https://github.com/grin-tech/grin/blob/master/grin/src/Transformations/Optimising/EvaluatedCaseElimination.hs
[Inlining.hs]: https://github.com/grin-tech/grin/blob/master/grin/src/Transformations/Optimising/Inlining.hs
[SparseCaseOptimisation.hs]: https://github.com/grin-tech/grin/blob/master/grin/src/Transformations/Optimising/SparseCaseOptimisation.hs
[TrivialCaseElimination.hs]: https://github.com/grin-tech/grin/blob/master/grin/src/Transformations/Optimising/TrivialCaseElimination.hs
[UpdateElimination.hs]: https://github.com/grin-tech/grin/blob/master/grin/src/Transformations/Optimising/UpdateElimination.hs
[GeneralizedUnboxing.hs]: https://github.com/grin-tech/grin/blob/master/grin/src/Transformations/Optimising/GeneralizedUnboxing.hs
[SimpleDeadFunctionElimination.hs]: https://github.com/grin-tech/grin/blob/master/grin/src/Transformations/Optimising/SimpleDeadFunctionElimination.hs
[SimpleDeadVariableElimination.hs]: https://github.com/grin-tech/grin/blob/master/grin/src/Transformations/Optimising/SimpleDeadVariableElimination.hs
[SimpleDeadParameterElimination.hs]: https://github.com/grin-tech/grin/blob/master/grin/src/Transformations/Optimising/SimpleDeadParameterElimination.hs
[ArityRaising.hs]: https://github.com/grin-compiler/grin/blob/master/grin/src/Transformations/Optimising/ArityRaising.hs
[ConstantPropagation.hs]: https://github.com/grin-compiler/grin/blob/master/grin/src/Transformations/Optimising/ConstantPropagation.hs
[CopyPropagation.hs]: https://github.com/grin-compiler/grin/blob/master/grin/src/Transformations/Optimising/CopyPropagation.hs
[CaseCopyPropagation.hs]: https://github.com/grin-compiler/grin/blob/master/grin/src/Transformations/Optimising/CaseCopyPropagation.hs
[CaseHoisting.hs]: https://github.com/grin-compiler/grin/blob/master/grin/src/Transformations/Optimising/CaseHoisting.hs
[CSE.hs]: https://github.com/grin-compiler/grin/blob/master/grin/src/Transformations/Optimising/CSE.hs
[EvaluatedCaseElimination.hs]: https://github.com/grin-compiler/grin/blob/master/grin/src/Transformations/Optimising/EvaluatedCaseElimination.hs
[Inlining.hs]: https://github.com/grin-compiler/grin/blob/master/grin/src/Transformations/Optimising/Inlining.hs
[SparseCaseOptimisation.hs]: https://github.com/grin-compiler/grin/blob/master/grin/src/Transformations/Optimising/SparseCaseOptimisation.hs
[TrivialCaseElimination.hs]: https://github.com/grin-compiler/grin/blob/master/grin/src/Transformations/Optimising/TrivialCaseElimination.hs
[UpdateElimination.hs]: https://github.com/grin-compiler/grin/blob/master/grin/src/Transformations/Optimising/UpdateElimination.hs
[GeneralizedUnboxing.hs]: https://github.com/grin-compiler/grin/blob/master/grin/src/Transformations/Optimising/GeneralizedUnboxing.hs
[SimpleDeadFunctionElimination.hs]: https://github.com/grin-compiler/grin/blob/master/grin/src/Transformations/Optimising/SimpleDeadFunctionElimination.hs
[SimpleDeadVariableElimination.hs]: https://github.com/grin-compiler/grin/blob/master/grin/src/Transformations/Optimising/SimpleDeadVariableElimination.hs
[SimpleDeadParameterElimination.hs]: https://github.com/grin-compiler/grin/blob/master/grin/src/Transformations/Optimising/SimpleDeadParameterElimination.hs
[ArityRaisingSpec.hs]: https://github.com/grin-tech/grin/blob/master/grin/test/Transformations/Optimising/ArityRaisingSpec.hs
[ConstantPropagationSpec.hs]: https://github.com/grin-tech/grin/blob/master/grin/test/Transformations/Optimising/ConstantPropagationSpec.hs
[CopyPropagationSpec.hs]: https://github.com/grin-tech/grin/blob/master/grin/test/Transformations/Optimising/CopyPropagationSpec.hs
[CaseCopyPropagationSpec.hs]: https://github.com/grin-tech/grin/blob/master/grin/test/Transformations/Optimising/CaseCopyPropagationSpec.hs
[CaseHoistingSpec.hs]: https://github.com/grin-tech/grin/blob/master/grin/test/Transformations/Optimising/CaseHoistingSpec.hs
[CSESpec.hs]: https://github.com/grin-tech/grin/blob/master/grin/test/Transformations/Optimising/CSESpec.hs
[EvaluatedCaseEliminationSpec.hs]: https://github.com/grin-tech/grin/blob/master/grin/test/Transformations/Optimising/EvaluatedCaseEliminationSpec.hs
[InliningSpec.hs]: https://github.com/grin-tech/grin/blob/master/grin/test/Transformations/Optimising/InliningSpec.hs
[SparseCaseOptimisationSpec.hs]: https://github.com/grin-tech/grin/blob/master/grin/test/Transformations/Optimising/SparseCaseOptimisationSpec.hs
[TrivialCaseEliminationSpec.hs]: https://github.com/grin-tech/grin/blob/master/grin/test/Transformations/Optimising/TrivialCaseEliminationSpec.hs
[UpdateEliminationSpec.hs]: https://github.com/grin-tech/grin/blob/master/grin/test/Transformations/Optimising/UpdateEliminationSpec.hs
[GeneralizedUnboxingSpec.hs]: https://github.com/grin-tech/grin/blob/master/grin/test/Transformations/Optimising/GeneralizedUnboxingSpec.hs
[SimpleDeadFunctionEliminationSpec.hs]: https://github.com/grin-tech/grin/blob/master/grin/test/Transformations/Optimising/SimpleDeadFunctionEliminationSpec.hs
[SimpleDeadVariableEliminationSpec.hs]: https://github.com/grin-tech/grin/blob/master/grin/test/Transformations/Optimising/SimpleDeadVariableEliminationSpec.hs
[SimpleDeadParameterEliminationSpec.hs]: https://github.com/grin-tech/grin/blob/master/grin/test/Transformations/Optimising/SimpleDeadParameterEliminationSpec.hs
[ArityRaisingSpec.hs]: https://github.com/grin-compiler/grin/blob/master/grin/test/Transformations/Optimising/ArityRaisingSpec.hs
[ConstantPropagationSpec.hs]: https://github.com/grin-compiler/grin/blob/master/grin/test/Transformations/Optimising/ConstantPropagationSpec.hs
[CopyPropagationSpec.hs]: https://github.com/grin-compiler/grin/blob/master/grin/test/Transformations/Optimising/CopyPropagationSpec.hs
[CaseCopyPropagationSpec.hs]: https://github.com/grin-compiler/grin/blob/master/grin/test/Transformations/Optimising/CaseCopyPropagationSpec.hs
[CaseHoistingSpec.hs]: https://github.com/grin-compiler/grin/blob/master/grin/test/Transformations/Optimising/CaseHoistingSpec.hs
[CSESpec.hs]: https://github.com/grin-compiler/grin/blob/master/grin/test/Transformations/Optimising/CSESpec.hs
[EvaluatedCaseEliminationSpec.hs]: https://github.com/grin-compiler/grin/blob/master/grin/test/Transformations/Optimising/EvaluatedCaseEliminationSpec.hs
[InliningSpec.hs]: https://github.com/grin-compiler/grin/blob/master/grin/test/Transformations/Optimising/InliningSpec.hs
[SparseCaseOptimisationSpec.hs]: https://github.com/grin-compiler/grin/blob/master/grin/test/Transformations/Optimising/SparseCaseOptimisationSpec.hs
[TrivialCaseEliminationSpec.hs]: https://github.com/grin-compiler/grin/blob/master/grin/test/Transformations/Optimising/TrivialCaseEliminationSpec.hs
[UpdateEliminationSpec.hs]: https://github.com/grin-compiler/grin/blob/master/grin/test/Transformations/Optimising/UpdateEliminationSpec.hs
[GeneralizedUnboxingSpec.hs]: https://github.com/grin-compiler/grin/blob/master/grin/test/Transformations/Optimising/GeneralizedUnboxingSpec.hs
[SimpleDeadFunctionEliminationSpec.hs]: https://github.com/grin-compiler/grin/blob/master/grin/test/Transformations/Optimising/SimpleDeadFunctionEliminationSpec.hs
[SimpleDeadVariableEliminationSpec.hs]: https://github.com/grin-compiler/grin/blob/master/grin/test/Transformations/Optimising/SimpleDeadVariableEliminationSpec.hs
[SimpleDeadParameterEliminationSpec.hs]: https://github.com/grin-compiler/grin/blob/master/grin/test/Transformations/Optimising/SimpleDeadParameterEliminationSpec.hs

20
docs/AbstractInterpretation.md
View File

@ -19,10 +19,30 @@ method: compiled abstract interpretation
- https://en.wikipedia.org/wiki/Data-flow_analysis
- https://en.wikipedia.org/wiki/Abstract_interpretation
### points-to analysis
- [Pointer analysis overview (CMU)](http://www.cs.cmu.edu/afs/cs/academic/class/15745-s11/public/lectures/L27-Pointer-Analysis.pdf)
- [Pointer analysis overview (IAState)](http://web.cs.iastate.edu/~weile/cs513x/2.PointerAnalysis.pdf)
- [Lecture Notes: Pointer Analysis](https://www.cs.cmu.edu/~aldrich/courses/15-819O-13sp/resources/pointer.pdf)
- [Pointer Analysis Tutorial](https://yanniss.github.io/points-to-tutorial15.pdf)
- [Cloning-Based Context-Sensitive Pointer Alias Analysis Using Binary Decision Diagrams](https://suif.stanford.edu/papers/pldi04.pdf)
- [Points-to Analysis in Almost Linear Time](https://www.cs.cornell.edu/courses/cs711/2005fa/papers/steensgaard-popl96.pdf)
- [Fast and accurate flow-insensitive points-to analysis](http://www.cs.utexas.edu/users/pingali/CS380C/2007fa/papers/popl97.pdf)
### relation of dataflow analysis, abstract interpretation and type inference
- [Equivalence of data-flow analysis, abstract interpretation and type inference?](https://cs.stackexchange.com/questions/30746/equivalence-of-data-flow-analysis-abstract-interpretation-and-type-inference)
- [Types as Abstract Interpretations](https://www.irif.fr/~mellies/mpri/mpri-ens/articles/cousot-types-as-abstract-interpretations.pdf)
- [Principles of Program Analysis](http://www.imm.dtu.dk/~hrni/PPA/ppa.html) book
### search for: abstract compilation
- http://www.iro.umontreal.ca/~feeley/papers/BoucherFeeleyCC96.pdf ; Abstract compilation: A new implementation paradigm for static analysis
- https://pdfs.semanticscholar.org/5ad8/cb6b477793ffb5ec29dde89df6b82dbb6dba.pdf ; A Graph–Free Approach to Data–Flow Analysis
### efficient implementation
- [EigenCFA: Accelerating Flow Analysis with GPUs](http://matt.might.net/papers/prabhu2011eigencfa.pdf)
- [A GPU Implementation of Inclusion-based Points-to Analysis](https://userweb.cs.txstate.edu/~mb92/papers/ppopp12.pdf)
- [Parallel Inclusion-based Points-to Analysis](http://iss.ices.utexas.edu/Publications/Papers/oopsla10-mendezlojo.pdf)
## Notes
- HPT is liberal as much as possible; allow variadic case type (i.e. ANY -> ANY)

44
docs/Analysis-Experiment.md Normal file
View File

@ -0,0 +1,44 @@
# Analysis Experiment
Compare Andersen style (inclusion based) and Steensgaard (unification based) points-to analyses.
Compare dataflow approach with unfication approach in general.
Check runtime and memory efficiency of:
- precise vs imprecise analyses
- dataflow vs unicification approach
- optimize early (STG/Lambda) vs optimize late (GRIN)
Tools:
- dataflow: [Souffle](https://github.com/souffle-lang/souffle)
- unification: [unifiacion-fd](https://github.com/wrengr/unification-fd)
TODO/Experiments:
- add closure constructor support for lambda
- keep closures in lambda
- lambda type inference (unification)
- experiment: stg/lambda level whole program analysis
- with explicit stg-style closure representaion in lambda track closures and it's saturation status ; this could subsume grin's eval/apply tracking/approximation
- implement andersen style: with souffle
- closure tacker ; generate specialised eval and Pnode constructions during lambda -> grin compilation
- accurate live variable/datafield analysis
- inaccurate live variable/datafield analysis
- implement steensgaard as typeinference: with unification-fd
- lambda
- grin
- material:
- https://github.com/wrengr/unification-fd
- https://fineshambles.com/2017/07/26/a-type-inference-implementation-adventure/
- https://winterkoninkje.dreamwidth.org/tag/unification
- https://ro-che.info/articles/2017-06-17-generic-unification
- http://nochair.net/posts/2012/03-29-unification-fd.html
- https://bl.ocks.org/nponeccop/631dfba9180f8fa3020dff82df3290a3
- other:
- https://github.com/willtim/Expresso
- https://github.com/willtim/row-polymorphism
### Context Sensitivity
It seem extremely beneficial to use Context Sensitive Analysis:
- [Alternate Control-Flow Analyses for Defunctionalization in the MLton Compiler](https://www.cs.rit.edu/~mtf/student-resources/20155_shea_mscourse.pdf)
- [Pushdown Control-Flow Analysis for Free](https://arxiv.org/abs/1507.03137)
- [A model of context-sensitive pointer analysis](https://www.youtube.com/watch?v=vcj9uvRkCnc&list=PLRUJ115QHa0WMyGyP2j_1KRFJjaT0kFOu&index=3&t=0s) (video)

4
docs/GRIN-LLVM-CodeGen.md
View File

@ -120,3 +120,7 @@ Node operations:
- hash cons TypeEnv to get rid of duplicate types
- use better variable names in the generated LLVM IR
- remove special heap pointer handling from codegen ; expose it in GRIN via a transfromation ; heap pointer should be a parameter and return value of `store`.
## Readings
- https://mapping-high-level-constructs-to-llvm-ir.readthedocs.io/en/latest/README.html

5
docs/MemoryManagement.md
View File

@ -9,7 +9,10 @@
## Compile time garbage collection
[ASAP: As Static As Possible memory management](http://www.cl.cam.ac.uk/techreports/UCAM-CL-TR-908.html)
related: [Dead data elimination](http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/MoL-2010-19.text.pdf#page=55) in [A modern back-end for a dependently typed language](http://nbviewer.jupyter.org/github/grin-tech/grin/blob/master/papers/MoL-2010-19.text.pdf)
related: [Dead data elimination](http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/MoL-2010-19.text.pdf#page=55) in [A modern back-end for a dependently typed language](http://nbviewer.jupyter.org/github/grin-compiler/grin/blob/master/papers/MoL-2010-19.text.pdf)
## Sample Project
[Sample project](https://github.com/robinvd/lang-experiments) for LLVM stack map based GC.
## Readings
- http://craftinginterpreters.com/garbage-collection.html

21
docs/Milestone-2.md
View File

@ -9,22 +9,23 @@ duration: 2 weeks
deadline: May 6
### new additions
- [ ] module system
- [ ] name handling
- [ ] locally new names (in block + pass to flatten out and maintain uniqueness)
- [ ] name scopes (module, function)
- [ ] liberal name support (like in llvm, i.e. %"any characer 1234 {}!@#$%} -"
- ~~module system~~
- [x] name handling
- [x] SSA name conversion pass to allow local name scopes
- ~~locally new names (in block + pass to flatten out and maintain uniqueness)~~
- ~~name scopes (module, function)~~
- [x] liberal name support (like in llvm, i.e. %"any characer 1234 {}!@#$%} -"
- [ ] context aware logging framework (for errors and debugging)
- [x] pass manager ; run passes until the fixpoint is reached
- ~~add `allocate` memory operation to grin ; required by circular data structures~~
- [ ] grin syntax for type signatures
- [ ] grin syntax to declare primops with their type signature
- [ ] grin validator pass
- [x] grin syntax for type signatures
- [x] grin syntax to declare primops with their type signature
- [x] grin validator pass
- ~~hpt result based dead code elimination pass~~
### finish
- [ ] lambda frontend
- [ ] type system
- [x] lambda frontend
- [x] type system
- [ ] simplification transformations (answer if vectorisation equals with a mapping to tagged unions)
- [ ] missing optimisations
- [x] case hoisting

4
docs/Readings.md
View File

@ -54,8 +54,8 @@ http://b-studios.de/blog/2016/02/21/the-hitchhikers-guide-to-morphisms/
### Recursion schemes
<img src="images/recursion-schemes-cheat-sheet.svg" style="max-width: 100%; max-height: 100vh; height: auto;">
<img src="https://github.com/grin-compiler/grin/blob/master/images/recursion-schemes-cheat-sheet.svg" style="max-width: 100%; max-height: 100vh; height: auto;">
### Algebras
<img src="images/algebras.svg" style="max-width: 100%; max-height: 100vh; height: auto;">
<img src="https://github.com/grin-compiler/grin/blob/master/images/algebras.svg" style="max-width: 100%; max-height: 100vh; height: auto;">

6
docs/TODO.md
View File

@ -26,7 +26,6 @@
- LLVM backend for HPT IR
- inline support
- sharing analysis
# SIMD / SPMD
- [The story of ispc](http://pharr.org/matt/blog/2018/04/30/ispc-all.html)
@ -38,3 +37,8 @@
### shared blocks
- add support for named blocks and a corresponding call block command i.e. `tailcall` / `continue` / `join` / `follow` __BLOCK_NAME__
### STG primops
- add primops to support STG style unknown funtion call. Whith these primops incremental compilation could be supported
- static analysis of STG primops to transform STG closures and info tables to ordinary GRIN C/F/P nodes

9
grin/LICENSE
View File

@ -1,4 +1,4 @@
Copyright (c) 2017, Andor Pénzes, Csaba Hruska
Copyright (c) 2017, Andor Pénzes, Csaba Hruska, Péter Podlovics
All rights reserved.
@ -13,9 +13,10 @@ modification, are permitted provided that the following conditions are met:
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Csaba Hruska, Peter Divianszky nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
* Neither the name of Andor Pénzes, Csaba Hruska, Péter Podlovics
nor the names of other contributors may be used to endorse or
promote products derived from this software without specific
prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

99
grin/app/GrinCLI.hs → grin/app/CLI/Lib.hs
View File

@ -1,14 +1,19 @@
{-# LANGUAGE LambdaCase #-}
module Main where
module CLI.Lib where
import Control.Monad
import Data.Map as Map
import Data.Map (Map(..))
import qualified Data.Map as Map
import Data.Char
import Data.Void
import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))
import qualified Data.Text.IO as Text
import qualified Text.Megaparsec as M
import qualified Text.Megaparsec.Char as M
import qualified Data.Binary as Binary
import Options.Applicative
import System.IO
import Grin.Grin
import Grin.PrimOpsPrelude
@ -16,6 +21,8 @@ import Grin.Parse -- hiding (value)
import Grin.Nametable as Nametable
import Pipeline.Pipeline
data Options = Options
{ optFiles :: [FilePath]
, optTrans :: [PipelineStep]
@ -24,6 +31,7 @@ data Options = Options
, optQuiet :: Bool
, optLoadBinary :: Bool
, optSaveBinary :: Bool
, optCFiles :: [FilePath]
} deriving Show
flg c l h = flag' c (mconcat [long l, help h])
@ -36,6 +44,7 @@ transformOpts =
<|> flg Vectorisation "v" "Vectorisation"
<|> flg RegisterIntroduction "ri" "Register Introduction"
<|> flg ProducerNameIntroduction "pni" "Producer Name Introduction"
<|> flg BindingPatternSimplification "bps" "Binding Pattern Simplification"
<|> flg InlineEval "ie" "Inline Eval"
<|> flg InlineApply "ia" "Inline Apply"
<|> flg BindNormalisation "bn" "Bind Normalisation"
@ -71,6 +80,7 @@ pipelineOpts =
<|> flg (HPT Compile) "compile-hpt" "Compiles heap-points-to analysis machine"
<|> flg (HPT Optimise) "optimize-hpt" "Optimizes heap-points-to analysis abstract program"
<|> flg (HPT PrintProgram) "print-hpt-code" "Prints the heap-points-to analysis machine"
<|> (HPT . SaveProgram <$> (strOption (mconcat [long "save-hpt-code", help "Saves the heap-points-to analysis machine"])))
<|> flg (HPT RunPure) "run-hpt-pure" "Runs the heap-points-to analysis machine via pure interpreter"
<|> flg (HPT PrintResult) "print-hpt-result" "Prints the heap-points-to analysis result"
<|> flg (CBy Compile) "compile-cby" "Compiles created-by analysis machine"
@ -83,6 +93,11 @@ pipelineOpts =
<|> flg (LVA PrintProgram) "print-lva-code" "Prints the live variable analysis machine"
<|> flg (LVA RunPure) "run-lva-pure" "Runs the live variable analysis machine via pure interpreter"
<|> flg (LVA PrintResult) "print-lva-result" "Prints the live variable analysis result"
<|> flg (ET Compile) "compile-et" "Compiles effect tracking analysis machine"
<|> flg (ET Optimise) "optimize-et" "Optimizes effect tracking analysis abstract program"
<|> flg (ET PrintProgram) "print-et-code" "Prints the effect tracking analysis machine"
<|> flg (ET RunPure) "run-et-pure" "Runs the effect tracking analysis machine via pure interpreter"
<|> flg (ET PrintResult) "print-et-result" "Prints the effect tracking analysis result"
<|> flg (Sharing Compile) "compile-sharing" "Compiles sharing analysis machine"
<|> flg (Sharing Optimise) "optimize-sharing" "Optimizes sharing analyis abstract program"
<|> flg (Sharing PrintProgram) "print-sharing-code" "Prints the sharing analysis machine"
@ -91,37 +106,65 @@ pipelineOpts =
<|> flg' (Eff CalcEffectMap) 'e' "em" "Calculate the effect for functions"
<|> flg (Eff PrintEffectMap) "pe" "Print effect map"
<|> flg' Lint 'l' "lint" "Checks the well-formedness of the actual grin code"
<|> flg' (PrintGrin id) 'p' "print-grin" "Prints the actual grin code"
<|> flg' (SimplePrintGrin id) 'p' "simple-print-grin" "Print the actual grin code without externals" <|> printGrinWithOpt
<|> flg PrintTypeAnnots "print-type-annots" "Prints the type env calculated from the annotations in the source"
<|> flg PrintTypeEnv "te" "Prints type env"
<|> flg' (Pass [HPT Compile, HPT RunPure]) 't' "hpt" "Compiles and runs the heap-points-to analysis"
<|> flg' (Pass [CBy Compile, CBy RunPure]) 'c' "cby" "Compiles and runs the created-by analysis"
<|> flg' (Pass [LVA Compile, LVA RunPure]) 'v' "lva" "Compiles and runs the live variable analysis"
<|> flg (Pass [ET Compile, ET RunPure]) "et" "Compiles and runs the effect tracking analysis"
<|> flg' (Pass [Sharing Compile, Sharing RunPure]) 's' "sharing" "Compiles and runs the sharing analysis"
<|> flg (Pass [HPT Compile, HPT Optimise, HPT RunPure]) "hpt-opt" "Compiles, optimizes and runs the heap-points-to analysis"
<|> flg (Pass [CBy Compile, CBy Optimise, CBy RunPure]) "cby-opt" "Compiles, optimizes and runs the created-by analysis"
<|> flg (Pass [LVA Compile, LVA Optimise, LVA RunPure]) "lva-opt" "Compiles, optimizes and runs the live variable analysis"
<|> flg (Pass [ET Compile, ET Optimise, ET RunPure]) "et-opt" "Compiles, optimizes and runs the effect tracking analysis"
<|> flg (Pass [Sharing Compile, Sharing Optimise, Sharing RunPure]) "sharing-opt" "Compiles, optimizes and runs the sharing analysis"
<|> flg (Pass [LVA Compile, CBy Compile, RunCByWithLVA]) "cby-with-lva" "Compiles the live variable and created-by analyses, then runs the created-by analysis using the LVA result"
<|> flg DeadCodeElimination "dce" "Dead Code Elimination"
<|> flg PureEval "eval" "Evaluate the grin program (pure)"
<|> flg JITLLVM "llvm" "JIT with LLVM"
<|> flg PrintAST "ast" "Print the Abstract Syntax Tree"
<|> (SaveLLVM True <$> (strOption (mconcat [long "save-llvm", help "Save the generated llvm"])))
<|> (SaveExecutable False . Abs <$> (strOption (mconcat [short 'o', long "save-elf", help "Save an executable ELF"])))
<|> (SaveExecutable True . Abs <$> (strOption (mconcat [short 'o', long "save-elf-dbg", help "Save an executable ELF with debug symbols"])))
<|> (SaveLLVM . Abs <$> (strOption (mconcat [long "save-llvm", help "Save the generated llvm"])))
<|> (SaveGrin . Abs <$> (strOption (mconcat [long "save-grin", help "Save the generated grin"])))
<|> (SaveBinary <$> (strOption (mconcat [long "save-binary", help "Save the generated grin in binary format"])))
<|> (T <$> transformOpts)
<|> flg ConfluenceTest "confluence-test" "Checks transformation confluence by generating random two pipelines which reaches the fix points."
<|> flg PrintErrors "print-errors" "Prints the error log"
options :: IO Options
options = execParser $ info
(pipelineArgs <**> helper)
(mconcat
[ fullDesc
, progDesc "grin compiler"
, header "grin compiler"
])
maybeRenderingOpt :: String -> Maybe RenderingOption
maybeRenderingOpt = M.parseMaybe renderingOpt
renderingOpt :: M.Parsec Void String RenderingOption
renderingOpt = Simple <$ M.string "simple"
<|> WithExternals <$ M.string "with-externals"
{- NOTE: Cannot use default in some/many combinators.
The library considers default value as:
"nothing is given, then use default",
but we want it to behave like:
"if the flag is parsed, and no argument is given, then use default"
-}
printGrinWithOpt :: Parser PipelineStep
printGrinWithOpt = flip PrintGrin id <$> option (maybeReader maybeRenderingOpt)
( long "print-grin"
<> help "Print the actual grin code with a given rendering option [simple | with-externals]"
<> metavar "OPT" )
options :: [String] -> IO Options
options args = do
let res = execParserPure defaultPrefs
(info
(pipelineArgs <**> helper)
(mconcat
[ fullDesc
, progDesc "grin compiler"
, header "grin compiler"
]))
args
handleParseResult res
where
pipelineArgs = Options
<$> some (argument str (metavar "FILES..."))
@ -149,10 +192,24 @@ options = execParser $ info
[ long "save-binary-intermed"
, help "Save intermediate results in binary format"
])
<*> many (strOption (mconcat
[ short 'C'
, long "c-file"
, help "The path for the runtime implementation in C"]))
main :: IO ()
main = do
Options files steps outputDir noPrelude quiet loadBinary saveBinary <- options
mainWithArgs :: [String] -> IO ()
mainWithArgs args = do
hSetBuffering stdout NoBuffering
Options
files
steps
outputDir
noPrelude
quiet
loadBinary
saveBinary
cFiles
<- options args
forM_ files $ \fname -> do
(mTypeEnv, program) <- if loadBinary
then do
@ -161,15 +218,21 @@ main = do
content <- Text.readFile fname
let (typeEnv, program') = either (error . M.errorBundlePretty) id $ parseGrinWithTypes fname content
pure $ (Just typeEnv, if noPrelude then program' else concatPrograms [primPrelude, program'])
let opts = defaultOpts { _poOutputDir = outputDir, _poFailOnLint = True, _poLogging = not quiet, _poSaveBinary = saveBinary }
let opts = defaultOpts
{ _poOutputDir = outputDir
, _poFailOnLint = True
, _poLogging = not quiet
, _poSaveBinary = saveBinary
, _poCFiles = cFiles
}
case steps of
[] -> void $ optimize opts program [] postPipeline
_ -> void $ pipeline opts mTypeEnv program steps
postPipeline :: [PipelineStep]
postPipeline =
[ SaveLLVM True "high-level-opt-code"
[ SaveLLVM $ Rel "high-level-opt-code"
, JITLLVM -- TODO: Remove this.
, PrintTypeEnv
, PrintGrin ondullblack
, SimplePrintGrin ondullblack
]

10
grin/app/CLI/Main.hs Normal file
View File

@ -0,0 +1,10 @@
module Main where
import System.Environment (getArgs)
import CLI.Lib (mainWithArgs)
main :: IO ()
main = do
args <- getArgs
mainWithArgs args

118
grin/grin.cabal
View File

@ -23,6 +23,10 @@ library
AbstractInterpretation.CreatedBy.CodeGen
AbstractInterpretation.CreatedBy.CodeGenBase
AbstractInterpretation.CreatedBy.Pretty
AbstractInterpretation.EffectTracking.Result
AbstractInterpretation.EffectTracking.CodeGen
AbstractInterpretation.EffectTracking.CodeGenBase
AbstractInterpretation.EffectTracking.Pretty
AbstractInterpretation.HeapPointsTo.CodeGen
AbstractInterpretation.HeapPointsTo.CodeGenBase
AbstractInterpretation.HeapPointsTo.Pretty
@ -35,7 +39,10 @@ library
AbstractInterpretation.LiveVariable.Result
AbstractInterpretation.LiveVariable.Pretty
AbstractInterpretation.IR
AbstractInterpretation.BinaryIR
AbstractInterpretation.PrettyIR
AbstractInterpretation.BinaryResult
AbstractInterpretation.ReduceCpp
AbstractInterpretation.Reduce
AbstractInterpretation.Util
AbstractInterpretation.OptimiseAbstractProgram
@ -76,7 +83,6 @@ library
Test.Check
Test.Grammar
Test.IO
Test.PrimOps
Test.Test
Test.Util
Transformations.BindNormalisation
@ -111,6 +117,7 @@ library
Transformations.Optimising.NonSharedElimination
Transformations.Simplifying.CaseSimplification
Transformations.Simplifying.ProducerNameIntroduction
Transformations.Simplifying.BindingPatternSimplification
Transformations.Simplifying.RegisterIntroduction
Transformations.Simplifying.RightHoistFetch2
Transformations.Simplifying.SplitFetch
@ -169,7 +176,7 @@ library
executable grin
hs-source-dirs: app
main-is: GrinCLI.hs
main-is: CLI/Main.hs
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends: base >=4.11
, grin
@ -190,11 +197,13 @@ executable grin
, optparse-applicative
, directory
, binary
other-modules:
CLI.Lib
default-language: Haskell2010
test-suite grin-test
type: exitcode-stdio-1.0
hs-source-dirs: test
hs-source-dirs: test, app
main-is: Spec.hs
default-extensions: OverloadedStrings
build-depends: base >=4.11
@ -215,6 +224,16 @@ test-suite grin-test
, mtl
, ansi-wl-pprint
, directory
, inline-c
, directory-tree
, yaml
, binary
, optparse-applicative
, megaparsec
, system-posix-redirect
, process
, bytestring
, MissingH
other-modules:
Transformations.Simplifying.RegisterIntroductionSpec
@ -223,6 +242,7 @@ test-suite grin-test
Transformations.Simplifying.RightHoistFetchSpec
Transformations.Simplifying.VectorisationSpec
Transformations.Simplifying.ProducerNameIntroductionSpec
Transformations.Simplifying.BindingPatternSimplificationSpec
Transformations.Optimising.CaseCopyPropagationSpec
Transformations.Optimising.CopyPropagationSpec
Transformations.Optimising.ConstantFoldingSpec
@ -253,16 +273,108 @@ test-suite grin-test
TestSpec
PipelineSpec
ParserSpec
PrimOpsSpec
NametableSpec
AbstractInterpretation.HptSpec
AbstractInterpretation.LiveVariableSpec
AbstractInterpretation.EffectTrackingSpec
AbstractInterpretation.IRSpec
AbstractInterpretation.OptimiseAbstractProgramSpec
AbstractInterpretation.SharingSpec
AbstractInterpretation.CreatedBySpec
Test.Hspec.PipelineExample
Test.EndToEnd
Test.EndToEndSpec
CLI.Lib
default-language: Haskell2010
test-suite grin-end-to-end-test
type: exitcode-stdio-1.0
hs-source-dirs: test, app
main-is: EndToEnd.hs
default-extensions: OverloadedStrings
build-depends: base >=4.11
, containers
, filepath
, functor-infix
, grin
, hspec
, hspec-core
, hspec-discover
, QuickCheck
, deepseq
, vector
, text
, random
, microlens
, transformers
, mtl
, ansi-wl-pprint
, directory
, inline-c
, directory-tree
, yaml
, megaparsec
, binary
, optparse-applicative
, system-posix-redirect
, process
, bytestring
, MissingH
other-modules:
Transformations.Simplifying.RegisterIntroductionSpec
Transformations.Simplifying.CaseSimplificationSpec
Transformations.Simplifying.SplitFetchSpec
Transformations.Simplifying.RightHoistFetchSpec
Transformations.Simplifying.VectorisationSpec
Transformations.Simplifying.ProducerNameIntroductionSpec
Transformations.Simplifying.BindingPatternSimplificationSpec
Transformations.Optimising.CaseCopyPropagationSpec
Transformations.Optimising.CopyPropagationSpec
Transformations.Optimising.ConstantFoldingSpec
Transformations.Optimising.ConstantPropagationSpec
Transformations.Optimising.EvaluatedCaseEliminationSpec
Transformations.Optimising.TrivialCaseEliminationSpec
Transformations.Optimising.SparseCaseOptimisationSpec
Transformations.Optimising.UpdateEliminationSpec
Transformations.Optimising.CSESpec
Transformations.Optimising.GeneralizedUnboxingSpec
Transformations.Optimising.ArityRaisingSpec
Transformations.Optimising.SimpleDeadFunctionEliminationSpec
Transformations.Optimising.SimpleDeadParameterEliminationSpec
Transformations.Optimising.SimpleDeadVariableEliminationSpec
Transformations.Optimising.InliningSpec
Transformations.Optimising.CaseHoistingSpec
Transformations.Optimising.DeadDataEliminationSpec
Transformations.Optimising.DeadFunctionEliminationSpec
Transformations.Optimising.DeadParameterEliminationSpec
Transformations.Optimising.DeadVariableEliminationSpec
Transformations.StaticSingleAssignmentSpec
Transformations.BindNormalisationSpec
Transformations.ConfluenceSpec
Transformations.MangleNamesSpec
Samples.SumListSpec
Samples.ArityFullRemoveSpec
LintSpec
TestSpec
PipelineSpec
ParserSpec
PrimOpsSpec
NametableSpec
AbstractInterpretation.HptSpec
AbstractInterpretation.LiveVariableSpec
AbstractInterpretation.EffectTrackingSpec
AbstractInterpretation.IRSpec
AbstractInterpretation.OptimiseAbstractProgramSpec
AbstractInterpretation.SharingSpec
AbstractInterpretation.CreatedBySpec
Test.Hspec.PipelineExample
Test.EndToEnd
Test.EndToEndSpec
CLI.Lib
default-language: Haskell2010
benchmark grin-benchmark
type: exitcode-stdio-1.0
hs-source-dirs: test

14
grin/grin/live-variable/case_backward_propagation.grin
View File

@ -1,14 +0,0 @@
grinMain =
n0 <- f 0
case n0 of
(CInt c0) -> (CInt b0) <- pure n0
pure b0
(CBool c1) -> pure c1
#default -> (CWord b1) <- pure n0
pure b1
f x =
case x of
0 -> pure (CInt 0)
1 -> pure (CBool 0)
2 -> pure (CWord 0)

18
grin/grin/live-variable/case_backward_propagation_nodes.grin
View File

@ -1,18 +0,0 @@
grinMain =
n0 <- f 0
n4 <- case n0 of
(CInt c0) -> (CInt b0) <- pure n0
n1 <- f b0
pure n1
(CBool c1) -> n2 <- f c1
pure n2
#default -> (CWord b1) <- pure n0
n3 <- f b1
pure n3
pure n4
f x =
case x of
0 -> pure (CInt 0)
1 -> pure (CBool 0)
2 -> pure (CWord 0)

11
grin/grin/live-variable/fields.grin
View File

@ -1,11 +0,0 @@
grinMain =
a0 <- pure 0
a1 <- pure 1
n0 <- pure (CNode a0 a1)
case n0 of
(CNode c0 c1) -> n1 <- pure (CNode c0 c1)
f n1
f x =
case x of
(CNode c2 c3) -> pure c3

9
grin/grin/live-variable/function_call_1.grin
View File

@ -1,9 +0,0 @@
grinMain =
n <- pure (CFoo 0)
y <- f n
pure y
f x =
case x of
(CFoo c0) -> pure c0
(CBar c1) -> pure 5

10
grin/grin/live-variable/function_call_2.grin
View File

@ -1,10 +0,0 @@
grinMain =
(CTwo a1 b1) <- f
n <- pure (COne a1)
pure n
f =
a0 <- pure 0
b0 <- pure 0
pure (CTwo a0 b0)

7
grin/grin/live-variable/heap_case.grin
View File

@ -1,7 +0,0 @@
grinMain =
a0 <- pure (CBool 0)
p0 <- case a0 of
(CWord c0) -> store (CWord c0)
(CBool c1) -> store (CBool c1)
(CBool a1) <- fetch p0
pure a1

5
grin/grin/live-variable/heap_case_min.grin
View File

@ -1,5 +0,0 @@
grinMain =
p0 <- case (CBool 0) of
(CBool c1) -> store (CBool c1)
(CBool a1) <- fetch p0
pure a1

6
grin/grin/live-variable/heap_simple.grin
View File

@ -1,6 +0,0 @@
grinMain =
n <- pure (CTwo 0 1)
p <- store n
x <- fetch p
(CTwo a b) <- pure x
pure a

6
grin/grin/live-variable/lit_pat.grin
View File

@ -1,6 +0,0 @@
grinMain =
y <- pure 0
5 <- f y
pure 0
f x = pure x

5
grin/grin/live-variable/main_node_ret_1.grin
View File

@ -1,5 +0,0 @@
grinMain =
a <- pure 0
b <- pure 0
n <- pure (CTwo a b)
pure n

4
grin/grin/live-variable/main_node_ret_2.grin
View File

@ -1,4 +0,0 @@
grinMain =
a <- pure 0
b <- pure 0
pure (CTwo a b)

14
grin/grin/live-variable/node_test.grin
View File

@ -1,14 +0,0 @@
grinMain =
n0 <- pure (COne 0)
n1 <- pure (CTwo 0 1)
t <- f 0
n2 <- pure (t 0 1)
case n2 of
(COne c0) -> pure 5
(CTwo c1 c2) -> pure 5
pure 5
f x =
case x of
1 -> pure (COne)
2 -> pure (CTwo)

13
grin/grin/live-variable/nodes.grin
View File

@ -1,13 +0,0 @@
grinMain =
a0 <- pure 0
a1 <- pure 1
a2 <- pure 2
n0 <- f a0 a1 a2
case n0 of
(CInt c0) -> pure c0
(CBool c1) -> pure 5
f x y z =
case x of
0 -> pure (CInt y)
1 -> pure (CBool z)

12
grin/grin/live-variable/sum_opt.grin
View File

@ -1,12 +0,0 @@
grinMain =
n13 <- sum 0 1 100000
_prim_int_print n13
sum n29 n30 n31 =
b2 <- _prim_int_gt n30 n31
if b2 then
pure n29
else
n18 <- _prim_int_add n30 1
n28 <- _prim_int_add n29 n30
sum n28 n18 n31

10
grin/grin/live-variable/tricky_nodes.grin
View File

@ -1,10 +0,0 @@
grinMain =
n0 <- f 0
case n0 of
(COne c0 c1) -> pure 5
(CTwo c2 c3) -> pure 5
f x =
case x of
0 -> pure (COne x)
1 -> pure (CTwo 0 x)

243
grin/prim_ops.c Normal file
View File

@ -0,0 +1,243 @@
#include <stdio.h>
#include <stdlib.h>
#include <inttypes.h>
#include <stdbool.h>
#include <string.h>
#include <unistd.h>
#include "prim_ops.h"
#define BUFFER_SIZE 256
/*
NOTES:
* In error cases we just simple exit as this part is still under active development.
* _prim_ffi_file_eof is a placeholder implementation.
*/
struct string* create_string_len(int64_t l) {
struct string* r = (struct string*)malloc(sizeof(struct string));
r->data = (char*)calloc(sizeof(char), l * sizeof(char));
r->length = l;
#ifdef DEBUG
printf("create_string_len(%ld) = %d\n", l, (int)r);
#endif
return r;
}
struct string* create_string_copy(char* str) {
struct string* r = (struct string*)malloc(sizeof(struct string));
int64_t l = strlen(str);
r->data = (char*)malloc(l * sizeof(char));
strncpy(r->data, str, l);
r->length = l;
#ifdef DEBUG
printf("create_string_copy(\"%s\") = %d\n", str, (int)r);
#endif
return r;
}
void cstring(char* buffer, struct string* s){
memcpy(buffer, s->data, s->length);
buffer[s->length] = 0;
#ifdef DEBUG
printf("cstring(%s, %d) = %d\n", buffer, (int)s, (int)buffer);
#endif
}
void _prim_string_print(struct string* p1){
#ifdef DEBUG
printf("_prim_string_print(%d)\n", (int)p1);
#endif
for(int i = 0; i < p1->length; i++) {
putchar(p1->data[i]);
}
}
void _prim_int_print(int64_t p1) {
#ifdef DEBUG
printf("_prim_int_print(%d)\n", (int)p1);
#endif
printf("%ld", p1);
}
struct string* _prim_read_string() {
char *buffer = NULL;
size_t len = 0;
size_t read;
read = getline(&buffer, &len, stdin);
if (read == -1) {
return create_string_len(0);
} else {
struct string* r = create_string_copy(buffer);
free(buffer);
#ifdef DEBUG
printf("_prim_string_read() = %d\n", (int)r);
#endif
return r;
}
}
void _prim_usleep(int64_t p1) {
#ifdef DEBUG
printf("_prim_usleep(%ld)\n", p1);
#endif
usleep(p1); // p1 microseconds
}
void _prim_error(struct string* p1) {
#ifdef DEBUG
printf("_prim_error(%d)\n", (int)p1);
#endif
_prim_string_print(p1);
exit(-1);
}
int64_t _prim_ffi_file_eof(int64_t p1) {
// Currently this is a placeholder implementation for the idris frontend.
// In the idris examples only the stdin gets tested for feof so p1 is ignored by now.
// Appropiate file handling will be implemented later on.
#ifdef DEBUG
printf("_prim_ffi_file_eof(%ld)\n", p1);
#endif
return feof(stdin);
}
struct string* _prim_string_concat(struct string* p1, struct string* p2) {
struct string* r = create_string_len(p1->length + p2->length);
memcpy(r->data, p1->data, p1->length);
memcpy(r->data + p1->length, p2->data, p2-> length);
#ifdef DEBUG
printf("_prim_string_concat(%d,%d) = %d\n", (int)p1, (int)p2, (int)r);
#endif
return r;
}
struct string* _prim_string_reverse(struct string* src){
struct string* dst = create_string_len(src->length);
for(size_t i = 0; i < src->length; i++) {
dst->data[i] = src->data[src->length - i - 1];
}
#ifdef DEBUG
printf("_prim_string_reverse(%d)\n", (int)src);
#endif
return dst;
}
int64_t _prim_string_eq(struct string* p1, struct string* p2){
#ifdef DEBUG
printf("_prim_string_eq(%d,%d)\n", (int)p1, (int)p2);
#endif
if(p1->length != p2->length) {
return 0;
}
return memcmp(p1->data, p2->data, p1->length) == 0;
}
int64_t _prim_string_lt(struct string* p1, struct string* p2) {
#ifdef DEBUG
printf("_prim_string_lt(%d,%d)\n", (int)p1, (int)p2);
#endif
int len = (p1->length < p2->length)?(p1->length):(p2->length);
int cmp = memcmp(p1->data,p2->data, len);
if (p1->length < p2->length) {
return (int64_t)(cmp <= 0);
} else {
return (int64_t)(cmp < 0);
}
}
int64_t _prim_string_head(struct string* p1) {
#ifdef DEBUG
printf("_prim_string_head(%d)\n", (int)p1);
#endif
if (p1->length == 0) {
printf("_prim_string_head\n");
exit(-1);
}
return (int64_t)p1->data[0];
}
int64_t _prim_string_len(struct string* p1) {
#ifdef DEBUG
printf("_prim_string_len(%d) = %ld\n", (int)p1, p1 -> length);
#endif
return p1->length;
}
struct string* _prim_string_tail(struct string* p1){
if(p1->length == 0) {
printf("_prim_string_tail\n");
exit(-1);
}
struct string* r = create_string_len(p1->length - 1);
memcpy(r->data, p1->data + 1, r->length);
#ifdef DEBUG
printf("_prim_string_tail(%d) = %d\n", (int)p1, (int)r);
#endif
return r;
}
struct string* _prim_string_cons(int64_t p1, struct string* p2){
struct string* r = create_string_len(p2->length + 1);
r->data[0] = (char)p1;
memcpy(r->data+1,p2->data,p2->length);
#ifdef DEBUG
printf("_prim_string_cons(%ld, %d) = %d\n", p1, (int)p2, (int)r);
#endif
return r;
}
struct string* _prim_int_str(int64_t p1){
#ifdef DEBUG
printf("_prim_int_str(%ld)\n", p1);
#endif
char buffer[BUFFER_SIZE];
int len = snprintf(buffer, BUFFER_SIZE, "%ld", p1);
if (len >= 0 && len < BUFFER_SIZE) {
return create_string_copy(buffer);
} else {
printf("_prim_int_str\n");
exit(-1);
}
}
int64_t _prim_str_int(struct string* p1) {
#ifdef DEBUG
printf("_prim_str_int(%d)\n", (int)p1);
#endif
char buffer[p1->length+1];
cstring(buffer, p1);
int64_t r = strtoll(buffer, NULL, 10);
return r;
}
float _prim_int_float(int64_t p1) {
#ifdef DEBUG
printf("_prim_int_float(%ld)\n", p1);
#endif
return (float)p1;
}
struct string* _prim_float_string(float p1) {
#ifdef DEBUG
printf("_prim_float_string(%f)\n", p1);
#endif
char buffer[BUFFER_SIZE];
int len = snprintf(buffer, BUFFER_SIZE, "%.13g", p1);
if (len >= 0 && len < BUFFER_SIZE) {
return create_string_copy(buffer);
} else {
printf("_prim_float_string\n");
exit(-1);
}
}
int64_t _prim_char_int(char p1) {
#ifdef DEBUG
printf("_prim_char_int(%c)\n", p1);
#endif
return (int64_t)p1;
}

36
grin/prim_ops.h Normal file
View File

@ -0,0 +1,36 @@
#include <stdio.h>
#include <stdlib.h>
#include <inttypes.h>
#include <stdbool.h>
#include <string.h>
struct string {
char* data;
int64_t length;
};
struct string* create_string_len(int64_t l);
struct string* create_string_copy(char *str);
// ASSUMPTION: The buffer has enough memory allocated to store the string
void cstring(char* buffer, struct string* s);
void _prim_string_print(struct string* p1);
void _prim_int_print(int64_t p1);
struct string* _prim_read_string();
void _prim_usleep(int64_t p1);
void _prim_error(struct string* p1);
int64_t _prim_ffi_file_eof(int64_t p1);
struct string* _prim_string_concat(struct string* p1, struct string* p2);
struct string* _prim_string_reverse(struct string* p1);
int64_t _prim_string_eq(struct string* p1, struct string* p2);
int64_t _prim_string_head(struct string* p1);
int64_t _prim_string_len(struct string* p1);
struct string* _prim_string_tail(struct string* p1);
struct string* _prim_string_cons(int64_t p1, struct string* p2);
int64_t _prim_string_lt(struct string* p1, struct string* p2);
struct string* _prim_int_str(int64_t p1);
int64_t _prim_str_int(struct string* p1);
float _prim_int_float(int64_t p1);
struct string* _prim_float_string(float p1);
int64_t _prim_char_int(char p1);

251
grin/src/AbstractInterpretation/BinaryIR.hs Normal file
View File

@ -0,0 +1,251 @@
{-# LANGUAGE LambdaCase, RecordWildCards, Strict #-}
module AbstractInterpretation.BinaryIR (encodeAbstractProgram) where
import Control.Monad.State
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.ByteString.Lazy as LBS
import Data.ByteString.Builder
import AbstractInterpretation.IR
data Env
= Env
{ envTagMap :: Map (Set Tag) Int32
, envBlockCount :: !Int
, envBuilder :: !Builder
, envBuilderMap :: Map Int (Int, Builder) -- block size, data
, envInstCount :: !Int
}
emptyEnv = Env
{ envTagMap = mempty
, envBlockCount = 0
, envBuilder = mempty
, envBuilderMap = mempty
, envInstCount = 0
}
type W = State Env
emit :: Builder -> W ()
emit b = modify' $ \env@Env{..} -> env {envBuilder = envBuilder <> b}
writeI32 :: Int32 -> W ()
writeI32 i = emit $ int32LE i
writeW32 :: Word32 -> W ()
writeW32 w = emit $ word32LE w
writeReg :: Reg -> W ()
writeReg (Reg r) = writeW32 r
writeMem :: Mem -> W ()
writeMem (Mem m) = writeW32 m
writeTagSet :: Set Tag -> W ()
writeTagSet s = do
tm <- gets envTagMap
let size = fromIntegral $ Map.size tm
case Map.lookup s tm of
Just idx -> writeI32 idx
Nothing -> do
modify' $ \env@Env{..} -> env {envTagMap = Map.insert s size envTagMap}
writeI32 size
writeBlock :: [Instruction] -> W ()
writeBlock il = do
let size = length il
blockIndex <- gets envBlockCount
modify' $ \env@Env{..} -> env {envInstCount = envInstCount + size, envBlockCount = succ blockIndex}
writeI32 $ fromIntegral blockIndex
savedBuilder <- gets envBuilder
modify' $ \env@Env{..} -> env {envBuilder = mempty}
mapM_ writeInstruction il
blockBuilder <- gets envBuilder
modify' $ \env@Env{..} -> env {envBuilder = savedBuilder, envBuilderMap = Map.insert blockIndex (size, blockBuilder) envBuilderMap}
-----------------------------------
writeRange :: Range -> W ()
writeRange Range{..} = do
writeI32 from
writeI32 to
writeType :: Int32 -> W ()
writeType = writeI32
writeTag :: Tag -> W ()
writeTag (Tag w) = writeW32 w
writePredicate :: Predicate -> W ()
writePredicate = \case
TagIn s -> do
writeType 100
writeTagSet s
TagNotIn s -> do
writeType 101
writeTagSet s
ValueIn r -> do
writeType 102
writeRange r
ValueNotIn r -> do
writeType 103
writeRange r
writeCondition :: Condition -> W ()
writeCondition = \case
NodeTypeExists t -> do
writeType 200
writeTag t
SimpleTypeExists st -> do
writeType 201
writeI32 st
AnyNotIn s -> do
writeType 202
writeTagSet s
Any p -> do
writeType 203
writePredicate p
writeSelector :: Selector -> W ()
writeSelector = \case
NodeItem t i -> do
writeType 300
writeTag t
writeI32 $ fromIntegral i
ConditionAsSelector c -> do
writeType 301
writeCondition c
AllFields -> do
writeType 302
writeConstant :: Constant -> W ()
writeConstant = \case
CSimpleType st -> do
writeType 400
writeI32 st
CHeapLocation m -> do
writeType 401
writeMem m
CNodeType t a -> do
writeType 402
writeTag t
writeI32 $ fromIntegral a
CNodeItem t i v -> do
writeType 403
writeTag t
writeI32 $ fromIntegral i
writeI32 v
writeInstruction :: Instruction -> W ()
writeInstruction = \case
If {..} -> do
writeType 500
writeCondition condition
writeReg srcReg
writeBlock instructions
Project {..} -> do
writeType 501
writeSelector srcSelector
writeReg srcReg
writeReg dstReg
Extend {..} -> do
writeType 502
writeReg srcReg
writeSelector dstSelector
writeReg dstReg
Move {..} -> do
writeType 503
writeReg srcReg
writeReg dstReg
RestrictedMove {..} -> do
writeType 504
writeReg srcReg
writeReg dstReg
ConditionalMove {..} -> do
writeType 505
writeReg srcReg
writePredicate predicate
writeReg dstReg
Fetch {..} -> do
writeType 506
writeReg addressReg
writeReg dstReg
Store {..} -> do
writeType 507
writeReg srcReg
writeMem address
Update {..} -> do
writeType 508
writeReg srcReg
writeReg addressReg
RestrictedUpdate {..} -> do
writeType 509
writeReg srcReg
writeReg addressReg
ConditionalUpdate {..} -> do
writeType 510
writeReg srcReg
writePredicate predicate
writeReg addressReg
Set {..} -> do
writeType 511
writeReg dstReg
writeConstant constant
{-
memory count i32
register count i32
start block id i32
cmd count i32
cmds ...
block count i32
blocks (ranges) ...
intset count i32
set size i32
set elems ... [i32]
-}
writeBlockItem :: Int32 -> Int -> W Int32
writeBlockItem offset size = do
let nextOffset = offset + fromIntegral size
writeI32 $ offset
writeI32 $ nextOffset
pure nextOffset
encodeAbstractProgram :: AbstractProgram -> LBS.ByteString
encodeAbstractProgram AbstractProgram {..} = toLazyByteString (envBuilder env) where
env = flip execState emptyEnv $ do
writeW32 _absMemoryCounter
writeW32 _absRegisterCounter
-- start block id
writeBlock _absInstructions
-- commands
cmdCount <- gets envInstCount
writeI32 $ fromIntegral cmdCount
(blockSizes, blocks) <- gets $ unzip . Map.elems . envBuilderMap
mapM emit blocks
-- bocks
blkCount <- gets envBlockCount
writeI32 $ fromIntegral blkCount
foldM_ writeBlockItem 0 blockSizes
-- intsets
{-
setCount <- gets envTagSetCount
writeI32 $ fromIntegral setCount
sets <- gets envTagSets
-}
tagMap <- gets envTagMap
writeI32 $ fromIntegral $ Map.size tagMap
let sets = Map.elems $ Map.fromList [(i, s) | (s, i) <- Map.toList tagMap]
forM_ sets $ \s -> do
writeI32 $ fromIntegral $ Set.size s
forM_ (Set.toList s) (\(Tag t) -> writeI32 $ fromIntegral t)

65
grin/src/AbstractInterpretation/BinaryResult.hs Normal file
View File

@ -0,0 +1,65 @@
{-# LANGUAGE LambdaCase, RecordWildCards #-}
module AbstractInterpretation.BinaryResult where
import Data.Int
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Vector (Vector)
import qualified Data.Vector as V
import Control.Monad
import AbstractInterpretation.IR
import AbstractInterpretation.Reduce (NodeSet(..), Value(..), ComputerState(..), AbstractInterpretationResult(..))
import Data.Binary.Get
import qualified Data.ByteString.Lazy as LBS
checkTag :: Int32 -> String -> Get ()
checkTag tag msg = do
i <- getInt32le
when (i /= tag) $ fail msg
readTag :: Get Tag
readTag = Tag <$> getWord32le
readIntSet :: Get (Set Int32)
readIntSet = do
checkTag 1000 "int set expected"
size <- fromIntegral <$> getInt32le
Set.fromList <$> replicateM size getInt32le
readNodeItem :: Get (Vector (Set Int32))
readNodeItem = do
checkTag 1001 "node item expected"
size <- fromIntegral <$> getInt32le
V.fromList <$> replicateM size readIntSet
readNodeSet :: Get NodeSet
readNodeSet = do
checkTag 1002 "node set expected"
size <- fromIntegral <$> getInt32le
NodeSet . Map.fromList <$> replicateM size ((,) <$> readTag <*> readNodeItem)
readValue :: Get Value
readValue = do
checkTag 1003 "value expected"
Value <$> readIntSet <*> readNodeSet
readAbstractInterpretationResult :: Get AbstractInterpretationResult
readAbstractInterpretationResult = do
iterCount <- fromIntegral <$> getInt32le
memCount <- fromIntegral <$> getInt32le
regCount <- fromIntegral <$> getInt32le
mem <- V.fromList <$> replicateM memCount readNodeSet
reg <- V.fromList <$> replicateM regCount readValue
pure $ AbsIntResult
{ _airComp = ComputerState {_memory = mem, _register = reg}
, _airIter = iterCount
}
loadAbstractInterpretationResult :: String -> IO AbstractInterpretationResult
loadAbstractInterpretationResult fname = do
runGet readAbstractInterpretationResult <$> LBS.readFile fname

180
grin/src/AbstractInterpretation/CreatedBy/CodeGen.hs
View File

@ -20,7 +20,7 @@ import Grin.TypeEnvDefs
import qualified AbstractInterpretation.IR as IR
import AbstractInterpretation.IR (Instruction(..), AbstractProgram(..), emptyAbstractProgram, AbstractMapping(..))
import AbstractInterpretation.CreatedBy.CodeGenBase
import AbstractInterpretation.HeapPointsTo.CodeGen (litToSimpleType, unitType) -- FIXME: why? remove, refactor
import AbstractInterpretation.HeapPointsTo.CodeGen (litToSimpleType, unitType, codegenSimpleType) -- FIXME: why? remove, refactor
import AbstractInterpretation.HeapPointsTo.Result (undefinedProducer) -- FIXME: why? remove, refactor
data CByMapping
@ -109,11 +109,67 @@ codeGenVal = \case
Undefined t -> codeGenType codeGenSimpleType (codeGenNodeSetWith codeGenNodeTypeCBy) t
val -> error $ "unsupported value " ++ show val
typeTag :: Name -> Tag
typeTag n = Tag F n -- FIXME: this is a hack
projectType :: IR.Reg -> Ty -> CG [(Name, IR.Reg)]
projectType argReg = \case
TySimple{} -> pure []
TyVar name -> pure [(name, argReg)]
TyCon name args -> do
r <- newReg
emit IR.Fetch {addressReg = argReg, dstReg = r}
irTag <- getTag $ typeTag name
fmap concat $ forM (zip [1..] args) $ \(idx, ty) -> do
r1 <- newReg
emit IR.Project {srcSelector = IR.NodeItem irTag idx, srcReg = r, dstReg = r1}
projectType r1 ty
constructType :: [(Name, IR.Reg)] -> Ty -> CG IR.Reg
constructType argMap = \case
TySimple simpleType -> do
r <- newReg
emit IR.Set {dstReg = r, constant = IR.CSimpleType (codegenSimpleType simpleType)}
pure r
TyVar name -> do
r <- newReg
mapM_ emit [IR.Move {srcReg = q, dstReg = r} | (n,q) <- argMap, n == name]
pure r
TyCon name args -> do
-- construct type node
valReg <- newReg
irTag <- getTag $ typeTag name
emit IR.Set {dstReg = valReg, constant = IR.CNodeType irTag (length args)}
emit IR.Set {dstReg = valReg, constant = IR.CNodeItem irTag 0 undefinedProducer}
-- fill type node componets
forM_ (zip [1..] args) $ \(idx, ty) -> do
q <- constructType argMap ty
emit IR.Extend
{ srcReg = q
, dstSelector = IR.NodeItem irTag idx
, dstReg = valReg
}
-- store type node on abstract heap
loc <- newMem
r <- newReg
emit IR.Store {srcReg = valReg, address = loc}
emit IR.Set {dstReg = r, constant = IR.CHeapLocation loc}
pure r
codeGenExternal :: External -> [Val] -> CG Result
codeGenExternal External{..} args = do
valRegs <- mapM codeGenVal args
argMap <- concat <$> zipWithM projectType valRegs eArgsType
R <$> constructType argMap eRetType
codeGen :: Exp -> (AbstractProgram, CByMapping)
codeGen e = flip evalState emptyCGState $ para folder e >> mkCByProgramM where
folder :: ExpF (Exp, CG Result) -> CG Result
folder = \case
ProgramF exts defs -> (sequence_ . fmap snd $ defs) >> pure Z
ProgramF exts defs -> do
mapM_ addExternal exts
mapM_ snd defs
pure Z
DefF name args (_,body) -> do
(funResultReg, funArgRegs) <- getOrAddFunRegs name $ length args
@ -232,11 +288,11 @@ codeGen e = flip evalState emptyCGState $ para folder e >> mkCByProgramM where
altScrutReg <- newReg
addReg name altScrutReg
emit IR.Project
{ srcSelector = IR.ConditionAsSelector $ IR.NotIn tags
{ srcSelector = IR.ConditionAsSelector $ IR.AnyNotIn tags
, srcReg = valReg
, dstReg = altScrutReg
}
emit IR.If {condition = IR.NotIn tags, srcReg = valReg, instructions = altInstructions}
emit IR.If {condition = IR.AnyNotIn tags, srcReg = valReg, instructions = altInstructions}
_ -> error $ "CBy does not support the following case pattern: " ++ show cpat
@ -247,13 +303,35 @@ codeGen e = flip evalState emptyCGState $ para folder e >> mkCByProgramM where
AltF cpat (_,exp) -> pure $ A cpat exp
SAppF name args -> do -- copy args to definition's variables ; read function result register
(funResultReg, funArgRegs) <- getOrAddFunRegs name $ length args
valRegs <- mapM codeGenVal args
zipWithM_ (\src dst -> emit IR.Move {srcReg = src, dstReg = dst}) valRegs funArgRegs
-- HINT: handle primop here because it does not have definition
when (isExternalName (externals e) name) $ mapM_ emit $ codeGenPrimOp name funResultReg funArgRegs
pure $ R funResultReg
SAppF name args -> getExternal name >>= \case
Just ext -> do
res <- codeGenExternal ext args
let R r = res
-- HINT: workaround
-----------
-- copy args to definition's variables ; read function result register
(funResultReg, funArgRegs) <- getOrAddFunRegs name $ length args
valRegs <- mapM codeGenVal args
zipWithM_ (\src dst -> emit IR.Move {srcReg = src, dstReg = dst}) valRegs funArgRegs
-- old prim codegen
let External{..} = ext
isTySimple TySimple{} = True
isTySimple _ = False
emit IR.Move {srcReg = r, dstReg = funResultReg}
when (isTySimple eRetType && all isTySimple eArgsType) $ do
zipWithM_ (\argReg (TySimple argTy) -> emit IR.Set {dstReg = argReg, constant = IR.CSimpleType (codegenSimpleType argTy)}) funArgRegs eArgsType
pure res
-----------
Nothing -> do
-- copy args to definition's variables ; read function result register
(funResultReg, funArgRegs) <- getOrAddFunRegs name $ length args
valRegs <- mapM codeGenVal args
zipWithM_ (\src dst -> emit IR.Move {srcReg = src, dstReg = dst}) valRegs funArgRegs
pure $ R funResultReg
SReturnF val -> R <$> codeGenVal val
@ -280,83 +358,3 @@ codeGen e = flip evalState emptyCGState $ para folder e >> mkCByProgramM where
pure Z
SBlockF (_,exp) -> exp
codeGenPrimOp :: Name -> IR.Reg -> [IR.Reg] -> [Instruction]
codeGenPrimOp name funResultReg funArgRegs = execWriter $ do
let emit :: Instruction -> Writer [Instruction] ()
emit a = tell [a]
op argTypes resultTy = do
emit IR.Set {dstReg = funResultReg, constant = IR.CSimpleType resultTy}
zipWithM_ (\argReg argTy -> emit IR.Set {dstReg = argReg, constant = IR.CSimpleType argTy}) funArgRegs argTypes
unit = -1
int = litToSimpleType $ LInt64 0
word = litToSimpleType $ LWord64 0
float = litToSimpleType $ LFloat 0
bool = litToSimpleType $ LBool False
string = litToSimpleType $ LString ""
char = litToSimpleType $ LChar ' '
case name of
"_prim_int_print" -> op [int] unit
"_prim_string_print" -> op [string] unit
"_prim_read_string" -> op [] string
"_prim_usleep" -> op [int] unit
"_prim_error" -> op [string] unit
-- String
"_prim_string_concat" -> op [string, string] string
"_prim_string_reverse" -> op [string] string
"_prim_string_lt" -> op [string, string] bool
"_prim_string_eq" -> op [string, string] bool
"_prim_string_head" -> op [string] int
"_prim_string_tail" -> op [string] string
"_prim_string_cons" -> op [int, string] string
"_prim_string_len" -> op [string] int
-- Conversion
"_prim_int_str" -> op [int] string
"_prim_str_int" -> op [string] int
"_prim_int_float" -> op [int] float
"_prim_float_string" -> op [float] string
"_prim_char_int" -> op [char] int
-- Int
"_prim_int_add" -> op [int, int] int
"_prim_int_sub" -> op [int, int] int
"_prim_int_mul" -> op [int, int] int
"_prim_int_div" -> op [int, int] int
"_prim_int_eq" -> op [int, int] bool
"_prim_int_ne" -> op [int, int] bool
"_prim_int_gt" -> op [int, int] bool
"_prim_int_ge" -> op [int, int] bool
"_prim_int_lt" -> op [int, int] bool
"_prim_int_le" -> op [int, int] bool
-- Word
"_prim_word_add" -> op [word, word] word
"_prim_word_sub" -> op [word, word] word
"_prim_word_mul" -> op [word, word] word
"_prim_word_div" -> op [word, word] word
"_prim_word_eq" -> op [word, word] bool
"_prim_word_ne" -> op [word, word] bool
"_prim_word_gt" -> op [word, word] bool
"_prim_word_ge" -> op [word, word] bool
"_prim_word_lt" -> op [word, word] bool
"_prim_word_le" -> op [word, word] bool
-- Float
"_prim_float_add" -> op [float, float] float
"_prim_float_sub" -> op [float, float] float
"_prim_float_mul" -> op [float, float] float
"_prim_float_div" -> op [float, float] float
"_prim_float_eq" -> op [float, float] bool
"_prim_float_ne" -> op [float, float] bool
"_prim_float_gt" -> op [float, float] bool
"_prim_float_ge" -> op [float, float] bool
"_prim_float_lt" -> op [float, float] bool
"_prim_float_le" -> op [float, float] bool
-- Bool
"_prim_bool_eq" -> op [bool, bool] bool
"_prim_bool_ne" -> op [bool, bool] bool
-- FFI - TODO: Handle FFI appropiatey
"_prim_ffi_file_eof" -> op [int] int
missing -> error $ show missing

16
grin/src/AbstractInterpretation/CreatedBy/CodeGenBase.hs
View File

@ -29,10 +29,14 @@ data CGState
-- mapping
, _sRegisterMap :: Map.Map Name Reg
, _sFunctionArgMap :: Map.Map Name (Reg, [Reg])
, _sRegisterMap :: Map Name Reg
, _sFunctionArgMap :: Map Name (Reg, [Reg])
, _sTagMap :: Bimap.Bimap Tag IR.Tag
, _sProducerMap :: Map.Map Reg Name
-- internal
, _sExternalMap :: Map Name External
}
deriving (Show)
@ -50,6 +54,8 @@ emptyCGState = CGState
, _sFunctionArgMap = mempty
, _sTagMap = Bimap.empty
, _sProducerMap = mempty
, _sExternalMap = mempty
}
type CG = State CGState
@ -62,6 +68,12 @@ data Result
emit :: IR.Instruction -> CG ()
emit inst = modify' $ \s@CGState{..} -> s {_sInstructions = inst : _sInstructions}
addExternal :: External -> CG ()
addExternal e = modify' $ \s@CGState{..} -> s {_sExternalMap = Map.insert (eName e) e _sExternalMap}
getExternal :: Name -> CG (Maybe External)
getExternal name = Map.lookup name <$> gets _sExternalMap
-- creates regsiters for function arguments and result
getOrAddFunRegs :: Name -> Int -> CG (IR.Reg, [IR.Reg])
getOrAddFunRegs name arity = do

4
grin/src/AbstractInterpretation/CreatedBy/Util.hs
View File

@ -98,7 +98,7 @@ selectActiveProducers lvaResult prods = Map.keysSet
where
producerLiveness :: LVAResult -> Map Name Liveness
producerLiveness = flip Map.restrictKeys prods . _register
producerLiveness = flip Map.restrictKeys prods . _registerLv
isNodeLive' :: Liveness -> Bool
isNodeLive' (NodeSet m) = any hasLiveField m
@ -175,4 +175,4 @@ transitiveClosure m
modify $ Map.adjust update p
withoutUndefined :: ProducerGraph' -> ProducerGraph'
withoutUndefined = Map.delete undefinedProducerName
withoutUndefined = Map.delete undefinedProducerName

116
grin/src/AbstractInterpretation/EffectTracking/CodeGen.hs Normal file
View File

@ -0,0 +1,116 @@
{-# LANGUAGE LambdaCase, RecordWildCards, TupleSections, TemplateHaskell, OverloadedStrings #-}
module AbstractInterpretation.EffectTracking.CodeGen where
import Control.Monad.State
import Data.Set (Set)
import Data.Map (Map)
import Data.Vector (Vector)
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Vector as Vec
import Data.Functor.Foldable as Foldable
import Data.Tuple
import Data.Maybe
import Lens.Micro.Platform
import Grin.Grin
import Grin.Pretty
import Grin.TypeEnv
import qualified AbstractInterpretation.IR as IR
import AbstractInterpretation.IR (Instruction(..), AbstractProgram(..), AbstractMapping(..))
import AbstractInterpretation.EffectTracking.CodeGenBase
codeGen :: Program -> (AbstractProgram, ETMapping)
codeGen prg@(Program exts defs) = evalState (codeGenM prg >> mkAbstractProgramM) emptyCGState
codeGen _ = error "Program expected"
mkAbstractProgramM :: CG (AbstractProgram, ETMapping)
mkAbstractProgramM = do
CGState{..} <- get
let prg = AbstractProgram
{ _absMemoryCounter = 0
, _absRegisterCounter = _sRegisterCounter
, _absInstructions = _sInstructions
}
let splitExt = (,) <$> extID <*> extExt
extIdMap = Map.fromList . map splitExt . Map.elems $ _sExternalMap
let mpg = ETMapping
{ _etRegisterMap = _sRegisterMap
, _etFunctionRetMap = _sFunctionRetMap
, _etExternalMap = extIdMap
}
pure (prg, mpg)
codeGenM :: Exp -> CG Result
codeGenM = cata folder where
folder :: ExpF (CG Result) -> CG Result
folder = \case
ProgramF exts defs -> mapM_ addExternal exts >> sequence_ defs >> pure Z
DefF name args body -> do
instructions <- state $ \s@CGState{..} -> (_sInstructions, s {_sInstructions = []})
funResultReg <- getOrAddFunRetReg name
body >>= \case
-- Z -> emit IR.Set {dstReg = funResultReg, constant = IR.CSimpleType unitType}
R r -> emit IR.Move {srcReg = r, dstReg = funResultReg}
modify' $ \s@CGState{..} -> s {_sInstructions = reverse _sInstructions ++ instructions}
pure Z
EBindF leftExp lpat rightExp -> do
lhs <- leftExp
rhs <- rightExp
let R lhsReg = lhs
let R rhsReg = rhs
case lpat of
{- NOTE: By convention, all bindings should have a variable pattern
or a simple left-hand side of form `pure <var>`. This guarantees
that all relevant computations will have a name. Also, it means
the information has been already propagated to the variable.
-}
Unit -> pure ()
Lit{} -> pure ()
ConstTagNode{} -> pure ()
Var name -> addReg name lhsReg
_ -> error $ "Effect tracking: unsupported lpat " ++ show (PP lpat)
emit IR.Move { srcReg = lhsReg, dstReg = rhsReg }
pure $ R rhsReg
ECaseF val alts_ -> do
caseResultReg <- newReg
altRegs <- sequence alts_
forM altRegs $ \(R altReg) ->
emit IR.Move { srcReg = altReg, dstReg = caseResultReg }
pure $ R caseResultReg
AltF _ exp -> exp
SAppF name args -> getExternal name >>= \case
Just ext -> do
appReg <- newReg
extID <- fromJust <$> getExternalID name
when (eEffectful ext) $
emit IR.Set { dstReg = appReg, constant = IR.CSimpleType extID }
pure $ R appReg
-----------
Nothing -> do
appReg <- newReg
funResultReg <- getOrAddFunRetReg name
emit IR.Move { srcReg = funResultReg, dstReg = appReg }
pure $ R appReg
SReturnF{} -> R <$> newReg
SStoreF{} -> R <$> newReg
SFetchIF{}-> R <$> newReg
SUpdateF{} -> R <$> newReg
SBlockF exp -> exp

136
grin/src/AbstractInterpretation/EffectTracking/CodeGenBase.hs Normal file
View File

@ -0,0 +1,136 @@
{-# LANGUAGE LambdaCase, RecordWildCards, RankNTypes, TemplateHaskell #-}
module AbstractInterpretation.EffectTracking.CodeGenBase where
import Data.Int
import Data.Word
import Data.Set (Set)
import Data.Map (Map)
import Data.Vector (Vector)
import qualified Data.Bimap as Bimap
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Vector as Vec
import Data.Functor.Infix
import Control.Monad.State
import Grin.Grin (Name, SimpleType(..), CPat(..), unpackName, Tag(..), External(..))
import Grin.TypeEnvDefs
import AbstractInterpretation.IR (Instruction(..), Reg(..), AbstractMapping)
import qualified AbstractInterpretation.IR as IR
import Lens.Micro.Platform
type ExternalID = Int32
data ExternalWithID = E { extID :: ExternalID
, extExt :: External
}
deriving (Eq, Ord, Show)
data ETMapping
= ETMapping
{ _etRegisterMap :: Map Name Reg
, _etFunctionRetMap :: Map Name Reg
, _etExternalMap :: Map ExternalID External
}
deriving Show
data CGState
= CGState
{ _sRegisterCounter :: Word32
, _sInstructions :: [Instruction]
-- mapping
, _sRegisterMap :: Map Name Reg
, _sFunctionRetMap :: Map Name Reg
-- internal
, _sExternalMap :: Map Name ExternalWithID
}
deriving (Show)
concat <$> mapM makeLenses [''CGState]
emptyCGState :: CGState
emptyCGState = CGState
{ _sRegisterCounter = 0
, _sInstructions = []
-- mapping
, _sRegisterMap = mempty
, _sFunctionRetMap = mempty
-- internal
, _sExternalMap = mempty
}
type CG = State CGState
data Result
= R IR.Reg
| Z
| A CPat (CG Result)
emit :: IR.Instruction -> CG ()
emit inst = modify' $ \s@CGState{..} -> s {_sInstructions = inst : _sInstructions}
addExternal :: External -> CG ()
addExternal e = do
let name = eName e
eMap <- gets _sExternalMap
if name `Map.member` eMap then
error $ "External already present in the external map: " ++ show name
else
modify' $ \s@CGState{..} ->
let curSize = fromIntegral . Map.size $ _sExternalMap in
s { _sExternalMap = Map.insert (eName e) (E curSize e) _sExternalMap
, _sFunctionRetMap = mempty
}
getExternal :: Name -> CG (Maybe External)
getExternal name = extExt <$$> Map.lookup name <$> gets _sExternalMap
getExternalID :: Name -> CG (Maybe ExternalID)
getExternalID name = extID <$$> Map.lookup name <$> gets _sExternalMap
-- creates regsiters for function arguments and result
getOrAddFunRetReg :: Name -> CG IR.Reg
getOrAddFunRetReg name = do
funMap <- gets _sFunctionRetMap
case Map.lookup name funMap of
Just x -> pure x
Nothing -> do
retReg <- newReg
modify' $ \s@CGState{..} -> s {_sFunctionRetMap = Map.insert name retReg _sFunctionRetMap}
pure retReg
newReg :: CG IR.Reg
newReg = state $ \s@CGState{..} -> (IR.Reg _sRegisterCounter, s {_sRegisterCounter = succ _sRegisterCounter})
addReg :: Name -> IR.Reg -> CG ()
addReg name reg = modify' $ \s@CGState{..} -> s {_sRegisterMap = Map.insert name reg _sRegisterMap}
getReg :: Name -> CG IR.Reg
getReg name = do
regMap <- gets _sRegisterMap
case Map.lookup name regMap of
Nothing -> error $ "unknown variable " ++ unpackName name
Just reg -> pure reg
codeGenBlock :: CG a -> CG (a,[IR.Instruction])
codeGenBlock genM = do
instructions <- state $ \s@CGState{..} -> (_sInstructions, s {_sInstructions = []})
ret <- genM
blockInstructions <- state $ \s@CGState{..} -> (reverse _sInstructions, s {_sInstructions = instructions})
pure (ret, blockInstructions)
codeGenBlock_ :: CG a -> CG [IR.Instruction]
codeGenBlock_ = fmap snd . codeGenBlock

30
grin/src/AbstractInterpretation/EffectTracking/Pretty.hs Normal file
View File

@ -0,0 +1,30 @@
{-# LANGUAGE LambdaCase, RecordWildCards #-}
module AbstractInterpretation.EffectTracking.Pretty where
import Data.Functor.Foldable as Foldable
import Text.PrettyPrint.ANSI.Leijen
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Vector (Vector)
import qualified Data.Vector as V
import Grin.Grin (Tag, Name)
import Grin.Pretty as Grin
import qualified AbstractInterpretation.EffectTracking.Result as R
instance Pretty R.Effects where
pretty (R.Effects es) = prettyBracedList . map dullyellow . map Grin.pretty . Set.toList $ es
instance Pretty R.ETResult where
pretty R.ETResult{..} = vsep
[ yellow (text "Bindings") <$$> indent 4 (prettyKeyValue $ Map.toList _register)
, yellow (text "Functions") <$$> indent 4 (prettyKeyValue $ Map.toList _function)
]

82
grin/src/AbstractInterpretation/EffectTracking/Result.hs Normal file
View File

@ -0,0 +1,82 @@
{-# LANGUAGE LambdaCase, RecordWildCards, TemplateHaskell, GeneralizedNewtypeDeriving, TypeFamilies, DeriveFunctor, ViewPatterns #-}
module AbstractInterpretation.EffectTracking.Result where
import Data.Int
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Data.Bimap as Bimap
import Data.Maybe
import Lens.Micro.Platform
import Lens.Micro.Extra
import Grin.Grin (Name, Tag, External(..))
import Grin.Pretty
import AbstractInterpretation.IR hiding (Tag, SimpleType)
import AbstractInterpretation.Reduce (ComputerState(..))
import qualified Grin.TypeEnv as TypeEnv
import qualified AbstractInterpretation.IR as IR
import qualified AbstractInterpretation.Reduce as R
import AbstractInterpretation.EffectTracking.CodeGenBase (ETMapping(..))
newtype Effects = Effects { _effectSet :: Set Name }
deriving (Eq, Ord, Show, Semigroup, Monoid)
data ETResult = ETResult
{ _register :: Map Name Effects
, _function :: Map Name Effects
, _external :: Map Name External
} deriving (Eq, Ord, Show)
instance Semigroup ETResult where
(<>) (ETResult reg1 fun1 ext1) (ETResult reg2 fun2 ext2)
= ETResult (reg1 <> reg2) (fun1 <> fun2) (ext1 <> ext2)
instance Monoid ETResult where
mempty = ETResult mempty mempty mempty
hasSideEffectVar :: ETResult -> Name -> Bool
hasSideEffectVar ETResult{..} v
| Just (Effects effs) <- Map.lookup v _register
= not . null $ effs
| otherwise = error $ "Variable " ++ show (PP v) ++ " is not present in the effect analysis result"
hasSideEffectFun :: ETResult -> Name -> Bool
hasSideEffectFun ETResult{..} f
| Just ext <- Map.lookup f _external
= eEffectful ext
| Just (Effects effs) <- Map.lookup f _function
= not . null $ effs
| otherwise = error $ "Function " ++ show (PP f) ++ " is not present in the effect analysis result"
hasSideEffect :: ETResult -> Name -> Bool
hasSideEffect ETResult{..} name
| Just (Effects effs) <- Map.lookup name _register
= not . null $ effs
| Just ext <- Map.lookup name _external
= eEffectful ext
| Just (Effects effs) <- Map.lookup name _function
= not . null $ effs
| otherwise = error $ "Entity " ++ show (PP name) ++ " is not present in the effect analysis result"
toETResult :: ETMapping -> R.ComputerState -> ETResult
toETResult e@ETMapping{..} c@R.ComputerState{..} = ETResult
{ _register = Map.map (convertReg e c) _etRegisterMap
, _function = Map.map (convertReg e c) _etFunctionRetMap
, _external = Map.fromList . map toMapEntry . Map.elems $ _etExternalMap
} where
convertReg :: ETMapping -> ComputerState -> Reg -> Effects
convertReg etMap R.ComputerState{..} (Reg i) = convertValue etMap $ _register V.! (fromIntegral i)
convertValue :: ETMapping -> R.Value -> Effects
convertValue ETMapping{..} (R.Value ty _) = Effects $ Set.map (eName . fromJust . flip Map.lookup _etExternalMap) ty
toMapEntry :: External -> (Name, External)
toMapEntry = (,) <$> eName <*> id

4
grin/src/AbstractInterpretation/HeapPointsTo/CodeGen.hs
View File

@ -283,12 +283,12 @@ codeGenM = cata folder where
altScrutReg <- newReg
addReg name altScrutReg
emit IR.Project
{ srcSelector = IR.ConditionAsSelector $ IR.NotIn tags
{ srcSelector = IR.ConditionAsSelector $ IR.AnyNotIn tags
, srcReg = valReg
, dstReg = altScrutReg
}
-- QUESTION: Redundant IF. Just for consistency?
emit IR.If {condition = IR.NotIn tags, srcReg = valReg, instructions = altInstructions}
emit IR.If {condition = IR.AnyNotIn tags, srcReg = valReg, instructions = altInstructions}
_ -> error $ "HPT does not support the following case pattern: " ++ show cpat

4
grin/src/AbstractInterpretation/IR.hs
View File

@ -32,6 +32,7 @@ data Selector
= NodeItem Tag Int -- node item index
| ConditionAsSelector Condition
| AllFields
| EveryNthField Int
deriving (Eq, Ord, Show)
newtype Tag = Tag Word32 deriving (Eq, Ord, Show, Generic, NFData)
@ -41,12 +42,11 @@ type SimpleType = Int32 -- TODO: rename to a generic name; should not be related
data Condition
= NodeTypeExists Tag
| SimpleTypeExists SimpleType
| NotIn (Set Tag)
| AnyNotIn (Set Tag)
-- A field satisfies a predicate iff at least one of its possible values
-- satisfy that predicate.
-- NOTE: "non-deterministic" selector for Any?
| Any Predicate
| All Predicate
deriving (Eq, Ord, Show)
data Predicate

234
grin/src/AbstractInterpretation/LiveVariable/CodeGen.hs
View File

@ -1,5 +1,8 @@
{-# LANGUAGE LambdaCase, TupleSections, TemplateHaskell, OverloadedStrings, RecordWildCards #-}
module AbstractInterpretation.LiveVariable.CodeGen where
module AbstractInterpretation.LiveVariable.CodeGen
( module AbstractInterpretation.LiveVariable.CodeGen
, live, sideEffecting
) where
import Control.Monad.State
@ -19,6 +22,8 @@ import qualified AbstractInterpretation.IR as IR
import AbstractInterpretation.IR (Instruction(..), AbstractProgram(..), AbstractMapping(..))
import AbstractInterpretation.LiveVariable.CodeGenBase
import AbstractInterpretation.EffectTracking.Result
-- NOTE: For a live variable, we could store its type information.
-- Live variable analysis program.
@ -39,10 +44,12 @@ emptyReg = newReg
-- Tests whether the given register is live.
isLiveThen :: IR.Reg -> [IR.Instruction] -> IR.Instruction
isLiveThen r i = IR.If { condition = IR.Any isNotPointer, srcReg = r, instructions = i }
isLiveThen r is = IR.If { condition = IR.Any isLivenessInfo, srcReg = r, instructions = is }
live :: LivenessId
live = -1
isLiveThenM :: IR.Reg -> CG () -> CG ()
isLiveThenM r actionM = do
is <- codeGenBlock_ actionM
emit $ isLiveThen r is
setBasicValLiveInst :: IR.Reg -> IR.Instruction
setBasicValLiveInst r = IR.Set { dstReg = r, constant = IR.CSimpleType live }
@ -60,6 +67,16 @@ setTagLive tag reg = do
, dstReg = reg
}
setAllTagsLive :: IR.Reg -> CG ()
setAllTagsLive reg = do
tmp <- newReg
setBasicValLive tmp
emit IR.Extend
{ srcReg = tmp
, dstSelector = IR.EveryNthField 0
, dstReg = reg
}
-- In order to Extend a node field, or Project into it, we need that field to exist.
-- This function initializes a node in the register with a given tag and arity.
setNodeTypeInfo :: IR.Reg -> IR.Tag -> Int -> Instruction
@ -78,9 +95,12 @@ setLive r = do
setBasicValLive r
emit IR.Extend { srcReg = r, dstSelector = IR.AllFields, dstReg = r }
-- Only structural information should flow forwards,
-- and only liveness information should flow backwards.
{- Data flow info propagation for node pattern:
case nodeReg of
(CNode argReg) -> ...
or
(CNode argReg) <- pure nodeReg
-}
nodePatternDataFlow :: IR.Reg -> IR.Reg -> IR.Tag -> Int -> CG ()
@ -101,6 +121,44 @@ nodePatternDataFlow argReg nodeReg irTag idx = do
emit $ copyStructureWithPtrInfo tmp argReg
-- Only structural and effect information should flow forwards,
-- and only liveness information should flow backwards.
{- Data flow info propagation for variable patterns
v <- pure ...
-}
varPatternDataFlow :: IR.Reg -> IR.Reg -> CG ()
varPatternDataFlow varReg lhsReg = do
emit $ copyStructureWithPtrInfo lhsReg varReg
effectDataFlow lhsReg varReg
livenessDataFlow varReg lhsReg
livenessDataFlow :: IR.Reg -> IR.Reg -> CG ()
livenessDataFlow srcReg dstReg = do
tmp <- newReg
emit $ copyStructureWithLivenessInfo srcReg tmp
emit $ IR.RestrictedMove { srcReg = tmp, dstReg = dstReg }
effectDataFlow :: IR.Reg -> IR.Reg -> CG ()
effectDataFlow srcReg dstReg = do
tmp <- newReg
emit $ copyStructureWithEffectInfo srcReg tmp
emit $ IR.RestrictedMove { srcReg = tmp, dstReg = dstReg }
-- Tests whether the given register has any side effects.
hasSideEffectsThen :: IR.Reg -> [IR.Instruction] -> IR.Instruction
hasSideEffectsThen r is = IR.If { condition = IR.Any isEffectInfo, srcReg = r, instructions = is }
hasSideEffectsThenM :: IR.Reg -> CG () -> CG ()
hasSideEffectsThenM r actionM = do
is <- codeGenBlock_ actionM
emit $ hasSideEffectsThen r is
setBasicValSideEffectingInst :: IR.Reg -> IR.Instruction
setBasicValSideEffectingInst r = IR.Set { dstReg = r, constant = IR.CSimpleType sideEffecting }
setBasicValSideEffecting :: IR.Reg -> CG ()
setBasicValSideEffecting = emit . setBasicValSideEffectingInst
codeGenVal :: Val -> CG IR.Reg
codeGenVal = \case
ConstTagNode tag vals -> do
@ -178,50 +236,55 @@ codeGenM e = (cata folder >=> const setMainLive) e
where
folder :: ExpF (CG Result) -> CG Result
folder = \case
ProgramF exts defs -> sequence_ defs >> pure Z
ProgramF exts defs -> mapM_ addExternal exts >> sequence_ defs >> pure Z
DefF name args body -> do
(funResultReg, funArgRegs) <- getOrAddFunRegs name $ length args
DefF f args body -> do
(funResultReg, funArgRegs) <- getOrAddFunRegs f $ length args
zipWithM_ addReg args funArgRegs
body >>= \case
Z -> doNothing
R r -> do emit IR.Move { srcReg = funResultReg, dstReg = r }
emit $ copyStructureWithPtrInfo r funResultReg
-- NOTE: A function might have side-effects,
-- so we have to generate code for it even if its result register is dead.
-- emit $ funResultReg `isLiveThen` bodyInstructions
R r -> varPatternDataFlow funResultReg r
pure Z
EBindF leftExp lpat rightExp -> do
leftExp >>= \case
Z -> case lpat of
Unit -> pure ()
Var name -> do
r <- newReg
addReg name r
_ -> error $ "pattern mismatch at LVA bind codegen, expected Unit got " ++ show lpat
R r -> case lpat of
Unit -> setBasicValLive r
Lit{} -> setBasicValLive r
Var name -> addReg name r
ConstTagNode tag args -> do
irTag <- getTag tag
setTagLive irTag r
bindInstructions <- codeGenBlock_ $ forM (zip [1..] args) $ \(idx, arg) ->
case arg of
Var name -> do
argReg <- newReg
addReg name argReg
nodePatternDataFlow argReg r irTag idx
Lit {} -> emit IR.Set { dstReg = r, constant = IR.CNodeItem irTag idx live }
_ -> error $ "illegal node pattern component " ++ show arg
emit IR.If
{ condition = IR.NodeTypeExists irTag
, srcReg = r
, instructions = bindInstructions
}
_ -> error $ "unsupported lpat " ++ show lpat
rightExp
lhs <- leftExp
let R lhsReg = lhs
case lpat of
{- NOTE: By convention, all bindings should have a variable pattern
or a simple left-hand side of form `pure <var>`. This guarantees
that all relevant computations will have a name. Also, it means
the information has been already propagated to the variable.
-}
Unit -> setBasicValLive lhsReg
Lit{} -> setBasicValLive lhsReg
Var v -> do
varReg <- newReg
addReg v varReg
varPatternDataFlow varReg lhsReg
ConstTagNode tag args -> do
irTag <- getTag tag
setTagLive irTag lhsReg
bindInstructions <- codeGenBlock_ $ forM (zip [1..] args) $ \(idx, arg) ->
case arg of
Var name -> do
argReg <- newReg
addReg name argReg
nodePatternDataFlow argReg lhsReg irTag idx
Lit {} -> emit IR.Set { dstReg = lhsReg, constant = IR.CNodeItem irTag idx live }
_ -> error $ "illegal node pattern component " ++ show arg
emit IR.If
{ condition = IR.NodeTypeExists irTag
, srcReg = lhsReg
, instructions = bindInstructions
}
_ -> error $ "unsupported lpat " ++ show lpat
rhs <- rightExp
let R rhsReg = rhs
effectDataFlow lhsReg rhsReg
pure $ R rhsReg
ECaseF val alts_ -> do
valReg <- codeGenVal val
@ -250,7 +313,7 @@ codeGenM e = (cata folder >=> const setMainLive) e
addReg scrutName altScrutReg
-- restricting scrutinee to alternative's domain
emit IR.Project
{ srcSelector = IR.ConditionAsSelector $ IR.NotIn tags
{ srcSelector = IR.ConditionAsSelector $ IR.AnyNotIn tags
, srcReg = scrutReg
, dstReg = altScrutReg
}
@ -260,12 +323,11 @@ codeGenM e = (cata folder >=> const setMainLive) e
processAltResult = \case
Z -> doNothing
R altResultReg -> do
--NOTE: We propagate liveness information rom the case result register
--NOTE: We propagate liveness information from the case result register
-- to the alt result register. But we also have to propagate
-- structural and pointer information from the alt result register
-- into the case result register.
emit IR.RestrictedMove {srcReg = caseResultReg, dstReg = altResultReg}
emit $ copyStructureWithPtrInfo altResultReg caseResultReg
varPatternDataFlow caseResultReg altResultReg
restoreScrutReg origScrutReg scrutName = do
-- propagating info back to original scrutinee register
@ -293,14 +355,22 @@ codeGenM e = (cata folder >=> const setMainLive) e
processAltResult
restoreScrutReg
codeGenAltSimple actionM = codeGenBlock_ $
actionM >> (altM >>= processAltResult)
{- NOTE: In case of a pattern match, all tags should be marked live.
However, we allow for more aggressive optimizations if we only
set a tag live, when it actually appears amongst the alternatives.
This way we trust the program more than the analysis result, and
all "possible" tags not appearing amongst the alernatives will
stay dead.
Also, if there is a #default alternative, we mark all tags live.
-}
case cpat of
NodePat tag vars -> do
irTag <- getTag tag
altInstructions <- codeGenAltExists irTag $ \altScrutReg -> do
setTagLive irTag altScrutReg
-- NOTE: should be altResultRegister
caseResultReg `isLiveThenM` setTagLive irTag altScrutReg
caseResultReg `hasSideEffectsThenM` setTagLive irTag altScrutReg
-- bind pattern variables
forM_ (zip [1..] vars) $ \(idx, name) -> do
argReg <- newReg
@ -315,17 +385,35 @@ codeGenM e = (cata folder >=> const setMainLive) e
-- NOTE: if we stored type information for basic val,
-- we could generate code conditionally here as well
LitPat lit -> do
altInstructions <- codeGenAltSimple $ setBasicValLive valReg
mapM_ emit altInstructions
-- NOTE: should be altResultRegister
caseResultReg `isLiveThenM` setBasicValLive valReg
caseResultReg `hasSideEffectsThenM` setBasicValLive valReg
altM >>= processAltResult
DefaultPat -> do
tags <- Set.fromList <$> sequence [getTag tag | A (NodePat tag _) _ <- alts]
altInstructions <- codeGenAltNotIn tags (const doNothing)
emit IR.If
{ condition = IR.NotIn tags
, srcReg = valReg
, instructions = altInstructions
}
altInstructions <- codeGenAltNotIn tags $ \altScrutReg -> do
caseResultReg `isLiveThenM` (setBasicValLive altScrutReg >> setAllTagsLive altScrutReg)
caseResultReg `hasSideEffectsThenM` (setBasicValLive altScrutReg >> setAllTagsLive altScrutReg)
let canBeLiteral = null tags
{- NOTE: Since, we are not tracking simple types (literals),
the "AnyNotIn" condition will always be false for simple typed
values. Hence, we need to check manually whether a scrutinee
can be a simple typed value or not. If we never pattern match
on a node tag, the scrutinee can be a simple typed value.
Alternatively, we could track simple types, even with only
some dummy values, but that would be unnecessary overhead.
-}
if canBeLiteral then
mapM_ emit altInstructions
else
emit IR.If
{ condition = IR.AnyNotIn tags
, srcReg = valReg
, instructions = altInstructions
}
_ -> error $ "LVA does not support the following case pattern: " ++ show cpat
pure $ R caseResultReg
@ -333,13 +421,24 @@ codeGenM e = (cata folder >=> const setMainLive) e
AltF cpat exp -> pure $ A cpat exp
SAppF name args -> do
(funResultReg, funArgRegs) <- getOrAddFunRegs name $ length args
valRegs <- mapM codeGenVal args
zipWithM_ (\src dst -> emit IR.RestrictedMove {srcReg = src, dstReg = dst}) funArgRegs valRegs
zipWithM_ (\src dst -> emit $ copyStructureWithPtrInfo src dst) valRegs funArgRegs
-- HINT: handle primop here because it does not have definition
when (isExternalName (externals e) name) $ codeGenPrimOp name funResultReg funArgRegs
pure $ R funResultReg
appReg <- newReg
argRegs <- mapM codeGenVal args
mExt <- getExternal name
case mExt of
Nothing -> do -- regular function
(funResultReg, funArgRegs) <- getOrAddFunRegs name $ length args
-- no effect data-flow between formal and actual arguments
zipWithM_ livenessDataFlow funArgRegs argRegs
zipWithM_ (\src dst -> emit $ copyStructureWithPtrInfo src dst) argRegs funArgRegs
varPatternDataFlow appReg funResultReg
Just ext | eEffectful ext -> do mapM_ setBasicValLive argRegs
setBasicValSideEffecting appReg
| otherwise -> do allArgsLive <- codeGenBlock_ $ mapM_ setBasicValLive argRegs
emit $ appReg `isLiveThen` allArgsLive
pure $ R appReg
SReturnF val -> R <$> codeGenVal val
@ -408,17 +507,10 @@ codeGenM e = (cata folder >=> const setMainLive) e
-- setting pointer liveness
emit $ valReg `isLiveThen` [setBasicValLiveInst addressReg]
pure Z
R <$> newReg
SBlockF exp -> exp
codeGenPrimOp :: Name -> IR.Reg -> [IR.Reg] -> CG ()
codeGenPrimOp name funResultReg funArgRegs
| name == "_prim_int_print" = mapM_ setBasicValLive funArgRegs
| otherwise = do
allArgsLive <- codeGenBlock_ $ mapM_ setBasicValLive funArgRegs
emit $ funResultReg `isLiveThen` allArgsLive
codeGenAlt :: (Maybe Name, IR.Reg) ->
(IR.Reg -> Name -> CG IR.Reg) ->
(IR.Reg -> CG ()) ->

48
grin/src/AbstractInterpretation/LiveVariable/CodeGenBase.hs
View File

@ -21,6 +21,8 @@ import Grin.TypeEnvDefs
import AbstractInterpretation.IR (Instruction(..), Reg(..))
import qualified AbstractInterpretation.IR as IR
import AbstractInterpretation.EffectTracking.Result
data CGState
= CGState
{ _sMemoryCounter :: Word32
@ -32,6 +34,8 @@ data CGState
, _sRegisterMap :: Map.Map Name Reg
, _sFunctionArgMap :: Map.Map Name (Reg, [Reg])
, _sTagMap :: Bimap.Bimap Tag IR.Tag
, _sExternalMap :: Map.Map Name External
}
deriving (Show)
@ -48,6 +52,8 @@ emptyCGState = CGState
, _sRegisterMap = mempty
, _sFunctionArgMap = mempty
, _sTagMap = Bimap.empty
, _sExternalMap = mempty
}
type CG = State CGState
@ -60,6 +66,12 @@ data Result
emit :: IR.Instruction -> CG ()
emit inst = modify' $ \s@CGState{..} -> s {_sInstructions = inst : _sInstructions}
addExternal :: External -> CG ()
addExternal e = modify' $ \s@CGState{..} -> s {_sExternalMap = Map.insert (eName e) e _sExternalMap}
getExternal :: Name -> CG (Maybe External)
getExternal name = Map.lookup name <$> gets _sExternalMap
-- creates regsiters for function arguments and result
getOrAddFunRegs :: Name -> Int -> CG (IR.Reg, [IR.Reg])
getOrAddFunRegs name arity = do
@ -172,8 +184,22 @@ codeGenType cgSimpleTy cgNodeTy = \case
isPointer :: IR.Predicate
isPointer = IR.ValueIn (IR.Range 0 (maxBound :: Int32))
isNotPointer :: IR.Predicate
isNotPointer = IR.ValueIn (IR.Range (minBound :: Int32) 0)
ptrLowerBound :: Int32
ptrLowerBound = 0
live :: Int32
live = -1
sideEffecting :: Int32
sideEffecting = -2
-- NOTE: Exclusive upper bound
isLivenessInfo :: IR.Predicate
isLivenessInfo = IR.ValueIn (IR.Range live ptrLowerBound)
-- NOTE: Exclusive upper bound
isEffectInfo :: IR.Predicate
isEffectInfo = IR.ValueIn (IR.Range sideEffecting live)
-- For simple types, copies only pointer information
-- For nodes, copies the structure and the pointer information in the fields
@ -183,3 +209,21 @@ copyStructureWithPtrInfo srcReg dstReg = IR.ConditionalMove
, predicate = isPointer
, dstReg = dstReg
}
-- For simple types, copies only non-pointer information.
-- For nodes, copies the structure and the non-pointer information in the fields.
-- In the case of LVA, no literal type info is propagated,
-- so any non-pointer info is liveness info (the value of -1).
copyStructureWithLivenessInfo :: IR.Reg -> IR.Reg -> IR.Instruction
copyStructureWithLivenessInfo srcReg dstReg = IR.ConditionalMove
{ srcReg = srcReg
, predicate = isLivenessInfo
, dstReg = dstReg
}
copyStructureWithEffectInfo :: IR.Reg -> IR.Reg -> IR.Instruction
copyStructureWithEffectInfo srcReg dstReg = IR.ConditionalMove
{ srcReg = srcReg
, predicate = isEffectInfo
, dstReg = dstReg
}

25
grin/src/AbstractInterpretation/LiveVariable/Pretty.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE RecordWildCards #-}
module AbstractInterpretation.LiveVariable.Pretty where
import Data.Tuple
import Data.Functor.Foldable as Foldable
import Text.PrettyPrint.ANSI.Leijen
@ -10,6 +11,8 @@ import qualified Data.Map as Map
import Data.Vector (Vector)
import qualified Data.Vector as V
import Lens.Micro.Platform
import Grin.Pretty
import Grin.Grin (Tag, Name)
@ -32,8 +35,20 @@ instance Pretty Liveness where
. Map.toList $ ns
instance Pretty LVAResult where
pretty LVAResult{..} = vsep
[ yellow (text "Heap") <$$> indent 4 (prettyKeyValue $ zip [(0 :: Int)..] $ V.toList _memory)
, yellow (text "Env") <$$> indent 4 (prettyKeyValue $ Map.toList _register)
, yellow (text "Function") <$$> indent 4 (vsep $ map prettyFunction $ Map.toList _function)
]
pretty = prettyLVAResult
prettyLVAResult :: LVAResult -> Doc
prettyLVAResult LVAResult{..} = vsep
[ yellow (text "Heap") <$$> indent 4 (prettyKeyValue $ zip [(0 :: Int)..] $ V.toList _memory)
, yellow (text "Env (* is effectful)") <$$> indent 4 (prettyKeyValue . mapFst annotateEffectfulName . Map.toList $ _registerLv)
, yellow (text "Function (* is effectful)") <$$> indent 4 (vsep . map prettyFunction . mapFst annotateEffectfulName . Map.toList $ _functionLv)
] where
annotateEffectfulName name
| Just (Effect True) <- Map.lookup name _registerEff
= text "*" <> pretty name
| Just (Effect True) <- Map.lookup name _functionEff
= text "*" <> pretty name
| otherwise = pretty name
mapFst f = map (over _1 f)

50
grin/src/AbstractInterpretation/LiveVariable/Result.hs
View File

@ -29,16 +29,21 @@ data Liveness
| NodeSet (Map Tag Node)
deriving (Eq, Ord, Show)
newtype Effect = Effect { _hasEffect :: Bool }
deriving (Eq, Ord, Show)
data LVAResult
= LVAResult
{ _memory :: Vector Liveness
, _register :: Map Name Liveness
, _function :: Map Name (Liveness, Vector Liveness)
{ _memory :: Vector Liveness
, _registerLv :: Map Name Liveness
, _functionLv :: Map Name (Liveness, Vector Liveness)
, _registerEff :: Map Name Effect
, _functionEff :: Map Name Effect
}
deriving (Eq, Show)
emptyLVAResult :: LVAResult
emptyLVAResult = LVAResult mempty mempty mempty
emptyLVAResult = LVAResult mempty mempty mempty mempty mempty
concat <$> mapM makeLenses [''Node, ''Liveness, ''LVAResult]
@ -55,6 +60,9 @@ isLive :: Liveness -> Bool
isLive (BasicVal b) = b
isLive (NodeSet m) = any isNodeLive m
hasLiveArgs :: (Liveness, Vector Liveness) -> Bool
hasLiveArgs (_, argsLv) = any isLive argsLv
-- | A function is only dead if its return value is dead
-- , and all of its parameters are dead as well. The case
-- when the return value is dead, but there is a live parameter
@ -62,19 +70,29 @@ isLive (NodeSet m) = any isNodeLive m
isFunDead :: (Liveness, Vector Liveness) -> Bool
isFunDead (retLv, argsLv) = not (isLive retLv || any isLive argsLv)
toLVAResult :: LVAMapping -> R.ComputerState -> LVAResult
toLVAResult AbstractMapping{..} R.ComputerState{..} = LVAResult
{ _memory = V.map convertHeapNodeSet _memory
, _register = Map.map convertReg _absRegisterMap
, _function = Map.map convertFunctionRegs _absFunctionArgMap
{ _memory = V.map convertHeapNodeSet _memory
, _registerLv = Map.map convertRegLv _absRegisterMap
, _functionLv = Map.map convertFunctionRegs _absFunctionArgMap
, _registerEff = Map.map convertRegEff _absRegisterMap
, _functionEff = Map.map convertFunctionEffect _absFunctionArgMap
}
where
isLive :: Set LivenessId -> Bool
isLive = Set.member (-1)
convertReg :: Reg -> Liveness
convertReg (Reg i) = convertValue $ _register V.! (fromIntegral i)
hasEffect :: Set LivenessId -> Bool
hasEffect = Set.member (-2)
convertReg :: (R.Value -> a) -> Reg -> a
convertReg convertValue (Reg i) = convertValue $ _register V.! (fromIntegral i)
convertRegLv :: Reg -> Liveness
convertRegLv = convertReg convertValueLv
convertRegEff :: Reg -> Effect
convertRegEff = convertReg convertValueEff
-- we can encounter empty node sets on the heap
convertHeapNodeSet :: R.NodeSet -> Liveness
@ -91,10 +109,16 @@ toLVAResult AbstractMapping{..} R.ComputerState{..} = LVAResult
where irTaggedMap = Map.map convertFields ns
fromIR irTag = _absTagMap Bimap.!> irTag
convertValue :: R.Value -> Liveness
convertValue (R.Value vals ns)
convertValueLv :: R.Value -> Liveness
convertValueLv (R.Value vals ns)
| Map.null . R._nodeTagMap $ ns = BasicVal (isLive vals)
| otherwise = convertNodeSet ns
convertFunctionRegs :: (Reg, [Reg]) -> (Liveness, Vector Liveness)
convertFunctionRegs (Reg retReg, argRegs) = (convertValue $ _register V.! (fromIntegral retReg), V.fromList [convertValue $ _register V.! (fromIntegral argReg) | Reg argReg <- argRegs])
convertFunctionRegs (Reg retReg, argRegs) = (convertValueLv $ _register V.! (fromIntegral retReg), V.fromList [convertValueLv $ _register V.! (fromIntegral argReg) | Reg argReg <- argRegs])
convertValueEff :: R.Value -> Effect
convertValueEff (R.Value vals _) = Effect (hasEffect vals)
convertFunctionEffect :: (Reg, [Reg]) -> Effect
convertFunctionEffect (retReg, _) = convertRegEff retReg

3
grin/src/AbstractInterpretation/PrettyIR.hs
View File

@ -99,8 +99,7 @@ prettyCondition :: Maybe IRMap -> Condition -> Doc
prettyCondition mirm = \case
NodeTypeExists tag -> prettyTag mirm tag <+> text "exists in"
SimpleTypeExists ty -> prettySimpleType ty <> text "#" <> (integer $ fromIntegral ty) <+> text "exists in"
NotIn tags -> text "not in" <+> list (map (prettyTag mirm) $ Set.toList tags)
All predicate -> text "all" <+> prettyPredicate mirm predicate True
AnyNotIn tags -> text "any not in" <+> list (map (prettyTag mirm) $ Set.toList tags)
Any predicate -> text "any" <+> prettyPredicate mirm predicate False
prettyConstant :: Maybe IRMap -> Constant -> Doc

49
grin/src/AbstractInterpretation/Reduce.hs
View File

@ -12,6 +12,7 @@ import Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Data.Bimap as Bimap
import qualified Data.Foldable
import Data.Maybe
import Data.Function (on)
import GHC.Generics (Generic)
import System.IO.Unsafe
@ -126,15 +127,6 @@ conditionalMoveNodeSet (NodeSet srcTagMap) predicate dstNS@(NodeSet dstTagMap) =
let filteredSrcNS = NodeSet $ Map.map (V.map (Set.filter (`notInRange` rng))) srcTagMap
in mappend filteredSrcNS dstNS
-- NOTE: a ~ Tag
tagPredicateCondition :: ((a -> Bool) -> Set a -> Bool)
-> (a -> Set a -> Bool)
-> Map a b
-> Bool
tagPredicateCondition quantifier predicate tagMap =
let tags = Map.keysSet tagMap
in quantifier (`predicate` tags) tags
-- Note the existential quantifier for the simpleTypes.
-- A field only satisfies the predicate
-- if it actually has a value inside it that satisfies the predicate.
@ -162,28 +154,18 @@ evalInstruction = \case
SimpleTypeExists ty -> do
typeSet <- use $ selectReg srcReg.simpleType
pure $ Set.member ty typeSet
NotIn tags -> do
AnyNotIn tags -> do
tagMap <- use $ selectTagMap srcReg
typeSet <- use $ selectReg srcReg.simpleType
pure $ not (Set.null typeSet) || Data.Foldable.any (`Set.notMember` tags) (Map.keysSet tagMap)
All (TagIn tagSet) -> do
tagMap <- use $ selectTagMap srcReg
pure $ tagPredicateCondition all Set.member tagMap
All (TagNotIn tagSet) -> do
tagMap <- use $ selectTagMap srcReg
pure $ tagPredicateCondition all Set.notMember tagMap
Any (TagIn tagSet) -> do
tagMap <- use $ selectTagMap srcReg
pure $ tagPredicateCondition any Set.member tagMap
let tags = Map.keysSet tagMap
pure $ any (`Set.member` tagSet) tags
Any (TagNotIn tagSet) -> do
tagMap <- use $ selectTagMap srcReg
pure $ tagPredicateCondition any Set.notMember tagMap
All (ValueIn rng) -> do
val <- use $ selectReg srcReg
pure $ valPredicateCondition all (`inRange` rng) val
All (ValueNotIn rng) -> do
val <- use $ selectReg srcReg
pure $ valPredicateCondition all (`notInRange` rng) val
let tags = Map.keysSet tagMap
pure $ any (`Set.notMember` tagSet) tags
Any (ValueIn rng) -> do
val <- use $ selectReg srcReg
pure $ valPredicateCondition any (`inRange` rng) val
@ -209,11 +191,10 @@ evalInstruction = \case
when (Set.member ty typeSet) $ do
selectReg dstReg.simpleType %= (Set.insert ty)
NotIn tags -> do
value <- use $ selectReg srcReg
AnyNotIn tags -> do
tagMap <- use $ selectTagMap srcReg
typeSet <- use $ selectReg srcReg.simpleType
let filteredTagMap = Data.Foldable.foldr Map.delete tagMap tags
let filteredTagMap = Map.withoutKeys tagMap tags
when (not (Set.null typeSet) || not (Map.null filteredTagMap)) $ do
selectReg dstReg.nodeSet %= (mappend $ NodeSet filteredTagMap)
selectReg dstReg.simpleType %= (mappend typeSet)
@ -224,20 +205,20 @@ evalInstruction = \case
let mergedFields = mconcat . (map Data.Foldable.fold) . Map.elems $ tagMap
selectReg dstReg.simpleType %= (mappend mergedFields)
EveryNthField n -> do
tagMap <- use $ selectTagMap srcReg
let mergedNthFields = mconcat . mapMaybe (V.!? n) . Map.elems $ tagMap
selectReg dstReg.simpleType %= (mappend mergedNthFields)
Extend {..} -> do
-- TODO: support all selectors
value <- use $ selectReg srcReg.simpleType
case dstSelector of
NodeItem tag itemIndex -> selectTagMap dstReg.at tag.non mempty.ix itemIndex %= (mappend value)
AllFields -> selectTagMap dstReg %= (Map.map (V.map (mappend value)))
EveryNthField n -> selectTagMap dstReg %= (Map.map (over (ix n) (mappend value)))
ConditionAsSelector cond -> case cond of
-- selects all fields/simpleType having at least one possible value satisfying the predicate
All (ValueIn rng) -> do
selectReg dstReg.simpleType %= (mappendIf (any (`inRange` rng)) value)
selectTagMap dstReg %= Map.map (V.map (mappendIf (any (`inRange` rng)) value))
All (ValueNotIn rng) -> do
selectReg dstReg.simpleType %= (mappendIf (any (`notInRange` rng)) value)
selectTagMap dstReg %= Map.map (V.map (mappendIf (any (`notInRange` rng)) value))
_ -> pure () -- TODO
Move {..} -> move srcReg dstReg

25
grin/src/AbstractInterpretation/ReduceCpp.hs Normal file
View File

@ -0,0 +1,25 @@
{-# LANGUAGE LambdaCase, RecordWildCards, Strict #-}
module AbstractInterpretation.ReduceCpp where
import qualified Data.ByteString.Lazy as LBS
import qualified System.Process
import System.IO.Unsafe
import AbstractInterpretation.IR
import AbstractInterpretation.Reduce (AbstractInterpretationResult)
import AbstractInterpretation.BinaryResult
import AbstractInterpretation.BinaryIR
evalAbstractProgramCpp :: AbstractProgram -> IO AbstractInterpretationResult
evalAbstractProgramCpp prg = do
-- save abstract program to temp file
LBS.writeFile "dataflow_program.dfbin" $ encodeAbstractProgram prg
-- run external reducer
System.Process.callCommand "df_test dataflow_program.dfbin"
-- read back result
loadAbstractInterpretationResult "dataflow_program.dfbin.dat"
evalAbstractProgramCppUnsafe :: AbstractProgram -> AbstractInterpretationResult
evalAbstractProgramCppUnsafe a = unsafePerformIO $ evalAbstractProgramCpp a

4
grin/src/Grin/EffectMap.hs
View File

@ -20,8 +20,8 @@ import Lens.Micro.Platform
import Grin.Grin
-- | Either the name of a function with return type of Unit,
-- or a list of heap locations updated by the function.
-- | Contains the name of all the effectful primops used by the function,
-- and a list of heap locations updated by it.
data Effects
= Effects
{ _effectfulPrimops :: Set Name

3
grin/src/Grin/Grin.hs
View File

@ -9,6 +9,7 @@ import Debug.Trace (trace)
import Lens.Micro.Platform
import Data.Maybe
import Data.Text (pack, unpack)
import Data.List (nub)
import Grin.Syntax
import Grin.TypeEnvDefs
@ -124,7 +125,7 @@ showTS :: Show a => a -> Name
showTS = packName . show
concatPrograms :: [Program] -> Program
concatPrograms prgs = Program (concat exts) (concat defs) where
concatPrograms prgs = Program (nub $ concat exts) (concat defs) where
(exts, defs) = unzip [(e, d) | Program e d <- prgs]
-- indetifier rules for parser and pretty printer

104
grin/src/Grin/Lint.hs
View File

@ -1,6 +1,11 @@
{-# LANGUAGE ViewPatterns, LambdaCase, TupleSections, RecordWildCards, OverloadedStrings, ScopedTypeVariables #-}
{-# LANGUAGE MultiWayIf #-}
module Grin.Lint (lint, Error(..)) where
module Grin.Lint
( lint
, allWarnings
, noDDEWarnings
, Error(..)
) where
import Text.Printf
@ -105,6 +110,7 @@ data Env
, envErrors :: Map Int [Error]
, envDefinedNames :: Map Name DefRole
, envFunArity :: Map Name Int
, envWarningKinds :: [WarningKind] -- Allowed warning kinds
}
emptyEnv = Env
@ -113,6 +119,7 @@ emptyEnv = Env
, envErrors = mempty
, envDefinedNames = mempty
, envFunArity = mempty
, envWarningKinds = []
}
type Lint = State Env
@ -130,6 +137,24 @@ nextId = modify' $ \env@Env{..} -> env {envNextId = succ envNextId}
type check
-}
data WarningKind
= Syntax
| Semantics
| DDE
deriving (Enum, Eq, Ord, Show)
allWarnings :: [WarningKind]
allWarnings = [Syntax .. DDE]
noDDEWarnings :: [WarningKind]
noDDEWarnings = [Syntax, Semantics]
warning :: WarningKind -> [Error] -> Check ()
warning w m = do
ws <- gets envWarningKinds
when (w `elem` ws) $
tell m
syntaxVal :: ValCtx -> Val -> Check Bool
syntaxVal ctx = \case
Lit{} -> pure True
@ -149,7 +174,7 @@ syntaxVal ctx = \case
_ | ctx == ValCtx
-> pure True
_ -> tell [msg $ "Syntax error - expected " ++ showValCtx ctx] >> pure False
_ -> warning Syntax [msg $ "Syntax error - expected " ++ showValCtx ctx] >> pure False
syntaxVal_ :: ValCtx -> Val -> Check ()
syntaxVal_ = void <$$> syntaxVal
@ -163,16 +188,12 @@ syntaxVal_ = void <$$> syntaxVal
Var Name -- HIGH level GRIN
-}
syntaxExp :: ExpCtx -> ExpCtx -> Check Bool
syntaxExp expected given
| given == expected = pure True
| (SimpleExpCtx, ExpCtx) <- (given, expected) = pure True -- simple exp is also an exp
| (SEWithoutNodesCtx, SimpleExpCtx) <- (given, expected) = pure True -- simple exp without nodes is also a simple exp
| (SEWithoutNodesCtx, ExpCtx) <- (given, expected) = pure True -- simple exp without nodes is also an exp
| otherwise = tell [msg $ "Syntax error - expected " ++ showExpCtx expected] >> pure False
syntaxExp_ :: ExpCtx -> ExpCtx -> Check ()
syntaxExp_ = void <$$> syntaxExp
syntaxExp :: ExpCtx -> ExpCtx -> Check ()
syntaxExp expected given | given == expected = pure ()
syntaxExp ExpCtx SimpleExpCtx = pure ()
syntaxExp SimpleExpCtx SEWithoutNodesCtx = pure ()
syntaxExp ExpCtx SEWithoutNodesCtx = pure ()
syntaxExp expected _ = warning Syntax [msg $ "Syntax error - expected " ++ showExpCtx expected]
checkNameDef :: DefRole -> Name -> Check ()
checkNameDef role name = do
@ -181,13 +202,13 @@ checkNameDef role name = do
, env {envDefinedNames = Map.insert name role envDefinedNames}
)
when defined $ do
tell [msg $ printf "multiple defintion of %s" name]
warning Semantics [msg $ printf "multiple defintion of %s" name]
checkNameUse :: Name -> Check ()
checkNameUse name = do
defined <- state $ \env@Env{..} -> (Map.member name envDefinedNames, env)
unless defined $ do
tell [msg $ printf "undefined variable: %s" name]
warning Syntax [msg $ printf "undefined variable: %s" name]
checkVarScopeM :: ExpF a -> Check ()
checkVarScopeM exp = do
@ -253,10 +274,11 @@ check exp nodeCheckM = do
nextId
pure (idx CCTC.:< exp )
lint :: Maybe TypeEnv -> Exp -> (Cofree ExpF Int, Map Int [Error])
lint mTypeEnv exp@(Program exts _) = fmap envErrors $ flip runState emptyEnv $ do
cata functionNames exp
anaM builder (ProgramCtx, maybe noAnnotation annotate mTypeEnv exp)
lint :: [WarningKind] -> Maybe TypeEnv -> Exp -> (Cofree ExpF Int, Map Int [Error])
lint warningKinds mTypeEnv exp@(Program exts _) =
fmap envErrors $ flip runState (emptyEnv { envWarningKinds = warningKinds }) $ do
cata functionNames exp
anaM builder (ProgramCtx, maybe noAnnotation annotate mTypeEnv exp)
where
functionNames :: ExpF (Lint ()) -> Lint ()
functionNames = \case
@ -285,7 +307,7 @@ lint mTypeEnv exp@(Program exts _) = fmap envErrors $ flip runState emptyEnv $ d
let lhsCtx = if notVariable lpat then SEWithoutNodesCtx else SimpleExpCtx
check (EBindF (lhsCtx, leftExp) lpat (ExpCtx, rightExp)) $ do
syntaxE ExpCtx
when (isFetchF leftExp && notVariable lpat) (tell [msg $ "The result of Fetch can only be bound to a variable: " ++ plainShow lpat])
when (isFetchF leftExp && notVariable lpat) (warning DDE [msg $ "The result of Fetch can only be bound to a variable: " ++ plainShow lpat])
when (notVariable lpat) $ do
forM_ mTypeEnv $ \typeEnv -> do
@ -295,7 +317,7 @@ lint mTypeEnv exp@(Program exts _) = fmap envErrors $ flip runState emptyEnv $ d
pure $ do -- Lint
-- NOTE: This can still give false positive errors, because bottom-up typing can only approximate the result of HPT.
when (sameType expectedPatType lhsType == Just False) $ do
tell $ [beforeMsg $ unwords
warning Semantics $ [beforeMsg $ unwords
["Invalid pattern match for", plainShow lpat ++ "." , "Expected pattern of type:", plainShow expectedPatType ++ ",", "but got:", plainShow lhsType]]
(_ :< ECaseF val alts0) -> checkWithChild AltCtx $ do
@ -307,25 +329,27 @@ lint mTypeEnv exp@(Program exts _) = fmap envErrors $ flip runState emptyEnv $ d
map (`Map.singleton` 1) $
concatMap (^.. _AltFCPat . _CPatNodeTag) alts
forM_ (Map.keys $ Map.filter (>1) tagOccurences) $ \(tag :: Tag) ->
tell [beforeMsg $ printf "case has overlapping node alternatives %s" (plainShow tag)]
warning Semantics [beforeMsg $ printf "case has overlapping node alternatives %s" (plainShow tag)]
-- Overlapping literal alternatives
let literalOccurences =
Map.unionsWith (+) $
map (`Map.singleton` 1) $
concatMap (^.. _AltFCPat . _CPatLit) alts
forM_ (Map.keys $ Map.filter (>1) literalOccurences) $ \(lit :: Lit) ->
tell [beforeMsg $ printf "case has overlapping literal alternatives %s" (plainShow lit)]
warning Semantics [beforeMsg $ printf "case has overlapping literal alternatives %s" (plainShow lit)]
let noOfDefaults = length $ findIndices (has (_AltFCPat . _CPatDefault)) alts
-- More than one default
when (noOfDefaults > 1) $ do
tell [beforeMsg $ "case has more than one default alternatives"]
warning Semantics [beforeMsg $ "case has more than one default alternatives"]
forM_ mTypeEnv $ \typeEnv -> do
-- Case variable has a location type
case val of
(Var name) | Just _ <- typeEnv ^? variable . at name . _Just . _T_SimpleType . _T_Location ->
tell [beforeMsg $ printf "case variable %s has a location type" name]
(Var name)
| Just st <- typeEnv ^? variable . at name . _Just . _T_SimpleType
, has _T_Location st || has _T_String st || has _T_Float st
-> warning Semantics [beforeMsg $ printf "case variable %s has non-supported pattern match type: %s" name (plainShow st)]
_ -> pure () -- TODO
-- Non-covered alternatives
@ -333,7 +357,7 @@ lint mTypeEnv exp@(Program exts _) = fmap envErrors $ flip runState emptyEnv $ d
case val of
(Var name) | Just tags <- typeEnv ^? variable . at name . _Just . _T_NodeSet . to Map.keys -> do
forM_ tags $ \tag -> when (Map.notMember tag tagOccurences) $ do
tell [beforeMsg $ printf "case has non-covered alternative %s" (plainShow tag)]
warning Semantics [beforeMsg $ printf "case has non-covered alternative %s" (plainShow tag)]
_ -> pure () -- TODO
-- Simple Exp
@ -344,11 +368,11 @@ lint mTypeEnv exp@(Program exts _) = fmap envErrors $ flip runState emptyEnv $ d
when (not $ isExternalName exts name) $
case Map.lookup name envDefinedNames of
(Just FunName) -> pure ()
(Just _) -> tell [msg $ printf "non-function in function call: %s" name]
Nothing -> tell [msg $ printf "non-defined function is called: %s" name]
(Just _) -> warning Syntax [msg $ printf "non-function in function call: %s" name]
Nothing -> warning Syntax [msg $ printf "non-defined function is called: %s" name]
-- Non saturated function call
forM_ (Map.lookup name envFunArity) $ \n -> when (n /= length args) $ do
tell [msg $ printf "non-saturated function call: %s" name]
warning Syntax [msg $ printf "non-saturated function call: %s" name]
mapM_ (syntaxVal_ SimpleValCtx) args
-- Only simple values should be returned,
@ -362,7 +386,7 @@ lint mTypeEnv exp@(Program exts _) = fmap envErrors $ flip runState emptyEnv $ d
case ctx of
-- last expression in a binding sequence or a single, standalone expression
ExpCtx | hasNoNodes -> syntaxE SEWithoutNodesCtx
| otherwise -> tell [msg $ "Last return expressions can only return non-node values: " ++ plainShow (SReturn val)]
| otherwise -> warning DDE [msg $ "Last return expressions can only return non-node values: " ++ plainShow (SReturn val)]
-- lhs of a binding
SimpleExpCtx | hasNoNodes -> syntaxE SEWithoutNodesCtx
-- lhs of a bidning where the LPat is not a variable
@ -376,11 +400,11 @@ lint mTypeEnv exp@(Program exts _) = fmap envErrors $ flip runState emptyEnv $ d
forM_ mTypeEnv $ \typeEnv -> do
-- Store has given a primitive type
case val of
(Lit lit) -> tell [msg $ printf "store has given a primitive value: %s" (plainShow val)]
(Lit lit) -> warning Semantics [msg $ printf "store has given a primitive value: %s" (plainShow val)]
(ConstTagNode _ _) -> pure ()
(Var name) | Just tags <- typeEnv ^? variable . at name . _Just . _T_NodeSet . to Map.keys -> pure ()
| Just st <- typeEnv ^? variable . at name . _Just . _T_SimpleType -> do
when (st /= T_Dead) $ tell [msg $ printf "store has given a primitive value: %s :: %s" (plainShow val) (plainShow st)]
when (st /= T_Dead) $ warning Semantics [msg $ printf "store has given a primitive value: %s :: %s" (plainShow val) (plainShow st)]
_ -> pure ()
(_ :< SFetchIF name _) -> checkWithChild ctx $ do
@ -390,9 +414,9 @@ lint mTypeEnv exp@(Program exts _) = fmap envErrors $ flip runState emptyEnv $ d
| Just _ <- typeEnv ^? variable . at name . _Just . _T_SimpleType . _T_Location
-> pure ()
| Just st <- typeEnv ^? variable . at name . _Just . _T_SimpleType
-> when (st /= T_Dead) $ tell [msg $ printf "the parameter of fetch is a primitive type: %s :: %s" (plainShow name) (plainShow st)]
-> when (st /= T_Dead) $ warning Semantics [msg $ printf "the parameter of fetch is a primitive type: %s :: %s" (plainShow name) (plainShow st)]
| Just ns <- typeEnv ^? variable . at name . _Just . _T_NodeSet
-> tell [msg $ printf "the parameter of fetch is a node type: %s" (plainShow name)]
-> warning Semantics [msg $ printf "the parameter of fetch is a node type: %s" (plainShow name)]
| otherwise -> pure ()
(_ :< SUpdateF name val) -> checkWithChild ctx $ do
@ -404,19 +428,19 @@ lint mTypeEnv exp@(Program exts _) = fmap envErrors $ flip runState emptyEnv $ d
| Just _ <- typeEnv ^? variable . at name . _Just . _T_SimpleType . _T_Location
-> pure ()
| Just st <- typeEnv ^? variable . at name . _Just . _T_SimpleType
-> when (st /= T_Dead) $ tell [msg $ printf "the parameter of update is a primitive type: %s :: %s" (plainShow name) (plainShow st)]
-> when (st /= T_Dead) $ warning Semantics [msg $ printf "the parameter of update is a primitive type: %s :: %s" (plainShow name) (plainShow st)]
| Just ns <- typeEnv ^? variable . at name . _Just . _T_NodeSet
-> tell [msg $ printf "the parameter of update is a node type: %s" (plainShow name)]
-> warning Semantics [msg $ printf "the parameter of update is a node type: %s" (plainShow name)]
| otherwise -> pure ()
forM_ mTypeEnv $ \typeEnv -> do
-- Update has given a primitive type
case val of
(Lit lit) -> tell [msg $ printf "update has given a primitive value: %s" (plainShow val)]
(Lit lit) -> warning Semantics [msg $ printf "update has given a primitive value: %s" (plainShow val)]
(ConstTagNode _ _) -> pure ()
(Var name) | Just tags <- typeEnv ^? variable . at name . _Just . _T_NodeSet . to Map.keys -> pure ()
| Just st <- typeEnv ^? variable . at name . _Just . _T_SimpleType -> do
when (st /= T_Dead) $ tell [msg $ printf "update has given a primitive value: %s :: %s" (plainShow val) (plainShow st)]
when (st /= T_Dead) $ warning Semantics [msg $ printf "update has given a primitive value: %s :: %s" (plainShow val) (plainShow st)]
_ -> pure ()
(_ :< SBlockF{}) -> checkWithChild ExpCtx $ do
@ -427,7 +451,7 @@ lint mTypeEnv exp@(Program exts _) = fmap envErrors $ flip runState emptyEnv $ d
syntaxE AltCtx
where
syntaxE = syntaxExp_ ctx
syntaxE = syntaxExp ctx
checkWithChild childCtx m = check ((childCtx,) <$> (getF e)) m
getF (_ :< f) = f
@ -439,4 +463,4 @@ lint mTypeEnv exp@(Program exts _) = fmap envErrors $ flip runState emptyEnv $ d
-- Collects the side-effects without appending it to the output.
censorListen :: (Monoid w, Monad m) => WriterT w m a -> WriterT w m (a,w)
censorListen = censor (const mempty) . listen
censorListen = censor (const mempty) . listen

2
grin/src/Grin/Nametable.hs
View File

@ -78,6 +78,7 @@ external (External{..}) =
<*> ty eRetType
<*> mapM ty eArgsType
<*> (pure eEffectful)
<*> (pure eKind)
-- | Convert Names in the expression to Int identifiers and create
-- an associated name table.
@ -149,6 +150,7 @@ restore (exp, nt) = cata build exp where
(rty eRetType)
(map rty eArgsType)
eEffectful
eKind
rty :: Ty -> Ty
rty = \case

13
grin/src/Grin/Parse/AST.hs
View File

@ -108,23 +108,24 @@ satisfyM pred parser = do
externalBlock = do
L.indentGuard sc EQ pos1
kw "primop"
ext <- const PrimOp <$> kw "primop" <|> const FFI <$> kw "ffi"
eff <- const False <$> kw "pure" <|> const True <$> kw "effectful"
i <- L.indentGuard sc GT pos1
some $ try (external eff i)
some $ try (external ext eff i)
external :: Bool -> Pos -> Parser External
external eff i = do
external :: ExternalKind -> Bool -> Pos -> Parser External
external ext eff i = do
L.indentGuard sc EQ i
name <- var
op "::"
ty <- reverse <$> sepBy1 tyP (op "->")
L.indentGuard sc GT i >> op "::"
ty <- reverse <$> sepBy1 (L.indentGuard sc GT i >> L.lexeme sc tyP ) (L.indentGuard sc GT i >> op "->")
let (retTy:argTyRev) = ty
pure External
{ eName = name
, eRetType = retTy
, eArgsType = reverse argTyRev
, eEffectful = eff
, eKind = ext
}
tyP :: Parser Ty

61
grin/src/Grin/Pretty.hs
View File

@ -4,6 +4,9 @@ module Grin.Pretty
, printGrin
, PP(..)
, WPP(..)
, RenderingOption(..)
, prettyProgram
, prettyHighlightExternals
, prettyKeyValue
, prettyBracedList
, prettySimplePair
@ -80,32 +83,44 @@ showName n = case unpackName n of
instance Pretty Name where
pretty = text . showName
data RenderingOption
= Simple
| WithExternals
deriving (Eq, Ord, Show, Read)
prettyProgram :: RenderingOption -> Exp -> Doc
prettyProgram Simple (Program exts e) = prettyHighlightExternals exts (Program [] e)
prettyProgram WithExternals p@(Program exts _) = prettyHighlightExternals exts p
prettyProgram _ p = prettyHighlightExternals [] p
-- TODO
-- nice colors for syntax highlight
-- better node type syntax (C | F | P)
-- | Print a given expression with highlighted external functions.
prettyHighlightExternals :: [External] -> Exp -> Doc
prettyHighlightExternals externals exp = cata folder exp where
folder = \case
ProgramF exts defs -> vcat (prettyExternals exts : defs)
DefF name args exp -> hsep (pretty name : map pretty args) <+> text "=" <$$> indent 2 exp <> line
-- Exp
EBindF simpleexp Unit exp -> simpleexp <$$> exp
EBindF simpleexp lpat exp -> pretty lpat <+> text "<-" <+> simpleexp <$$> exp
ECaseF val alts -> keyword "case" <+> pretty val <+> keyword "of" <$$> indent 2 (vsep alts)
-- Simple Expr
SAppF name args -> hsep (((if isExternalName externals name then dullyellow else cyan) $ pretty name) : text "$" : map pretty args)
SReturnF val -> keyword "pure" <+> pretty val
SStoreF val -> keywordR "store" <+> pretty val
SFetchIF name Nothing -> keywordR "fetch" <+> pretty name
SFetchIF name (Just i) -> keywordR "fetch" <+> pretty name <> brackets (int i)
SUpdateF name val -> keywordR "update" <+> pretty name <+> pretty val
SBlockF exp -> text "do" <$$> indent 2 exp
-- Alt
AltF cpat exp -> pretty cpat <+> text "->" <$$> indent 2 exp
instance Pretty Exp where
pretty exp = cata folder exp where
externals = case exp of
(Program es _) -> es
_ -> []
folder = \case
ProgramF exts defs -> vcat (prettyExternals exts : map pretty defs)
DefF name args exp -> hsep (pretty name : map pretty args) <+> text "=" <$$> indent 2 (pretty exp) <> line
-- Exp
EBindF simpleexp Unit exp -> pretty simpleexp <$$> pretty exp
EBindF simpleexp lpat exp -> pretty lpat <+> text "<-" <+> pretty simpleexp <$$> pretty exp
ECaseF val alts -> keyword "case" <+> pretty val <+> keyword "of" <$$> indent 2 (vsep (map pretty alts))
-- Simple Expr
SAppF name args -> hsep (((if isExternalName externals name then dullyellow else cyan) $ pretty name) : text "$" : map pretty args)
SReturnF val -> keyword "pure" <+> pretty val
SStoreF val -> keywordR "store" <+> pretty val
SFetchIF name Nothing -> keywordR "fetch" <+> pretty name
SFetchIF name (Just i) -> keywordR "fetch" <+> pretty name <> brackets (int i)
SUpdateF name val -> keywordR "update" <+> pretty name <+> pretty val
SBlockF exp -> text "do" <$$> indent 2 (pretty exp)
-- Alt
AltF cpat exp -> pretty cpat <+> text "->" <$$> indent 2 (pretty exp)
pretty = prettyProgram Simple
instance Pretty Val where
pretty = \case
@ -186,7 +201,7 @@ instance Pretty EffectMap where
indent 4 (prettyKeyValue $ Map.toList effects)
prettyExternals :: [External] -> Doc
prettyExternals exts = vcat (map prettyExtGroup $ groupBy (\a b -> eEffectful a == eEffectful b) exts) where
prettyExternals exts = vcat (map prettyExtGroup $ groupBy (\a b -> eEffectful a == eEffectful b && eKind a == eKind b) exts) where
prettyExtGroup [] = mempty
prettyExtGroup l@(a : _) = keyword "primop" <+> (if eEffectful a then keyword "effectful" else keyword "pure") <$$> indent 2
(vsep [prettyFunction (eName, (eRetType, V.fromList eArgsType)) | External{..} <- l] <> line)
@ -203,7 +218,7 @@ prettyBracedList = encloseSep lbrace rbrace comma
prettySimplePair :: (Pretty a, Pretty b) => (a, b) -> Doc
prettySimplePair (x, y) = pretty x <> pretty y
prettyFunction :: Pretty a => (Name, (a, Vector a)) -> Doc
prettyFunction :: (Pretty a, Pretty name) => (name, (a, Vector a)) -> Doc
prettyFunction (name, (ret, args)) = pretty name <> align (encloseSep (text " :: ") empty (text " -> ") (map pretty $ (V.toList args) ++ [ret]))
prettyLocSet :: Set Loc -> Doc

21
grin/src/Grin/PrimOpsPrelude.hs
View File

@ -13,27 +13,27 @@ import Grin.TH
primPrelude :: Program
primPrelude = [progConst|
primop effectful
_prim_int_print :: T_Int64 -> T_Unit
ffi effectful
_prim_int_print :: T_Int64 -> T_Unit
_prim_usleep :: T_Int64 -> T_Unit
_prim_string_print :: T_String -> T_Unit
_prim_read_string :: T_String
_prim_usleep :: T_Int64 -> T_Unit
_prim_error :: T_String -> T_Unit
-- FFI - TODO: Handle FFI appropiately
_prim_ffi_file_eof :: T_Int64 -> T_Int64
primop pure
-- Everything that handles Strings are FFI implemented now.
ffi pure
-- String
_prim_string_concat :: T_String -> T_String -> T_String
_prim_string_reverse :: T_String -> T_String
_prim_string_lt :: T_String -> T_String -> T_Bool
_prim_string_eq :: T_String -> T_String -> T_Bool
_prim_string_head :: T_String -> T_Int64
_prim_string_lt :: T_String -> T_String -> T_Int64
_prim_string_eq :: T_String -> T_String -> T_Int64
_prim_string_head :: T_String -> T_Int64 -- TODO: Change to Char
_prim_string_tail :: T_String -> T_String
_prim_string_cons :: T_Int64 -> T_String -> T_String
_prim_string_len :: T_String -> T_Int64
ffi pure
-- Conversion
_prim_int_str :: T_Int64 -> T_String
_prim_str_int :: T_String -> T_Int64
@ -41,11 +41,14 @@ primPrelude = [progConst|
_prim_float_string :: T_Float -> T_String
_prim_char_int :: T_Char -> T_Int64
primop pure
-- Int
_prim_int_shr :: T_Int64 -> T_Int64 -- TODO: Remove?
_prim_int_add :: T_Int64 -> T_Int64 -> T_Int64
_prim_int_sub :: T_Int64 -> T_Int64 -> T_Int64
_prim_int_mul :: T_Int64 -> T_Int64 -> T_Int64
_prim_int_div :: T_Int64 -> T_Int64 -> T_Int64
_prim_int_ashr :: T_Int64 -> T_Int64 -> T_Int64
_prim_int_eq :: T_Int64 -> T_Int64 -> T_Bool
_prim_int_ne :: T_Int64 -> T_Int64 -> T_Bool
_prim_int_gt :: T_Int64 -> T_Int64 -> T_Bool

17
grin/src/Grin/Syntax.hs
View File

@ -32,12 +32,18 @@ data Ty
| TySimple SimpleType
deriving (Generic, Data, NFData, Eq, Ord, Show)
data ExternalKind
= PrimOp -- ^ Implemented in the internal code generator
| FFI -- ^ Implemented in C and linked during the linker phase
deriving (Generic, Data, NFData, Eq, Ord, Show)
data External
= External
{ eName :: Name
, eRetType :: Ty
, eArgsType :: [Ty]
, eEffectful :: Bool
, eKind :: ExternalKind
}
deriving (Generic, Data, NFData, Eq, Ord, Show)
@ -117,6 +123,7 @@ externals = \case
-- * Binary instances
deriving instance Binary Name
deriving instance Binary ExternalKind
deriving instance Binary External
deriving instance Binary Ty
deriving instance Binary SimpleType
@ -142,6 +149,12 @@ deriving instance Ord a => Ord (ExpF a)
pattern SFetch name = SFetchI name Nothing
pattern SFetchF name = SFetchIF name Nothing
pattern BoolPat b = LitPat (LBool b)
_AltCPat :: Traversal' Exp CPat
_AltCPat f (Alt p e) = (`Alt` e) <$> f p
_AltCPat _ other = pure other
_AltFCPat :: Traversal' (ExpF a) CPat
_AltFCPat f (AltF p e) = (`AltF` e) <$> f p
_AltFCPat _ other = pure other
@ -158,6 +171,10 @@ _CPatDefault :: Traversal' CPat ()
_CPatDefault f DefaultPat = const DefaultPat <$> f ()
_CPatDefault _ other = pure other
_ValVar :: Traversal' Val Name
_ValVar f (Var name) = Var <$> f name
_ValVar _ other = pure other
_TyCon :: Traversal' Ty (Name, [Ty])
_TyCon f (TyCon n ts) = uncurry TyCon <$> f (n, ts)
_TyCon _ other = pure other

7
grin/src/Grin/SyntaxDefs.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, DeriveAnyClass, StandaloneDeriving #-}
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, DeriveAnyClass, StandaloneDeriving, LambdaCase #-}
module Grin.SyntaxDefs where
import Data.Text (Text, unpack)
@ -31,6 +31,11 @@ instance IsString Name where
instance PrintfArg Name where
formatArg = formatString . unpack . unNM
nameString :: Name -> String
nameString = \case
NM n -> unpack n
_ -> error "Name index found." -- This could have left in the AST after a problematic deserialisation.
-- * GRIN Tag
data TagType = C | F | P Int {-missing parameter count-}

8
grin/src/Grin/TypeEnv.hs
View File

@ -66,6 +66,14 @@ _T_Location :: Traversal' SimpleType [Int]
_T_Location f (T_Location ls) = T_Location <$> f ls
_T_Location _ rest = pure rest
_T_String :: Traversal' SimpleType ()
_T_String f T_String = const T_String <$> f ()
_T_String _ rest = pure rest
_T_Float :: Traversal' SimpleType ()
_T_Float f T_Float = const T_Float <$> f ()
_T_Float _ rest = pure rest
_T_Unit :: Traversal' SimpleType ()
_T_Unit f T_Unit = const T_Unit <$> f ()
_T_Unit _ rest = pure rest

204
grin/src/Pipeline/Pipeline.hs
View File

@ -7,8 +7,11 @@ module Pipeline.Pipeline
, Transformation(..)
, EffectStep(..)
, Path(..)
, RenderingOption(..)
, pattern HPTPass
, pattern PrintGrin
, pattern SimplePrintGrin
, pattern FullPrintGrin
, pattern DeadCodeElimination
, pipeline
, optimize
@ -29,11 +32,11 @@ import Pipeline.Eval
import Grin.Grin
import Grin.TypeEnv
import Grin.TypeCheck
import Grin.EffectMap
import Grin.EffectMap hiding (Eff)
import Pipeline.Optimizations
import qualified Grin.Statistics as Statistics
import Grin.Parse
import Grin.Pretty(showWide)
import Grin.Pretty(showWide, prettyProgram, RenderingOption(..))
import Transformations.CountVariableUse
import Transformations.GenerateEval
import qualified Transformations.Simplifying.Vectorisation2 as Vectorisation2
@ -42,6 +45,7 @@ import Transformations.BindNormalisation
import qualified Grin.Lint as Lint
import Grin.PrettyLint
import Transformations.Simplifying.SplitFetch
import Transformations.Simplifying.BindingPatternSimplification
import Transformations.Simplifying.CaseSimplification
import Transformations.Optimising.Inlining (inlineEval, inlineApply, inlineBuiltins)
import Transformations.UnitPropagation
@ -52,29 +56,34 @@ import Transformations.Names (ExpChanges(..))
import qualified Transformations.Simplifying.RightHoistFetch2 as RHF
import Transformations.Simplifying.RegisterIntroduction
import Transformations.Simplifying.ProducerNameIntroduction
import qualified AbstractInterpretation.HeapPointsTo.Result as HPT
import qualified AbstractInterpretation.CreatedBy.Readback as CBy
import qualified AbstractInterpretation.CreatedBy.Result as CBy
import qualified AbstractInterpretation.LiveVariable.Result as LVA
import qualified AbstractInterpretation.Sharing.Result as Sharing
import qualified AbstractInterpretation.HeapPointsTo.Result as HPT
import qualified AbstractInterpretation.CreatedBy.Readback as CBy
import qualified AbstractInterpretation.CreatedBy.Result as CBy
import qualified AbstractInterpretation.LiveVariable.Result as LVA
import qualified AbstractInterpretation.EffectTracking.Result as ET
import qualified AbstractInterpretation.Sharing.Result as Sharing
import AbstractInterpretation.BinaryIR
import AbstractInterpretation.OptimiseAbstractProgram
import AbstractInterpretation.CreatedBy.Pretty
import AbstractInterpretation.HeapPointsTo.Pretty
import AbstractInterpretation.LiveVariable.Pretty
import AbstractInterpretation.EffectTracking.Pretty
import AbstractInterpretation.Sharing.Pretty
import AbstractInterpretation.Sharing.CodeGen
import AbstractInterpretation.Reduce (ComputerState, AbstractInterpretationResult(..), evalAbstractProgram)
import qualified AbstractInterpretation.PrettyIR as IR
import qualified AbstractInterpretation.IR as IR
import qualified AbstractInterpretation.HeapPointsTo.CodeGen as HPT
import qualified AbstractInterpretation.HeapPointsTo.CodeGenBase as HPT
import qualified AbstractInterpretation.CreatedBy.CodeGen as CBy
import qualified AbstractInterpretation.LiveVariable.CodeGen as LVA
import qualified AbstractInterpretation.Sharing.CodeGen as Sharing
import qualified AbstractInterpretation.HeapPointsTo.CodeGen as HPT
import qualified AbstractInterpretation.HeapPointsTo.CodeGenBase as HPT
import qualified AbstractInterpretation.CreatedBy.CodeGen as CBy
import qualified AbstractInterpretation.LiveVariable.CodeGen as LVA
import qualified AbstractInterpretation.EffectTracking.CodeGen as ET
import qualified AbstractInterpretation.EffectTracking.CodeGenBase as ET
import qualified AbstractInterpretation.Sharing.CodeGen as Sharing
import qualified Reducer.LLVM.CodeGen as CGLLVM
import qualified Reducer.LLVM.JIT as JITLLVM
import System.Directory
import System.Process
import qualified System.Process
import Data.Bifunctor
import qualified Data.Bimap as Bimap
@ -107,12 +116,14 @@ import Data.Maybe (isNothing)
import System.IO (BufferMode(..), hSetBuffering, stdout)
import Data.Binary as Binary
import Grin.Nametable as Nametable
import qualified Data.ByteString.Lazy as LBS
data Transformation
-- Simplifying
= RegisterIntroduction
| ProducerNameIntroduction
| BindingPatternSimplification
| Vectorisation
| SplitFetch
| CaseSimplification
@ -162,6 +173,7 @@ data AbstractComputationStep
= Compile
| Optimise
| PrintProgram
| SaveProgram String
| RunPure
| PrintResult
deriving (Eq, Show)
@ -176,16 +188,18 @@ data PipelineStep
| HPT AbstractComputationStep
| CBy AbstractComputationStep
| LVA AbstractComputationStep
| ET AbstractComputationStep
| Sharing AbstractComputationStep
| RunCByWithLVA -- TODO: Remove
| Eff EffectStep
| T Transformation
| Pass [PipelineStep]
| PrintGrinH (Hidden (Doc -> Doc))
| PrintGrinH RenderingOption (Hidden (Doc -> Doc))
| PureEval
| JITLLVM
| PrintAST
| SaveLLVM Bool FilePath
| SaveLLVM Path
| SaveExecutable Bool Path -- Debug, Outputfile
| SaveGrin Path
| SaveBinary String
| DebugTransformationH (Hidden (Exp -> Exp))
@ -218,9 +232,17 @@ data Path
| Rel FilePath
deriving (Eq, Show)
pattern PrintGrin :: (Doc -> Doc) -> PipelineStep
pattern PrintGrin c <- PrintGrinH (H c)
where PrintGrin c = PrintGrinH (H c)
pattern PrintGrin :: RenderingOption -> (Doc -> Doc) -> PipelineStep
pattern PrintGrin r c <- PrintGrinH r (H c)
where PrintGrin r c = PrintGrinH r (H c)
pattern SimplePrintGrin :: (Doc -> Doc) -> PipelineStep
pattern SimplePrintGrin c <- PrintGrinH Simple (H c)
where SimplePrintGrin c = PrintGrinH Simple (H c)
pattern FullPrintGrin :: (Doc -> Doc) -> PipelineStep
pattern FullPrintGrin c <- PrintGrinH WithExternals (H c)
where FullPrintGrin c = PrintGrinH WithExternals (H c)
pattern DebugTransformation :: (Exp -> Exp) -> PipelineStep
pattern DebugTransformation t <- DebugTransformationH (H t)
@ -235,6 +257,7 @@ data PipelineOpts = PipelineOpts
, _poLintOnChange :: Bool
, _poTypedLint :: Bool -- Run HPT before every lint
, _poSaveBinary :: Bool
, _poCFiles :: [FilePath]
}
defaultOpts :: PipelineOpts
@ -247,6 +270,7 @@ defaultOpts = PipelineOpts
, _poLintOnChange = True
, _poTypedLint = False
, _poSaveBinary = False
, _poCFiles = []
}
type PipelineM a = ReaderT PipelineOpts (StateT PState IO) a
@ -260,6 +284,8 @@ data PState = PState
, _psCByResult :: Maybe CBy.CByResult
, _psLVAProgram :: Maybe (IR.AbstractProgram, LVA.LVAMapping)
, _psLVAResult :: Maybe LVA.LVAResult
, _psETProgram :: Maybe (IR.AbstractProgram, ET.ETMapping)
, _psETResult :: Maybe ET.ETResult
, _psSharingProgram :: Maybe (IR.AbstractProgram, Sharing.SharingMapping)
, _psSharingResult :: Maybe Sharing.SharingResult
-- the type environment calculated by HPT
@ -295,7 +321,6 @@ data TransformationFunc
| WithTypeEnvEff (TypeEnv -> EffectMap -> Exp -> (Exp, ExpChanges))
| WithTypeEnvShr (Sharing.SharingResult -> TypeEnv -> Exp -> (Exp, ExpChanges))
| WithLVA (LVA.LVAResult -> TypeEnv -> Exp -> Either String (Exp, ExpChanges))
| WithEffLVA (LVA.LVAResult -> EffectMap -> TypeEnv -> Exp -> Either String (Exp, ExpChanges))
| WithLVACBy (LVA.LVAResult -> CBy.CByResult -> TypeEnv -> Exp -> Either String (Exp, ExpChanges))
-- TODO: Add n paramter for the transformations that use NameM
@ -307,6 +332,7 @@ transformationFunc n = \case
SplitFetch -> Plain (noNewNames . splitFetch)
RegisterIntroduction -> Plain (newNames . registerIntroductionI n) -- TODO
ProducerNameIntroduction -> Plain producerNameIntroduction
BindingPatternSimplification -> Plain bindingPatternSimplification
RightHoistFetch -> Plain (noNewNames . RHF.rightHoistFetch)
-- misc
MangleNames -> Plain (newNames . mangleNames) -- TODO
@ -332,15 +358,15 @@ transformationFunc n = \case
ArityRaising -> WithTypeEnv (Right <$$> (arityRaising n))
LateInlining -> WithTypeEnv (Right <$$> lateInlining)
UnitPropagation -> WithTypeEnv (noNewNames <$$> Right <$$> unitPropagation)
NonSharedElimination -> WithTypeEnvShr (noNewNames <$$$> nonSharedElimination)
DeadFunctionElimination -> WithEffLVA (noNewNames <$$$$$> deadFunctionElimination)
DeadVariableElimination -> WithEffLVA (noNewNames <$$$$$> deadVariableElimination)
NonSharedElimination -> WithTypeEnvShr nonSharedElimination
DeadFunctionElimination -> WithLVA (noNewNames <$$$$> deadFunctionElimination)
DeadVariableElimination -> WithLVA (noNewNames <$$$$> deadVariableElimination)
DeadParameterElimination -> WithLVA (noNewNames <$$$$> deadParameterElimination)
DeadDataElimination -> WithLVACBy deadDataElimination
SparseCaseOptimisation -> WithTypeEnv (noNewNames <$$$> sparseCaseOptimisation)
where
noNewNames = flip (,) NoChange
newNames = flip (,) NewNames
noNewNames = flip (,) NoChange
newNames = flip (,) NewNames
transformation :: Transformation -> PipelineM ()
transformation t = do
@ -349,6 +375,7 @@ transformation t = do
e <- use psExp
te <- fromMaybe (traceShow "empty type env is used" emptyTypeEnv) <$> use psTypeEnv
em <- fromMaybe (traceShow "empty effect map is used" mempty) <$> use psEffectMap
et <- fromMaybe (traceShow "empty effect tracking result is used" mempty) <$> use psETResult
cby <- fromMaybe (traceShow "empty created by result is used" CBy.emptyCByResult) <$> use psCByResult
lva <- fromMaybe (traceShow "empty live variable result is used" LVA.emptyLVAResult) <$> use psLVAResult
shr <- fromMaybe (traceShow "empty sharing result is used" Sharing.emptySharingResult) <$> use psSharingResult
@ -358,7 +385,6 @@ transformation t = do
WithTypeEnv f -> f te e
WithTypeEnvEff f -> Right $ f te em e
WithLVA f -> f lva te e
WithEffLVA f -> f lva em te e
WithLVACBy f -> f lva cby te e
WithTypeEnvShr f -> Right $ f shr te e
psTransStep %= (+1)
@ -384,6 +410,7 @@ pipelineStep p = do
Compile -> compileAbstractProgram HPT.codeGen psHPTProgram
Optimise -> optimiseAbsProgWith psHPTProgram "HPT program is not available to be optimized"
PrintProgram -> printAbstractProgram psHPTProgram
SaveProgram p -> saveAbstractProgram p psHPTProgram
RunPure -> runHPTPure
PrintResult -> printAnalysisResult psHPTResult
@ -391,6 +418,7 @@ pipelineStep p = do
Compile -> compileAbstractProgram CBy.codeGen psCByProgram
Optimise -> optimiseAbsProgWith psCByProgram "CBy program is not available to be optimized"
PrintProgram -> printAbstractProgram psCByProgram
SaveProgram p -> saveAbstractProgram p psCByProgram
RunPure -> runCByPure
PrintResult -> printAnalysisResult psCByResult
@ -398,15 +426,24 @@ pipelineStep p = do
Compile -> compileAbstractProgram LVA.codeGen psLVAProgram
Optimise -> optimiseAbsProgWith psLVAProgram "LVA program is not available to be optimized"
PrintProgram -> printAbstractProgram psLVAProgram
SaveProgram p -> saveAbstractProgram p psLVAProgram
RunPure -> runLVAPure
PrintResult -> printAnalysisResult psLVAResult
ET step -> case step of
Compile -> compileAbstractProgram ET.codeGen psETProgram
Optimise -> optimiseAbsProgWith psETProgram "ET program is not available to be optimized"
PrintProgram -> printAbstractProgram psETProgram
RunPure -> runETPure
PrintResult -> printAnalysisResult psETResult
RunCByWithLVA -> runCByWithLVAPure
Sharing step -> case step of
Compile -> compileAbstractProgram Sharing.codeGen psSharingProgram
Optimise -> optimiseAbsProgWith psSharingProgram "Sharing program is not available to be optimized"
PrintProgram -> printAbstractProgram psSharingProgram
SaveProgram p -> saveAbstractProgram p psSharingProgram
RunPure -> runSharingPure
PrintResult -> printAnalysisResult psSharingResult
@ -415,10 +452,11 @@ pipelineStep p = do
PrintEffectMap -> printEffectMap
T t -> transformation t
Pass pass -> mapM_ pipelineStep pass
PrintGrin d -> printGrinM d
PrintGrin r d -> printGrinM r d
PureEval -> pureEval
JITLLVM -> jitLLVM
SaveLLVM relPath path -> saveLLVM relPath path
SaveLLVM path -> saveLLVM path
SaveExecutable dbg path -> saveExecutable dbg path
SaveGrin path -> saveGrin path
SaveBinary name -> saveBinary name
PrintAST -> printAST
@ -486,6 +524,17 @@ printAbstractProgram accessProg = do
progM <- use accessProg
mapM_ (printAbsProg . fst) progM
saveAbstractProgram :: String -> (Lens' PState (Maybe (IR.AbstractProgram, a))) -> PipelineM ()
saveAbstractProgram name accessProg = do
progM <- use accessProg
n <- use psSaveIdx
case progM of
Nothing -> pure ()
Just (prog, mapping) -> do
outputDir <- view poOutputDir
let fname = printf "%03d.%s.dfbin" n name
liftIO $ LBS.writeFile (outputDir </> fname) $ encodeAbstractProgram prog
printAnalysisResult :: Pretty res => (Lens' PState (Maybe res)) -> PipelineM ()
printAnalysisResult accessRes = use accessRes >>= \case
Nothing -> pure ()
@ -544,6 +593,15 @@ runLVAPure = use psLVAProgram >>= \case
pipelineLogIterations _airIter
psLVAResult .= Just result
runETPure :: PipelineM ()
runETPure = use psETProgram >>= \case
Nothing -> psETResult .= Nothing
Just (etProgram, etMapping) -> do
let AbsIntResult{..} = evalAbstractProgram $ etProgram
result = ET.toETResult etMapping _airComp
pipelineLogIterations _airIter
psETResult .= Just result
runSharingPureWith :: (Sharing.SharingMapping -> ComputerState -> Sharing.SharingResult) -> PipelineM ()
runSharingPureWith toSharingResult = use psSharingProgram >>= \case
Nothing -> psSharingResult .= Nothing
@ -601,10 +659,10 @@ pureEval = do
evalProgram PureReducer e
pipelineLog $ show $ pretty val
printGrinM :: (Doc -> Doc) -> PipelineM ()
printGrinM color = do
e <- use psExp
pipelineLog $ showWide $ color $ pretty e
printGrinM :: RenderingOption -> (Doc -> Doc) -> PipelineM ()
printGrinM r color = do
p <- use psExp
pipelineLog $ showWide $ color $ prettyProgram r p
jitLLVM :: PipelineM ()
jitLLVM = do
@ -635,23 +693,48 @@ saveBinary name = do
let fname = printf "%03d.%s.binary" n name
liftIO $ Binary.encodeFile (outputDir </> fname) ent
saveLLVM :: Bool -> FilePath -> PipelineM ()
saveLLVM relPath fname' = do
e <- use psExp
relPath :: Path -> PipelineM String
relPath path = do
n <- use psSaveIdx
Just typeEnv <- use psTypeEnv
o <- view poOutputDir
let fname = if relPath then o </> printf "%03d.%s" n fname' else fname'
code = CGLLVM.codeGen typeEnv e
llName = printf "%s.ll" fname
sName = printf "%s.s" fname
liftIO . void $ do
Text.putStrLn $ ppllvm code
putStrLn "* to LLVM *"
_ <- CGLLVM.toLLVM llName code
putStrLn "* LLVM X64 codegen *"
callCommand $ printf "opt-7 -O3 %s | llc-7 -o %s" llName sName
readFile sName >>= putStrLn
pure $ case path of
Abs fname -> fname
Rel fname -> o </> printf "%03d.%s" n fname
callCommand :: String -> PipelineM ()
callCommand cmd = do
pipelineLog $ "Call command:" ++ cmd
liftIO $ System.Process.callCommand cmd
saveLLVM :: Path -> PipelineM ()
saveLLVM path = do
e <- use psExp
pipelineStep HPTPass
Just typeEnv <- use psTypeEnv
fname <- relPath path
let code = CGLLVM.codeGen typeEnv e
let llName = printf "%s.ll" fname
let sName = printf "%s.s" fname
pipelineLog "* to LLVM *"
void $ liftIO $ CGLLVM.toLLVM llName code
pipelineLog"* LLVM X64 codegen *"
callCommand $ printf "opt-7 -O3 %s | llc-7 -o %s" llName (sName :: String)
saveExecutable :: Bool -> Path -> PipelineM ()
saveExecutable debugSymbols path = do
pipelineLog "* generate llvm x64 optcode *"
let grinOptCodePath = Rel "grin-opt-code"
pipelineStep $ SaveLLVM grinOptCodePath
grinOptCodeFile <- relPath grinOptCodePath
fname <- relPath path
pipelineLog "* generate executable *"
callCommand $ printf
("llc-7 -O3 -relocation-model=pic -filetype=obj %s.ll" ++ if debugSymbols then " -debugger-tune=gdb" else "")
grinOptCodeFile
cfg <- ask
callCommand $ printf
("clang-7 -O3 %s %s.o -s -o %s" ++ if debugSymbols then " -g" else "")
(intercalate " " $ _poCFiles cfg) grinOptCodeFile fname
debugTransformation :: (Exp -> Exp) -> PipelineM ()
debugTransformation t = do
@ -666,7 +749,10 @@ lintGrin mPhaseName = do
pipelineStep $ HPT RunPure
exp <- use psExp
mTypeEnv <- use psTypeEnv
let lintExp@(_, errorMap) = Lint.lint mTypeEnv exp
-- By default we don't run the DDE related warnings. They should be enabled
-- when we do refactor on transformations to not to create non-DDE conforming
-- nodes, and they should be removed when we refactor the possible syntax.
let lintExp@(_, errorMap) = Lint.lint Lint.noDDEWarnings mTypeEnv exp
psErrors .= (fmap Lint.message $ concat $ Map.elems errorMap)
-- print errors
@ -757,7 +843,8 @@ randomPipelineM seed = do
runBasicAnalyses = mapM_ pipelineStep
[ Sharing Compile
, Sharing RunPure
, Eff CalcEffectMap
, ET Compile
, ET RunPure
]
runCByLVA :: PipelineM ()
@ -766,13 +853,16 @@ randomPipelineM seed = do
, CBy RunPure
, LVA Compile
, LVA RunPure
, Eff CalcEffectMap
, ET Compile
, ET RunPure
]
runNameIntro :: PipelineM ()
runNameIntro = void . pipelineStep $ Pass
[ T ProducerNameIntroduction
, T BindNormalisation
, T BindingPatternSimplification
, T BindNormalisation
]
-- cleanup after producer name intro
@ -832,6 +922,8 @@ runPipeline o ta e m = do
, _psCByResult = Nothing
, _psLVAProgram = Nothing
, _psLVAResult = Nothing
, _psETProgram = Nothing
, _psETResult = Nothing
, _psSharingResult = Nothing
, _psSharingProgram = Nothing
, _psTypeEnv = Nothing
@ -962,6 +1054,8 @@ optimizeWithM pre trans post = do
, SimpleDeadVariableElimination
, ProducerNameIntroduction
, BindNormalisation
, BindingPatternSimplification
, BindNormalisation
, UnitPropagation
]
, map T $ trans `intersect`
@ -987,6 +1081,8 @@ invalidateAnalysisResults = do
psCByResult .= Nothing
psLVAProgram .= Nothing
psLVAResult .= Nothing
psETProgram .= Nothing
psETResult .= Nothing
psSharingProgram .= Nothing
psSharingResult .= Nothing
psTypeEnv .= Nothing
@ -1000,8 +1096,7 @@ runAnalysisFor t = do
WithTypeEnv _ -> [hpt]
WithTypeEnvEff _ -> [hpt, eff]
WithLVA _ -> [hpt, lva]
WithEffLVA _ -> [hpt, lva, cby, sharing, eff]
WithLVACBy _ -> [hpt, lva, cby, sharing, eff]
WithLVACBy _ -> [hpt, cby, lva, sharing]
WithTypeEnvShr _ -> [hpt, sharing]
where
analysis getter ann = do
@ -1014,6 +1109,7 @@ runAnalysisFor t = do
hpt = analysis psHPTResult HPT
lva = analysis psLVAResult LVA
cby = analysis psCByResult CBy
et = analysis psETResult ET
sharing = analysis psSharingResult Sharing
eff :: PipelineM ()
@ -1068,7 +1164,7 @@ defaultOptimizations =
]
debugPipeline :: [PipelineStep] -> [PipelineStep]
debugPipeline ps = [PrintGrin id] ++ ps ++ [PrintGrin id]
debugPipeline ps = [SimplePrintGrin id] ++ ps ++ [SimplePrintGrin id]
debugPipelineState :: PipelineM ()
debugPipelineState = do
@ -1083,6 +1179,8 @@ printingSteps =
, CBy PrintResult
, LVA PrintProgram
, LVA PrintResult
, ET PrintProgram
, ET PrintResult
, Sharing PrintProgram
, Sharing PrintResult
, PrintTypeEnv
@ -1091,7 +1189,7 @@ printingSteps =
, PrintErrors
, PrintTypeAnnots
, DebugPipelineState
, PrintGrin id
, SimplePrintGrin id
]
isPrintingStep :: PipelineStep -> Bool

5
grin/src/Reducer/LLVM/Base.hs
View File

@ -11,6 +11,7 @@ import Lens.Micro.Platform
import Data.Word
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import Data.Vector (Vector)
import Grin.Grin as Grin
@ -55,6 +56,8 @@ data Env
, _envTempCounter :: Int
, _envTypeEnv :: TypeEnv.TypeEnv
, _envTagMap :: Map Tag Constant
, _envStringMap :: Map Text AST.Name -- Grin String Literal -> AST.Name
, _envStringCounter :: Int
}
emptyEnv = Env
@ -68,6 +71,8 @@ emptyEnv = Env
, _envTempCounter = 0
, _envTypeEnv = TypeEnv.emptyTypeEnv
, _envTagMap = mempty
, _envStringMap = mempty
, _envStringCounter = 0
}
concat <$> mapM makeLenses [''Env]

111
grin/src/Reducer/LLVM/CodeGen.hs
View File

@ -18,8 +18,14 @@ import qualified Data.Set as Set
import Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.ByteString.Short as ShortByteString
import Data.String (fromString)
import Text.Printf (printf)
import Lens.Micro.Mtl
import LLVM.AST hiding (callingConvention, functionAttributes)
import LLVM.AST.AddrSpace
import LLVM.AST.Type as LLVM
import qualified LLVM.AST.Typed as LLVM
import LLVM.AST.Constant as C hiding (Add, ICmp)
@ -36,6 +42,7 @@ import LLVM.Module
import Control.Monad.Except
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Short as BSShort
import Grin.Grin as Grin
import Grin.Pretty
@ -46,6 +53,8 @@ import Reducer.LLVM.PrimOps
import Reducer.LLVM.TypeGen
import Reducer.LLVM.InferType
debugMode :: Bool
debugMode = True
@ -55,12 +64,25 @@ toLLVM fname mod = withContext $ \ctx -> do
BS.writeFile fname llvm
pure llvm
codeGenLit :: Lit -> C.Constant
codeGenLit :: Lit -> CG C.Constant
codeGenLit = \case
LInt64 v -> Int {integerBits=64, integerValue=fromIntegral v}
LWord64 v -> Int {integerBits=64, integerValue=fromIntegral v}
LFloat v -> C.Float {floatValue=F.Single v}
LBool v -> Int {integerBits=1, integerValue=if v then 1 else 0}
LInt64 v -> pure $ Int {integerBits=64, integerValue=fromIntegral v}
LWord64 v -> pure $ Int {integerBits=64, integerValue=fromIntegral v}
LFloat v -> pure $ C.Float {floatValue=F.Single v}
LBool v -> pure $ Int {integerBits=1, integerValue=if v then 1 else 0}
LChar v -> pure $ Int {integerBits=8, integerValue=fromIntegral $ fromEnum v}
LString v -> C.GlobalReference stringType <$> strName v
strName :: Text.Text -> CG AST.Name
strName str = do
mName <- use $ envStringMap . at str
case mName of
Just n -> pure n
Nothing -> do
counter <- envStringCounter <<%= succ
let n = Name $ fromString $ "str." ++ show counter
envStringMap %= Map.insert str n
pure n
codeGenVal :: Val -> CG Operand
codeGenVal val = case val of
@ -95,7 +117,7 @@ codeGenVal val = case val of
ValTag tag -> ConstantOperand <$> getTagId tag
Unit -> pure unit
Lit lit -> pure . ConstantOperand . codeGenLit $ lit
Lit lit -> ConstantOperand <$> codeGenLit lit
Var name -> do
Map.lookup name <$> gets _constantMap >>= \case
-- QUESTION: what is this?
@ -111,7 +133,7 @@ codeGenVal val = case val of
getCPatConstant :: CPat -> CG Constant
getCPatConstant = \case
TagPat tag -> getTagId tag
LitPat lit -> pure $ codeGenLit lit
LitPat lit -> codeGenLit lit
NodePat tag args -> getTagId tag
DefaultPat -> pure C.TokenNone
@ -122,7 +144,10 @@ getCPatName = \case
LInt64 v -> "int_" <> showTS v
LWord64 v -> "word_" <> showTS v
LBool v -> "bool_" <> showTS v
LChar v -> "char_" <> showTS v
LString v -> error "pattern match on string is not supported"
LFloat v -> error "pattern match on float is not supported"
other -> error $ "pattern match not implemented: " ++ show other
NodePat tag _ -> tagName tag
DefaultPat -> "default"
where
@ -138,7 +163,7 @@ getCPatName = \case
toModule :: Env -> AST.Module
toModule Env{..} = defaultModule
{ moduleName = "basic"
, moduleDefinitions = heapPointerDef : reverse _envDefinitions
, moduleDefinitions = heapPointerDef : (stringDefinitions) ++ (reverse _envDefinitions)
}
where
heapPointerDef = GlobalDefinition globalVariableDefaults
@ -147,6 +172,30 @@ toModule Env{..} = defaultModule
, initializer = Just $ Int 64 0
}
stringDefinitions = concat
[ [ GlobalDefinition globalVariableDefaults
{ name = valAstName
, Global.type' = ArrayType (fromIntegral (length stringVal)) i8
, initializer = Just $ C.Array i8 $ [Int 8 $ fromIntegral $ fromEnum v0 | v0 <- stringVal]
}
, GlobalDefinition globalVariableDefaults
{ name = astName
, Global.type' = stringStructType
, initializer = Just $ C.Struct Nothing False -- TODO: Set struct name
[ C.GetElementPtr
{ inBounds = True
, address = GlobalReference (PointerType (ArrayType (fromIntegral (length stringVal)) i8) (AddrSpace 0)) valAstName
, indices = [Int {integerBits=64, integerValue=0}, Int {integerBits=64, integerValue=0}]
}
, Int 64 $ fromIntegral $ length stringVal
]
}
]
| (stringVal0, astName@(Name astNameBS)) <- Map.toList _envStringMap
, let stringVal = Text.unpack stringVal0
, let valAstName = Name $ BSShort.pack $ (BSShort.unpack astNameBS) ++ (BSShort.unpack ".val") -- Append ShortByteStrings
]
{-
type of:
ok - SApp Name [SimpleVal]
@ -194,12 +243,14 @@ codeGen typeEnv exp = toModule $ flip execState (emptyEnv {_envTypeEnv = typeEnv
SAppF name args -> do
(retType, argTypes) <- getFunctionType name
operands <- mapM codeGenVal args
operandsTypes <- mapM (\x -> toCGType <$> typeOfVal x) args
operandsTypes <- mapM (fmap toCGType . typeOfVal) args
-- convert values to function argument type
convertedArgs <- sequence $ zipWith3 codeGenValueConversion operandsTypes operands argTypes
if isExternalName (externals exp) name
then codeGenPrimOp name args convertedArgs
else do
let findExternalName :: TypeEnv.Name -> Maybe External
findExternalName n = List.find ((n ==) . eName) (externals exp)
case findExternalName name of
Just e -> codeExternal e convertedArgs
Nothing -> do
-- call to top level functions
let functionType = FunctionType
{ resultType = cgLLVMType retType
@ -282,7 +333,8 @@ codeGen typeEnv exp = toModule $ flip execState (emptyEnv {_envTypeEnv = typeEnv
ProgramF exts defs -> do
-- register prim fun lib
registerPrimFunLib
runtimeErrorExternal
mapM registerPrimFunLib exts
sequence_ (map snd defs) >> pure (O unitCGType unit)
SFetchIF name Nothing -> do
@ -353,6 +405,15 @@ codeGenStoreNode val nodeLocation = do
pure $ (unitCGType, unit)
pure ()
convertStringOperand t o = case (cgType t,o) of
(T_SimpleType T_String, ConstantOperand stringRef@(GlobalReference{}))
-> ConstantOperand $ C.GetElementPtr
{ inBounds = False
, address = stringRef
, indices = [Int {integerBits=64, integerValue=0}, Int {integerBits=64, integerValue=0}]
}
_ -> o
codeGenCase :: Operand -> [(Alt, CG Result)] -> (CPat -> CG ()) -> CG Result
codeGenCase opVal alts bindingGen = do
curBlockName <- gets _currentBlockName
@ -435,6 +496,7 @@ codeGenTagSwitch tagVal nodeSet tagAltGen | Map.size nodeSet > 1 = do
activeBlock lastAltBlock
-- HINT: convert alt result to common type
convertedAltOp <- codeGenValueConversion altCGTy altOp resultCGType
closeBlock $ Br
{ dest = switchExit
, metadata' = []
@ -509,10 +571,25 @@ external retty label argtys = modify' (\env@Env{..} -> env {_envDefinitions = de
}
-- available primitive functions
registerPrimFunLib :: CG ()
registerPrimFunLib = do
external VoidType (mkName "_prim_int_print") [(i64, mkName "x")]
registerPrimFunLib :: External -> CG ()
registerPrimFunLib ext = do
external
(toLLVMType $ eRetType ext)
(mkName $ Text.unpack $ unNM $ eName ext)
[ (toLLVMType t, mkName ("x" ++ show n)) | (t,n) <- (eArgsType ext) `zip` [1..] ]
where
toLLVMType = \case
TySimple t -> typeGenSimpleType t
rest -> error $ "Unsupported type:" ++ show rest
runtimeErrorExternal :: CG ()
runtimeErrorExternal =
external
(typeGenSimpleType T_Unit)
(mkName "__runtime_error")
[(typeGenSimpleType T_Int64, mkName "x0")]
errorBlock :: CG ()
errorBlock = do
activeBlock $ mkName "error_block"
let functionType = FunctionType
@ -525,7 +602,7 @@ errorBlock = do
{ tailCallKind = Just Tail
, callingConvention = CC.C
, returnAttributes = []
, function = Right . ConstantOperand $ GlobalReference (ptr functionType) (mkName "_prim_int_print")
, function = Right . ConstantOperand $ GlobalReference (ptr functionType) (mkName "__runtime_error")
, arguments = zip [ConstantOperand $ C.Int 64 666] (repeat [])
, functionAttributes = []
, metadata = []

116
grin/src/Reducer/LLVM/PrimOps.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
module Reducer.LLVM.PrimOps where
import Control.Monad (when)
import LLVM.AST
import qualified LLVM.AST.IntegerPredicate as I
import qualified LLVM.AST.FloatingPointPredicate as F
@ -13,66 +14,89 @@ import qualified Grin.Grin as Grin
import Grin.TypeEnv hiding (function)
import Reducer.LLVM.Base
import Reducer.LLVM.TypeGen
import Grin.PrimOpsPrelude
cgUnit = toCGType $ T_SimpleType T_Unit :: CGType
cgInt64 = toCGType $ T_SimpleType T_Int64 :: CGType
cgWord64 = toCGType $ T_SimpleType T_Word64 :: CGType
cgFloat = toCGType $ T_SimpleType T_Float :: CGType
cgBool = toCGType $ T_SimpleType T_Bool :: CGType
cgString = toCGType $ T_SimpleType T_String :: CGType
cgChar = toCGType $ T_SimpleType T_Char :: CGType
codeGenPrimOp :: Grin.Name -> [Grin.Val] -> [Operand] -> CG Result
codeGenPrimOp name _ [opA, opB] = case name of
codeExternal :: Grin.External -> [Operand] -> CG Result
codeExternal e ops = case Grin.eKind e of
Grin.PrimOp -> codeGenPrimOp (Grin.eName e) ops
Grin.FFI -> codeGenFFI e ops
codeGenPrimOp :: Grin.Name -> [Operand] -> CG Result
codeGenPrimOp name [opA, opB] = pure $ case name of
-- Int
"_prim_int_add" -> pure . I cgInt64 $ Add {nsw=False, nuw=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_sub" -> pure . I cgInt64 $ Sub {nsw=False, nuw=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_mul" -> pure . I cgInt64 $ Mul {nsw=False, nuw=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_div" -> pure . I cgInt64 $ SDiv {exact=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_eq" -> pure . I cgBool $ ICmp {iPredicate=I.EQ, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_ne" -> pure . I cgBool $ ICmp {iPredicate=I.NE, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_gt" -> pure . I cgBool $ ICmp {iPredicate=I.SGT, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_ge" -> pure . I cgBool $ ICmp {iPredicate=I.SGE, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_lt" -> pure . I cgBool $ ICmp {iPredicate=I.SLT, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_le" -> pure . I cgBool $ ICmp {iPredicate=I.SLE, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_add" -> I cgInt64 $ Add {nsw=False, nuw=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_sub" -> I cgInt64 $ Sub {nsw=False, nuw=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_mul" -> I cgInt64 $ Mul {nsw=False, nuw=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_div" -> I cgInt64 $ SDiv {exact=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_ashr" -> I cgInt64 $ AShr {exact=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_eq" -> I cgBool $ ICmp {iPredicate=I.EQ, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_ne" -> I cgBool $ ICmp {iPredicate=I.NE, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_gt" -> I cgBool $ ICmp {iPredicate=I.SGT, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_ge" -> I cgBool $ ICmp {iPredicate=I.SGE, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_lt" -> I cgBool $ ICmp {iPredicate=I.SLT, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_le" -> I cgBool $ ICmp {iPredicate=I.SLE, operand0=opA, operand1=opB, metadata=[]}
-- Word
"_prim_word_add" -> pure . I cgWord64 $ Add {nsw=False, nuw=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_sub" -> pure . I cgWord64 $ Sub {nsw=False, nuw=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_mul" -> pure . I cgWord64 $ Mul {nsw=False, nuw=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_div" -> pure . I cgWord64 $ UDiv {exact=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_eq" -> pure . I cgBool $ ICmp {iPredicate=I.EQ, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_ne" -> pure . I cgBool $ ICmp {iPredicate=I.NE, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_gt" -> pure . I cgBool $ ICmp {iPredicate=I.UGT, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_ge" -> pure . I cgBool $ ICmp {iPredicate=I.UGE, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_lt" -> pure . I cgBool $ ICmp {iPredicate=I.ULT, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_le" -> pure . I cgBool $ ICmp {iPredicate=I.ULE, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_add" -> I cgWord64 $ Add {nsw=False, nuw=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_sub" -> I cgWord64 $ Sub {nsw=False, nuw=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_mul" -> I cgWord64 $ Mul {nsw=False, nuw=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_div" -> I cgWord64 $ UDiv {exact=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_eq" -> I cgBool $ ICmp {iPredicate=I.EQ, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_ne" -> I cgBool $ ICmp {iPredicate=I.NE, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_gt" -> I cgBool $ ICmp {iPredicate=I.UGT, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_ge" -> I cgBool $ ICmp {iPredicate=I.UGE, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_lt" -> I cgBool $ ICmp {iPredicate=I.ULT, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_le" -> I cgBool $ ICmp {iPredicate=I.ULE, operand0=opA, operand1=opB, metadata=[]}
-- Float
"_prim_float_add" -> pure . I cgFloat $ FAdd {fastMathFlags=noFastMathFlags, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_sub" -> pure . I cgFloat $ FSub {fastMathFlags=noFastMathFlags, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_mul" -> pure . I cgFloat $ FMul {fastMathFlags=noFastMathFlags, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_div" -> pure . I cgFloat $ FDiv {fastMathFlags=noFastMathFlags, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_eq" -> pure . I cgBool $ FCmp {fpPredicate=F.OEQ, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_ne" -> pure . I cgBool $ FCmp {fpPredicate=F.ONE, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_gt" -> pure . I cgBool $ FCmp {fpPredicate=F.OGT, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_ge" -> pure . I cgBool $ FCmp {fpPredicate=F.OGE, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_lt" -> pure . I cgBool $ FCmp {fpPredicate=F.OLT, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_le" -> pure . I cgBool $ FCmp {fpPredicate=F.OLE, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_add" -> I cgFloat $ FAdd {fastMathFlags=noFastMathFlags, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_sub" -> I cgFloat $ FSub {fastMathFlags=noFastMathFlags, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_mul" -> I cgFloat $ FMul {fastMathFlags=noFastMathFlags, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_div" -> I cgFloat $ FDiv {fastMathFlags=noFastMathFlags, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_eq" -> I cgBool $ FCmp {fpPredicate=F.OEQ, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_ne" -> I cgBool $ FCmp {fpPredicate=F.ONE, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_gt" -> I cgBool $ FCmp {fpPredicate=F.OGT, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_ge" -> I cgBool $ FCmp {fpPredicate=F.OGE, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_lt" -> I cgBool $ FCmp {fpPredicate=F.OLT, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_le" -> I cgBool $ FCmp {fpPredicate=F.OLE, operand0=opA, operand1=opB, metadata=[]}
-- Bool
"_prim_bool_eq" -> pure . I cgBool $ ICmp {iPredicate=I.EQ, operand0=opA, operand1=opB, metadata=[]}
"_prim_bool_ne" -> pure . I cgBool $ ICmp {iPredicate=I.NE, operand0=opA, operand1=opB, metadata=[]}
"_prim_bool_eq" -> I cgBool $ ICmp {iPredicate=I.EQ, operand0=opA, operand1=opB, metadata=[]}
"_prim_bool_ne" -> I cgBool $ ICmp {iPredicate=I.NE, operand0=opA, operand1=opB, metadata=[]}
codeGenPrimOp "_prim_int_print" _ [opA] = pure . I cgUnit $ Call
{ tailCallKind = Nothing
, callingConvention = CC.C
, returnAttributes = []
, function = Right $ ConstantOperand $ C.GlobalReference (fun void [i64]) (mkName "_prim_int_print")
, arguments = [(opA, [])]
, functionAttributes = []
, metadata = []
_ -> error $ "unknown primop: " ++ show name
codeGenFFI :: Grin.External -> [Operand] -> CG Result
codeGenFFI e ops = do
if (length ops /= length (Grin.eArgsType e))
then error $ "Non saturated function call: " ++ show (e, ops)
else mkFunction (Grin.nameString $ Grin.eName e) (ops `zip` (Grin.eArgsType e)) (Grin.eRetType e)
mkFunction name ops_params_ty ret_ty = pure . I (tyToCGType ret_ty) $ Call
{ tailCallKind = Nothing
, callingConvention = CC.C
, returnAttributes = []
, function = Right $ ConstantOperand $ C.GlobalReference (fun (tyToLLVMType ret_ty) (tyToLLVMType <$> params_ty)) (mkName name)
, arguments = ops `zip` repeat []
, functionAttributes = []
, metadata = []
}
where
ptr ty = PointerType { pointerReferent = ty, pointerAddrSpace = AddrSpace 0}
fun ret args = ptr FunctionType {resultType = ret, argumentTypes = args, isVarArg = False}
codeGenPrimOp name args _ = error $ "unknown primitive operation: " ++ Grin.unpackName name ++ " arguments: " ++ show args
(ops, params_ty) = unzip ops_params_ty
tyToLLVMType t = case t of
Grin.TySimple st -> typeGenSimpleType st
_ -> error $ "Non simple type in: " ++ show (name, t)
tyToCGType t = case t of
Grin.TySimple st -> toCGType (T_SimpleType st)
_ -> error $ "Non simple type in: " ++ show (name, t)
fptr ty = PointerType { pointerReferent = ty, pointerAddrSpace = AddrSpace 0}
fun ret args = fptr FunctionType {resultType = ret, argumentTypes = args, isVarArg = False}

16
grin/src/Reducer/LLVM/TypeGen.hs
View File

@ -7,6 +7,7 @@ import Text.Printf
import Data.Word
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Vector (Vector)
@ -27,16 +28,24 @@ import Grin.Grin as Grin
import Grin.TypeEnv
import Grin.Pretty
-- QUESTION: T_Dead case?
stringStructType :: LLVM.Type
stringStructType = LLVM.StructureType False [ptr i8, i64]
stringType :: LLVM.Type
stringType = ptr stringStructType
typeGenSimpleType :: SimpleType -> LLVM.Type
typeGenSimpleType = \case
T_Int64 -> i64
T_Word64 -> i64
T_Float -> float
T_Bool -> i1
T_String -> stringType
T_Char -> i8
T_Unit -> LLVM.void
T_Location _ -> locationLLVMType
T_UnspecifiedLocation -> locationLLVMType
T_Dead -> error $ "Dead/unused type was given."
locationCGType :: CGType
locationCGType = toCGType $ T_SimpleType $ T_Location []
@ -189,9 +198,8 @@ toCGType t = case t of
getVarType :: Grin.Name -> CG CGType
getVarType name = do
TypeEnv{..} <- gets _envTypeEnv
case Map.lookup name _variable of
Nothing -> error ("unknown variable " ++ unpackName name)
Just ty -> pure $ toCGType ty
pure $ maybe (error ("unknown variable " ++ unpackName name)) toCGType
$ Map.lookup name _variable
getFunctionType :: Grin.Name -> CG (CGType, [CGType])
getFunctionType name = do

17
grin/src/Reducer/PrimOps.hs
View File

@ -14,14 +14,17 @@ import Foreign.C.String
import Reducer.Base
import Data.Bits (shift)
import Data.Char (chr, ord)
import Grin.Grin
import Data.Map.Strict as Map
import Data.String (fromString)
import Data.Functor.Infix ((<$$>))
import Data.Text as Text
import Control.Monad.IO.Class
import Control.Concurrent (threadDelay)
import Data.Bits
import System.IO (hIsEOF, stdin)
import System.IO.Unsafe
@ -29,7 +32,7 @@ C.include "<math.h>"
C.include "<stdio.h>"
-- primitive functions
primLiteralPrint _ _ [RT_Lit (LInt64 a)] = liftIO (print a) >> pure RT_Unit
primLiteralPrint _ _ [RT_Lit (LInt64 a)] = liftIO (putStr $ show a) >> pure RT_Unit
primLiteralPrint _ _ [RT_Lit (LString a)] = liftIO (putStr (Text.unpack a)) >> pure RT_Unit
primLiteralPrint ctx ps x = error $ Prelude.unwords ["primLiteralPrint", ctx, "- invalid arguments:", show ps, " - ", show x]
@ -53,15 +56,17 @@ evalPrimOp name params args = case name of
"_prim_string_tail" -> string_un_op string Text.tail
"_prim_string_len" -> string_un_op int (fromIntegral . Text.length)
"_prim_string_concat" -> string_bin_op string (\t1 t2 -> Text.concat [t1, t2])
"_prim_string_lt" -> string_bin_op bool (<)
"_prim_string_eq" -> string_bin_op bool (==)
"_prim_string_lt" -> string_bin_op int (boolean 0 1 <$$> (<))
"_prim_string_eq" -> string_bin_op int (boolean 0 1 <$$> (==))
"_prim_string_cons" -> string_cons
-- Int
"_prim_int_shr" -> int_un_op int (`shiftR` 1)
"_prim_int_add" -> int_bin_op int (+)
"_prim_int_sub" -> int_bin_op int (-)
"_prim_int_mul" -> int_bin_op int (*)
"_prim_int_div" -> int_bin_op int div
"_prim_int_ashr" -> int_bin_op int (\v h -> shift v ((-1) * fromIntegral h))
"_prim_int_eq" -> int_bin_op bool (==)
"_prim_int_ne" -> int_bin_op bool (/=)
"_prim_int_gt" -> int_bin_op bool (>)
@ -105,6 +110,10 @@ evalPrimOp name params args = case name of
string x = pure . RT_Lit . LString $ x
-- char x = pure . RT_Lit . LChar $ x
int_un_op retTy fn = case args of
[RT_Lit (LInt64 a)] -> retTy $ fn a
_ -> error $ "invalid arguments: " ++ show params ++ " " ++ show args ++ " for " ++ unpackName name
int_bin_op retTy fn = case args of
[RT_Lit (LInt64 a), RT_Lit (LInt64 b)] -> retTy $ fn a b
_ -> error $ "invalid arguments: " ++ show params ++ " " ++ show args ++ " for " ++ unpackName name
@ -172,3 +181,5 @@ evalPrimOp name params args = case name of
primError = case args of
[RT_Lit (LString msg)] -> liftIO (ioError $ userError $ Text.unpack msg) >> pure RT_Unit
_ -> error $ "invalid arguments:" ++ show params ++ " " ++ show args ++ " for " ++ unpackName name
boolean f t x = if x then t else f

5
grin/src/Test/Assertions.hs
View File

@ -11,6 +11,8 @@ import AbstractInterpretation.CreatedBy.Result (ProducerMap,ProducerGraph(..))
import AbstractInterpretation.LiveVariable.Pretty
import AbstractInterpretation.LiveVariable.Result (LVAResult)
import AbstractInterpretation.HeapPointsTo.Result (HPTResult)
import AbstractInterpretation.EffectTracking.Pretty
import AbstractInterpretation.EffectTracking.Result (ETResult)
import Transformations.Names
@ -29,6 +31,9 @@ instance SameAs HPTResult where
instance SameAs LVAResult where
sameAs found expected = (PP found) `shouldBe` (PP expected)
instance SameAs ETResult where
sameAs found expected = (PP found) `shouldBe` (PP expected)
instance SameAs ProducerGraph where
sameAs found expected = (PP found) `shouldBe` (PP expected)

20
grin/src/Test/Check.hs
View File

@ -7,7 +7,6 @@ import Data.Functor.Foldable
import Data.Maybe
import Data.Monoid
import Grin.Grin
import Test.PrimOps
import Data.List as List
import Data.Map.Strict as Map
@ -21,7 +20,6 @@ data Check
| OnlyBasicValuesInCases
| OnlyTagsInAlts
| OnlyUniqueNames
-- | AllowedBindStoreValues
| SimpleExpOnLHS
deriving (Enum, Eq, Show)
@ -60,22 +58,6 @@ boolResult :: Bool -> Result
boolResult = \case
True -> Ok
False -> Failed ""
{-
allowedBindStoreValues :: Exp -> Bool
allowedBindStoreValues = getAll . bindStoreValues (\case
Loc _ -> All True
_ -> All False)
-}
{-
onlyExplicitNodes :: HPTResult -> Exp -> Result
onlyExplicitNodes hpt e = result . Set.toList $ cata (usedNames Set.singleton) e `Set.intersection` varsOfTagNodes hpt
varsOfTagNodes :: HPTResult -> Set Name
varsOfTagNodes = Set.fromList . Map.keys . Map.filter (not . Set.null . Set.filter isNode) . undefined -- envMap
where
isNode (N _) = True
isNode (V _) = False
-}
bindStoreValues :: Monoid m => (Val -> m) -> Exp -> m
bindStoreValues f = para $ \case
@ -130,7 +112,7 @@ nonDefinedNames :: Exp -> [Name]
nonDefinedNames e = Set.toList $ Prelude.foldl Set.difference
(cata (usedNames Set.singleton) e)
[ (cata (definedNames Set.singleton) e)
, Set.fromList $ Map.keys primOps
, Set.fromList $ fmap eName $ externals e
]
storedValues :: Monoid m => (Val -> m) -> ExpF m -> m

59
grin/src/Test/PrimOps.hs
View File

@ -1,59 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Test.PrimOps where
import Data.Map.Strict as Map
import Grin.Grin (Name, unpackName)
data PrimType
= TInt
| TWord
| TFloat
| TBool
| TUnit
deriving (Eq, Show)
checkName :: Name -> b -> b
checkName name = maybe (error $ "primOp is not defined:" ++ unpackName name) (const id) $ Map.lookup name primOps
-- TODO: Record effects
primOps :: Map Name ([PrimType], PrimType)
primOps = Map.fromList $
[ ("_prim_int_print", ([TInt], TUnit)) -- HINT: this primop is adhoc, will be removed
-- Int
, ("_prim_int_add", ([TInt, TInt], TInt))
, ("_prim_int_sub", ([TInt, TInt], TInt))
, ("_prim_int_mul", ([TInt, TInt], TInt))
, ("_prim_int_div", ([TInt, TInt], TInt))
, ("_prim_int_eq", ([TInt, TInt], TBool))
, ("_prim_int_ne", ([TInt, TInt], TBool))
, ("_prim_int_gt", ([TInt, TInt], TBool))
, ("_prim_int_ge", ([TInt, TInt], TBool))
, ("_prim_int_lt", ([TInt, TInt], TBool))
, ("_prim_int_le", ([TInt, TInt], TBool))
-- Word
, ("_prim_word_add", ([TWord, TWord], TWord))
, ("_prim_word_sub", ([TWord, TWord], TWord))
, ("_prim_word_mul", ([TWord, TWord], TWord))
, ("_prim_word_div", ([TWord, TWord], TWord))
, ("_prim_word_eq", ([TWord, TWord], TBool))
, ("_prim_word_ne", ([TWord, TWord], TBool))
, ("_prim_word_gt", ([TWord, TWord], TBool))
, ("_prim_word_ge", ([TWord, TWord], TBool))
, ("_prim_word_lt", ([TWord, TWord], TBool))
, ("_prim_word_le", ([TWord, TWord], TBool))
-- Float
, ("_prim_float_add", ([TFloat, TFloat], TFloat))
, ("_prim_float_sub", ([TFloat, TFloat], TFloat))
, ("_prim_float_mul", ([TFloat, TFloat], TFloat))
, ("_prim_float_div", ([TFloat, TFloat], TFloat))
, ("_prim_float_eq", ([TFloat, TFloat], TBool))
, ("_prim_float_ne", ([TFloat, TFloat], TBool))
, ("_prim_float_gt", ([TFloat, TFloat], TBool))
, ("_prim_float_ge", ([TFloat, TFloat], TBool))
, ("_prim_float_lt", ([TFloat, TFloat], TBool))
, ("_prim_float_le", ([TFloat, TFloat], TBool))
-- Bool
, ("_prim_bool_eq", ([TBool, TBool], TBool))
, ("_prim_bool_ne", ([TBool, TBool], TBool))
]

38
grin/src/Test/Test.hs
View File

@ -27,7 +27,8 @@ import GHC.Generics
import Grin.Grin hiding (Def)
import qualified Grin.Grin as Grin
import qualified Grin.TypeEnvDefs as Grin
import qualified Test.PrimOps as PrimOps
import qualified Grin.PrimOpsPrelude as PrimOps'
-- import qualified Test.PrimOps as PrimOps
import Test.QuickCheck
import Test.QuickCheck.Instances.Vector
import Generic.Random
@ -329,6 +330,7 @@ getSExpTypeInEff = \case
instance Arbitrary Eff where arbitrary = genericArbitraryU
-- TODO: Remove
data Type
= TUnit -- TODO: Rename
| TInt
@ -454,13 +456,47 @@ type GoalM a = ReaderT Context (LogicT Gen) a
initContext :: GoalM G.Exp -> Context
initContext expGen = Context (Env mempty primitives mempty) mempty expGen
where
primitives = Map.fromList [ (eName p, (tyToType <$> eArgsType p, tyToType $ eRetType p, [])) | p <- preludePurePrimOps ]
tyToType = \case
TySimple ty -> case ty of
T_Int64 -> TInt
T_Word64 -> TWord
T_Float -> TFloat
T_Bool -> TBool
T_Unit -> TUnit
T_String -> TString
T_Char -> TChar
ty -> error $ "Unsupported type when testing: " ++ show ty
{-
= TUnit -- TODO: Rename
| TInt
| TFloat
| TBool
| TWord
| TLoc Type
| TTag Name [Type] -- Only constant tags, only simple types, or variables with location info
| TUnion (Set Type)
| TString
| TChar
= External
{ eName :: Name
, eRetType :: Ty
, eArgsType :: [Ty]
, eEffectful :: Bool
}
primitives = Map.map (\(params, ret) -> (convPrimTypes <$> params, convPrimTypes ret, [])) PrimOps.primOps
primitives = primPrelude
convPrimTypes = \case
PrimOps.TInt -> TInt
PrimOps.TWord -> TWord
PrimOps.TFloat -> TFloat
PrimOps.TBool -> TBool
PrimOps.TUnit -> TUnit
-}
runGoalM :: GoalM G.Exp -> GoalM a -> Gen [a]
runGoalM expGen = observeManyT 1 . flip runReaderT (initContext expGen)

8
grin/src/Transformations/EffectMap.hs
View File

@ -23,7 +23,13 @@ import Transformations.Util
effectMap :: (TypeEnv, Exp) -> EffectMap
effectMap (te, e) = EffectMap $ effectfulFunctions $ unMMap $ snd $ para buildEffectMap e where
effectMap (te, e) = EffectMap $ withEffectfulExternals $ effectfulFunctions $ unMMap $ snd $ para buildEffectMap e where
withEffectfulExternals :: Map Name Effects -> Map Name Effects
withEffectfulExternals
| Program exts _ <- e
= Map.union $ Map.fromSet (\ext -> Effects (Set.singleton ext) mempty mempty) effectfulExternals
| otherwise = id
effectfulExternals :: Set Name
effectfulExternals = case e of

4
grin/src/Transformations/Names.hs
View File

@ -46,9 +46,13 @@ deriveNewName name = do
boolTF :: a -> a -> Bool -> a
boolTF true false x = if x then true else false
--TODO: this should be put into a Piple.Definitions module
data ExpChanges
= NoChange
| NewNames
-- only relevant heap operations
-- (e.g.: deleting a dead case alternative should not trigger this)
| DeletedHeapOperation
deriving (Eq, Show)
evalNameM :: Exp -> NameM a -> (a, ExpChanges)

7
grin/src/Transformations/Optimising/CSE.hs
View File

@ -12,6 +12,8 @@ import Grin.TypeEnv
import Grin.EffectMap
import Transformations.Util
import Debug.Trace
type Env = (Map SimpleExp SimpleExp)
-- TODO: track if function parameters with location type can be updated in the called function to improve CSE
@ -27,7 +29,10 @@ commonSubExpressionElimination typeEnv effMap e = hylo skipUnit builder (mempty,
SUpdate name val -> Map.insert (SFetch name) (SReturn val) env
SStore val | Var name <- lpat -> Map.insert (SFetch name) (SReturn val) extEnvKeepOld
-- HINT: location parameters might be updated in the called function, so forget their content
SApp defName args -> foldr Map.delete (if hasTrueSideEffect defName effMap then env else extEnvKeepOld) [SFetch name | Var name <- args, isLocation name]
SApp defName args -> foldr
Map.delete
(if (hasTrueSideEffect defName effMap) then env else extEnvKeepOld)
[SFetch name | Var name <- args, isLocation name]
SReturn val | isConstant val -> extEnvKeepOld
SFetch{} -> extEnvKeepOld
_ -> env

7
grin/src/Transformations/Optimising/CopyPropagation.hs
View File

@ -1,10 +1,13 @@
{-# LANGUAGE LambdaCase, TupleSections, ViewPatterns #-}
module Transformations.Optimising.CopyPropagation where
import Text.Printf
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Functor.Foldable as Foldable
import Text.Printf
import Lens.Micro.Extra
import Grin.Grin
import Transformations.Util
@ -53,7 +56,7 @@ copyPropagation e = hylo folder builder (mempty, e) where
folder :: ExpF Exp -> Exp
folder = \case
-- right unit law
EBindF leftExp lpat (SReturn val) | val == lpat -> leftExp
EBindF leftExp lpat (SReturn val) | val == lpat, isn't _ValVar lpat -> leftExp
-- left unit law ; cleanup matching constants
EBindF (SReturn val) lpat rightExp

2
grin/src/Transformations/Optimising/DeadDataElimination.hs
View File

@ -67,7 +67,7 @@ deadDataElimination lvaResult cbyResult tyEnv e = execTrf e $
lookupNodeLivenessM :: Name -> Tag -> LVAResult -> Trf (Vector Bool)
lookupNodeLivenessM v t lvaResult = do
lvInfo <- lookupExcept (noLiveness v) v . _register $ lvaResult
lvInfo <- lookupExcept (noLiveness v) v . _registerLv $ lvaResult
case lvInfo of
NodeSet taggedLiveness ->
_fields <$> lookupExcept (noLivenessTag v t) t taggedLiveness

48
grin/src/Transformations/Optimising/DeadFunctionElimination.hs
View File

@ -26,7 +26,6 @@ import Control.Monad.Trans.Except
import Grin.Grin
import Grin.Pretty
import Grin.TypeEnv
import Grin.EffectMap
import Transformations.Util
import AbstractInterpretation.LiveVariable.Result as LVA
@ -36,42 +35,49 @@ type Trf = Except String
runTrf :: Trf a -> Either String a
runTrf = runExcept
deadFunctionElimination :: LVAResult -> EffectMap -> TypeEnv -> Exp -> Either String Exp
deadFunctionElimination lvaResult effMap tyEnv = runTrf .
(deleteDeadFunctions lvaResult effMap >=> replaceDeadFunApps lvaResult effMap tyEnv)
deadFunctionElimination :: LVAResult -> TypeEnv -> Exp -> Either String Exp
deadFunctionElimination lvaResult tyEnv = runTrf .
(deleteDeadFunctions lvaResult >=> replaceDeadFunApps lvaResult tyEnv)
deleteDeadFunctions :: LVAResult -> EffectMap -> Exp -> Trf Exp
deleteDeadFunctions lvaResult effMap (Program exts defs) =
deleteDeadFunctions :: LVAResult -> Exp -> Trf Exp
deleteDeadFunctions lvaResult (Program exts defs) =
fmap (Program exts) $ filterM isFunDefLiveM defs where
isFunDefLiveM :: Exp -> Trf Bool
isFunDefLiveM (Def f _ _) = fmap not $ isFunDeadM lvaResult effMap f
isFunDefLiveM (Def f _ _) = fmap not $ isRemovableM lvaResult f
isFunDefLiveM e = throwE $ "DFE: " ++ show (PP e) ++ " is not a function definition"
replaceDeadFunApps :: LVAResult -> EffectMap -> TypeEnv -> Exp -> Trf Exp
replaceDeadFunApps lvaResult effMap tyEnv = cataM alg where
replaceDeadFunApps :: LVAResult -> TypeEnv -> Exp -> Trf Exp
replaceDeadFunApps lvaResult tyEnv = cataM alg where
alg :: ExpF Exp -> Trf Exp
alg = replaceAppWithUndefined lvaResult effMap tyEnv . embed
alg = replaceAppWithUndefined lvaResult tyEnv . embed
replaceAppWithUndefined :: LVAResult -> EffectMap -> TypeEnv -> Exp -> Trf Exp
replaceAppWithUndefined lvaResult effMap TypeEnv{..} app@(SApp f _) = do
funIsDead <- isFunDeadM lvaResult effMap f
if funIsDead then do
replaceAppWithUndefined :: LVAResult -> TypeEnv -> Exp -> Trf Exp
replaceAppWithUndefined lvaResult TypeEnv{..} app@(SApp f _) = do
isRemovable <- isRemovableM lvaResult f
if isRemovable then do
(retTy,_) <- lookupExcept (notFoundInTyEnv f) f _function
pure $ SReturn $ Undefined (simplifyType retTy)
else
pure app
where notFoundInTyEnv f = "DFE: Function " ++ show (PP f) ++ " not found in type env"
replaceAppWithUndefined _ _ _ e = pure e
replaceAppWithUndefined _ _ e = pure e
isRemovableM :: LVAResult -> Name -> Trf Bool
isRemovableM lvaResult f = (&&) <$> isFunDeadM lvaResult f
<*> hasNoSideEffectsM lvaResult f
isFunDeadM :: LVAResult -> EffectMap -> Name -> Trf Bool
isFunDeadM LVAResult{..} effMap f = fmap andHasNoSideEffect
. fmap isFunDead
hasNoSideEffectsM :: LVAResult -> Name -> Trf Bool
hasNoSideEffectsM LVAResult{..} f = fmap (not . _hasEffect)
. lookupExcept (noLiveness f) f
$ _function
where andHasNoSideEffect = (&&) (not $ hasTrueSideEffect f effMap)
$ _functionEff
noLiveness f = "DFE: Function " ++ show (PP f) ++ " not found in liveness map"
isFunDeadM :: LVAResult -> Name -> Trf Bool
isFunDeadM LVAResult{..} f = fmap isFunDead
. lookupExcept (noLiveness f) f
$ _functionLv
noEffect f = "DFE: Function " ++ show (PP f) ++ " not found in effect map"
noLiveness f = "DFE: Function " ++ show (PP f) ++ " not found in liveness map"

2
grin/src/Transformations/Optimising/DeadParameterElimination.hs
View File

@ -49,5 +49,5 @@ deadParameterElimination lvaResult tyEnv = runTrf . cataM alg where
lookupArgLivenessM :: Name -> LVAResult -> Trf (Vector Bool)
lookupArgLivenessM f LVAResult{..} = do
let funNotFound = "Function " ++ show f ++ " was not found in liveness analysis result"
(_,argLv) <- lookupExcept funNotFound f _function
(_,argLv) <- lookupExcept funNotFound f _functionLv
return $ Vec.map isLive argLv

59
grin/src/Transformations/Optimising/DeadVariableElimination.hs
View File

@ -12,11 +12,13 @@ import qualified Data.Vector as Vec
import Data.List
import Data.Maybe
import Data.Monoid
import qualified Data.Set.Extra as Set
import qualified Data.Foldable
import Data.Functor.Foldable as Foldable
import Lens.Micro
import Lens.Micro.Extra
import Lens.Micro.Platform
import Control.Monad.Extra
@ -26,10 +28,10 @@ import Control.Monad.Trans.Except
import Grin.Grin
import Grin.Pretty
import Grin.TypeEnv
import Grin.EffectMap
import Transformations.Util
import AbstractInterpretation.LiveVariable.Result as LVA
-- TODO: clean up `analyzeCases` and the other remnants of the EffectMap
data DeletedEntities = DeletedEntities
{ _deVariables :: Set Name
@ -51,17 +53,21 @@ runTrf :: Trf a -> Either String a
runTrf = flip evalState mempty . runExceptT
-- P and F nodes are handled by Dead Data Elimination
deadVariableElimination :: LVAResult -> EffectMap -> TypeEnv -> Exp -> Either String Exp
deadVariableElimination lvaResult effMap tyEnv
= runTrf . (deleteDeadBindings lvaResult effMap tyEnv >=> replaceDeletedVars tyEnv)
deadVariableElimination :: LVAResult -> TypeEnv -> Exp -> Either String Exp
deadVariableElimination lvaResult tyEnv exp =
runTrf . (deleteDeadBindings lvaResult tyEnv >=> replaceDeletedVars tyEnv) $ exp
{- NOTE: Fetches do not have to be handled separately,
since producer name introduction guarantees
that all bindings with a fetch LHS will have a Var PAT
(handled by the last case in alg).
Side effects are only incorporated into the liveness analysis
if `EffectTracking` was run before LVA.
Otherwise all computations are considered pure.
-}
deleteDeadBindings :: LVAResult -> EffectMap -> TypeEnv -> Exp -> Trf Exp
deleteDeadBindings lvaResult effMap tyEnv = cataM alg where
deleteDeadBindings :: LVAResult -> TypeEnv -> Exp -> Trf Exp
deleteDeadBindings lvaResult tyEnv p@(Program exts _) = cataM alg p where
alg :: ExpF Exp -> Trf Exp
alg = \case
e@(EBindF SStore{} (Var p) rhs)
@ -69,17 +75,22 @@ deleteDeadBindings lvaResult effMap tyEnv = cataM alg where
unless (isSingleton locs) (throwE $ multipleLocs p locs)
pointerDead <- isVarDeadM p
rmWhen pointerDead e rhs (Set.singleton p) (Set.fromList locs)
e@(EBindF (SApp f _) lpat rhs) -> do
let names = foldNamesVal Set.singleton lpat
hasNoSideEffect = not $ hasTrueSideEffect f effMap
funDead <- isFunDeadM f
rmWhen (funDead && hasNoSideEffect) e rhs names mempty
e@(EBindF (SApp f _) (Var v) rhs) | f `notElem` (map eName exts) -> do
{- NOTE: A live arg could mean there is an update inside the function.
Deleting this update usually has no effect on the code, but it is
not proven, that it will always keep the semantics.
-}
noLiveArgs <- noLiveArgsM f
varDead <- isVarDeadM v
bindingHasNoEffect <- varHasNoSideEffectsM v
rmWhen (noLiveArgs && varDead && bindingHasNoEffect) e rhs (Set.singleton v) mempty
e@(EBindF (SUpdate p v) Unit rhs) -> do
varDead <- isVarDeadM p
rmWhen varDead e rhs mempty mempty
e@(EBindF _ (Var v) rhs) -> do
varDead <- isVarDeadM v
rmWhen varDead e rhs (Set.singleton v) mempty
bindingHasNoEffect <- varHasNoSideEffectsM v
rmWhen (varDead && bindingHasNoEffect) e rhs (Set.singleton v) mempty
e -> pure . embed $ e
rmWhenAllDead :: ExpF Exp -> Exp -> Val -> Trf Exp
@ -95,18 +106,25 @@ deleteDeadBindings lvaResult effMap tyEnv = cataM alg where
pure modified
| otherwise = pure . embed $ orig
varHasNoSideEffectsM :: Name -> Trf Bool
varHasNoSideEffectsM v = fmap (not . _hasEffect)
. lookupExcept (varEffNotFound v) v
. LVA._registerEff
$ lvaResult
isVarDeadM :: Name -> Trf Bool
isVarDeadM v = fmap (not . isLive)
. lookupExcept (varLvNotFound v) v
. _register
$ lvaResult
isFunDeadM :: Name -> Trf Bool
isFunDeadM f = fmap isFunDead
. lookupExcept (funLvNotFound f) f
. LVA._function
. lookupExcept (varLvNotFound v) v
. LVA._registerLv
$ lvaResult
noLiveArgsM :: Name -> Trf Bool
noLiveArgsM f = fmap (not . hasLiveArgs)
. lookupExcept (funLvNotFound f) f
. LVA._functionLv
$ lvaResult
varEffNotFound v = "DVE: Variable " ++ show (PP v) ++ " was not found in effect map"
varLvNotFound v = "DVE: Variable " ++ show (PP v) ++ " was not found in liveness map"
funLvNotFound f = "DVE: Function " ++ show (PP f) ++ " was not found in liveness map"
@ -120,7 +138,6 @@ deleteDeadBindings lvaResult effMap tyEnv = cataM alg where
++ "but " ++ show (PP p) ++ " points to multiple locations: "
++ show (PP locs)
-- This will not replace the occurences of a deleted pointer
-- in fetches and in updates. But it does not matter,
-- since all of these fetches/updates are also dead, so they will be removed as well.

9
grin/src/Transformations/Optimising/NonSharedElimination.hs
View File

@ -12,12 +12,17 @@ import qualified Data.Set as Set
import Grin.Grin
import Grin.TypeEnv
import Transformations.Names (ExpChanges(..))
import AbstractInterpretation.Sharing.Result
nonSharedElimination :: SharingResult -> TypeEnv -> Exp -> Exp
nonSharedElimination SharingResult{..} te = cata skipUpdate where
nonSharedElimination :: SharingResult -> TypeEnv -> Exp -> (Exp, ExpChanges)
nonSharedElimination SharingResult{..} te exp = (exp', change) where
exp' = cata skipUpdate exp
change = if exp' /= exp then DeletedHeapOperation else NoChange
-- Remove bind when the parameter points to non-shared locations only.
skipUpdate :: ExpF Exp -> Exp

19
grin/src/Transformations/Optimising/SimpleDeadFunctionElimination.hs
View File

@ -11,15 +11,21 @@ import qualified Data.Foldable
import Grin.Grin
simpleDeadFunctionElimination :: Program -> Program
simpleDeadFunctionElimination exp@(Program exts defs) = Program exts [def | def@(Def name _ _) <- defs, Set.member name liveDefs] where
simpleDeadFunctionElimination (Program exts defs) = Program liveExts liveDefs where
liveExts = [ext | ext <- exts, Set.member (eName ext) liveNames]
liveDefs = [def | def@(Def name _ _) <- defs, Set.member name liveSet]
liveNames = cata collectAll $ Program [] liveDefs -- collect all live names
defMap :: Map Name Def
defMap = Map.fromList [(name, def) | def@(Def name _ _) <- defs]
lookupDef :: Name -> Maybe Def
lookupDef name = Map.lookup name defMap
liveDefs :: Set Name
liveDefs = fst $ until (\(live, visited) -> live == visited) visit (Set.singleton "grinMain", mempty)
liveSet :: Set Name
liveSet = fst $ until (\(live, visited) -> live == visited) visit (Set.singleton "grinMain", mempty)
visit :: (Set Name, Set Name) -> (Set Name, Set Name)
visit (live, visited) = (mappend live seen, mappend visited toVisit) where
@ -28,5 +34,10 @@ simpleDeadFunctionElimination exp@(Program exts defs) = Program exts [def | def@
collect :: ExpF (Set Name) -> Set Name
collect = \case
SAppF name _ | not (isExternalName exts name) -> Set.singleton name
SAppF name _ | Map.member name defMap -> Set.singleton name
exp -> Data.Foldable.fold exp
collectAll :: ExpF (Set Name) -> Set Name
collectAll = \case
SAppF name args -> Set.singleton name
exp -> Data.Foldable.fold exp

2
grin/src/Transformations/Optimising/SimpleDeadVariableElimination.hs
View File

@ -18,6 +18,8 @@ import Lens.Micro.Platform
-- TODO: Write for dead code elimination.???
-- TODO: Remove TypeEnv, consult EffectMap for side-effects, dont rely on unit return type
-- QUESTION: should SDVE use any interprocedural information?
simpleDeadVariableElimination :: TypeEnv -> EffectMap -> Exp -> Exp
simpleDeadVariableElimination typeEnv effMap e = cata folder e ^. _1 where

34
grin/src/Transformations/Simplifying/BindingPatternSimplification.hs Normal file
View File

@ -0,0 +1,34 @@
{-# LANGUAGE LambdaCase, OverloadedStrings #-}
module Transformations.Simplifying.BindingPatternSimplification where
import Control.Monad
import Data.Functor.Foldable as Foldable
import Grin.Grin
import Transformations.Util
import Transformations.Names
import Lens.Micro.Extra
newNodeName :: NameM Name
newNodeName = deriveNewName "p"
-- NOTE: This transformation can invalidate the "no left bind" invariant,
-- so we have to normalize these incorrect bindings after this transformation.
bindingPatternSimplification :: Exp -> (Exp, ExpChanges)
bindingPatternSimplification e = evalNameM e . cataM alg $ e where
alg :: ExpF Exp -> NameM Exp
alg = \case
-- NOTE: binding to Unit?
EBindF lhs pat rhs | isn't _ValVar pat -> do
newVar <- fmap Var newNodeName
pure $ EBind lhs newVar (EBind (SReturn newVar) pat rhs)
ECaseF scrut alts | isn't _ValVar scrut -> do
newVar <- fmap Var newNodeName
pure $ SBlock $ EBind (SReturn scrut) newVar (ECase newVar alts)
expf -> pure . embed $ expf

12
grin/src/Transformations/Simplifying/ProducerNameIntroduction.hs
View File

@ -8,10 +8,6 @@ import Data.Functor.Foldable as Foldable
import Grin.Grin
import Transformations.Names
-- TODO: remove this
import Grin.Parse
import Grin.Pretty
import Transformations.BindNormalisation
newNodeName :: NameM Name
newNodeName = deriveNewName "v"
@ -37,8 +33,6 @@ producerNameIntroduction e = evalNameM e . cata alg $ e where
SReturnF x@VarTagNode{} -> bindVal SReturn x
SReturnF x@ConstTagNode{} -> bindVal SReturn x
SReturnF x@Undefined{} -> bindVal SReturn x
-- This is not a producer, but helps in the propagation of producer info (makes DDE simpler)
SFetchF p -> bindFetch p
expf -> fmap embed . sequence $ expf
-- binds a Val (usually a node) to a name, then puts it into some context
@ -46,9 +40,3 @@ producerNameIntroduction e = evalNameM e . cata alg $ e where
bindVal context val = do
nodeVar <- fmap Var newNodeName
return $ SBlock $ EBind (SReturn val) nodeVar (context nodeVar)
-- bind the lhs of a fetch-binding to a variable
bindFetch :: Name -> NameM Exp
bindFetch p = do
fetchResult <- fmap Var newNodeName
return $ SBlock $ EBind (SFetch p) fetchResult (SReturn fetchResult)

1
grin/test-data/.gitignore vendored Normal file
View File

@ -0,0 +1 @@
experimental/

0
grin/test-data/dead-data-elimination/length_before.grin → grin/test-data/dead-data-elimination/length.grin
View File

0
grin/test-data/dead-data-elimination/length_after.grin → grin/test-data/dead-data-elimination/length.grin.expected
View File

50
grin/test-data/dead-data-elimination/length2.grin Normal file
View File

@ -0,0 +1,50 @@
grinMain = n1 <- pure (CInt 1)
t1 <- store n1
n2 <- pure (CInt 10000)
t2 <- store n2
n3 <- pure (Fupto t1 t2)
t3 <- store n3
n4 <- pure (Flength t3)
t4 <- store n4
n5 <- eval t4
(CInt r') <- pure n5
_prim_int_print r'
upto m n = n6 <- eval m
(CInt m') <- pure n6
n7 <- eval n
(CInt n') <- pure n7
b' <- _prim_int_gt m' n'
if b' then
n8 <- pure (CNil)
pure n8
else
m1' <- _prim_int_add m' 1
n9 <- pure (CInt m1')
m1 <- store n9
n10 <- pure (Fupto m1 n)
p <- store n10
n11 <- pure (CCons m p)
pure n11
length l = l2 <- eval l
case l2 of
(CNil) -> n12 <- pure (CInt 0)
pure n12
(CCons x xs) -> n13 <- length xs
(CInt l') <- pure n13
len <- _prim_int_add l' 1
n14 <- pure (CInt len)
pure n14
eval q = v <- fetch q
case v of
(CInt x'1) -> pure v
(CNil) -> pure v
(CCons y ys) -> pure v
(Fupto a b) -> w <- upto a b
update q w
pure w
(Flength c) -> z <- length c
update q z
pure z

0
grin/test-data/dead-data-elimination/pnode_before.grin → grin/test-data/dead-data-elimination/pnode.grin
View File

0
grin/test-data/dead-data-elimination/pnode_after.grin → grin/test-data/dead-data-elimination/pnode.grin.expected
View File

0
grin/test-data/dead-parameter-elimination/pnode_before.grin → grin/test-data/dead-parameter-elimination/pnode.grin
View File

52
grin/test-data/dead-parameter-elimination/pnode_after.grin → grin/test-data/dead-parameter-elimination/pnode.grin.expected
View File

@ -1,3 +1,4 @@
grinMain =
a0 <- pure (CInt 5)
a1 <- pure (CInt 5)
@ -5,34 +6,27 @@ grinMain =
p0 <- store a0
p1 <- store a1
p2 <- store a2
foo3 <- pure (P3foo)
pfoo3 <- store foo3
foo3ap <- pure (Fap pfoo3 p0)
foo3ap <- pure (Fap pfoo3 p0)
pfoo3ap <- store foo3ap
foo2 <- eval pfoo3ap
pfoo2 <- store foo2
foo2ap <- pure (Fap pfoo2 p1)
foo2 <- eval $ pfoo3ap
pfoo2 <- store foo2
foo2ap <- pure (Fap pfoo2 p1)
pfoo2ap <- store foo2ap
foo1 <- eval pfoo2ap
pfoo1 <- store foo1
foo1ap <- pure (Fap pfoo1 p2)
foo1 <- eval $ pfoo2ap
pfoo1 <- store foo1
foo1ap <- pure (Fap pfoo1 p2)
pfoo1ap <- store foo1ap
fooRet <- eval pfoo1ap
fooRet <- eval $ pfoo1ap
pure fooRet
foo y0 =
z0 <- pure (#undefined :: #ptr)
x0 <- pure (#undefined :: #ptr)
y0' <- eval y0
y0' <- eval $ y0
pure y0'
-- apply always gets the function node in whnf
apply pf cur =
case pf of
(P3foo) ->
@ -42,31 +36,33 @@ apply pf cur =
n1 <- pure (P1foo v0 cur)
pure n1
(P1foo v1 v2) ->
n2 <- foo v2
n2 <- foo $ v2
pure n2
ap f x =
f' <- eval f
apply f' x
f' <- eval $ f
apply $ f' x
eval p =
v <- fetch p
case v of
(CInt n) -> pure v
(P3foo) -> pure v
(P2foo v3) -> pure v
(P1foo v4 v5) -> pure v
(CInt n) ->
pure v
(P3foo) ->
pure v
(P2foo v3) ->
pure v
(P1foo v4 v5) ->
pure v
(Ffoo b0 b1 b2) ->
w0 <- foo b1
w0 <- foo $ b1
update p w0
pure w0
(Fapply g y) ->
w1 <- apply g y
w1 <- apply $ g y
update p w1
pure w1
(Fap h z) ->
w2 <- ap h z
w2 <- ap $ h z
update p w2
pure w2

5
grin/test-data/dead-parameter-elimination/pnode.grin.opts Normal file
View File

@ -0,0 +1,5 @@
outputExtension: "out"
grinOptions:
- "--quiet"
- "--dpe"
- "--save-grin=$$$OUT$$$"

BIN
grin/test-data/sum-simple/sum_simple.binary Normal file
View File

Binary file not shown.

37
grin/test-data/sum-simple/sum_simple_exp.grin Normal file
View File

@ -0,0 +1,37 @@
grinMain = t1 <- store (CInt 1)
t2 <- store (CInt 10000)
t3 <- store (Fupto t1 t2)
t4 <- store (Fsum t3)
(CInt r') <- eval t4
_prim_int_print r'
upto m n = (CInt m') <- eval m
(CInt n') <- eval n
b' <- _prim_int_gt m' n'
if b' then
pure (CNil)
else
m1' <- _prim_int_add m' 1
m1 <- store (CInt m1')
p <- store (Fupto m1 n)
pure (CCons m p)
sum l = l2 <- eval l
case l2 of
(CNil) -> pure (CInt 0)
(CCons x xs) -> (CInt x') <- eval x
(CInt s') <- sum xs
ax' <- _prim_int_add x' s'
pure (CInt ax')
eval q = v <- fetch q
case v of
(CInt x'1) -> pure (CInt x'1)
(CNil) -> pure (CNil)
(CCons y ys) -> pure (CCons y ys)
(Fupto a b) -> w <- upto a b
update q w
pure w
(Fsum c) -> z <- sum c
update q z
pure z

24
grin/test-data/sum-simple/sum_simple_exp.grin.expected Normal file
View File

@ -0,0 +1,24 @@
.text
.file "<string>"
.globl grinMain # -- Begin function grinMain
.p2align 4, 0x90
.type grinMain,@function
grinMain: # @grinMain
.cfi_startproc
# %bb.0: # %grinMain.entry
movl $50005000, %edi # imm = 0x2FB0408
jmp _prim_int_print # TAILCALL
.Lfunc_end0:
.size grinMain, .Lfunc_end0-grinMain
.cfi_endproc
# -- End function
.type _heap_ptr_,@object # @_heap_ptr_
.bss
.globl _heap_ptr_
.p2align 3
_heap_ptr_:
.quad 0 # 0x0
.size _heap_ptr_, 8
.section ".note.GNU-stack","",@progbits

6
grin/test-data/sum-simple/sum_simple_exp.grin.opts Normal file
View File

@ -0,0 +1,6 @@
outputExtension: "out.s"
grinOptions:
- "--optimize"
- "--hpt"
- "--quiet"
- "--save-llvm=$$$OUT$$$"

22
grin/test-runtime/runtime.c Normal file
View File

@ -0,0 +1,22 @@
#include <stdio.h>
#include <stdlib.h>
#include <inttypes.h>
/*
TODO: Add statistics.
*/
extern int64_t _heap_ptr_;
int64_t grinMain();
void __runtime_error(int64_t c){
exit(c);
}
int main() {
int64_t* heap = malloc(100*1024*1024);
_heap_ptr_ = (int64_t)heap;
grinMain();
free(heap);
return 0;
}

336
grin/test/AbstractInterpretation/EffectTrackingSpec.hs Normal file
View File

@ -0,0 +1,336 @@
{-# LANGUAGE OverloadedLists, OverloadedStrings, QuasiQuotes #-}
module AbstractInterpretation.EffectTrackingSpec where
import Data.Map (Map)
import Grin.TH
import Grin.Grin
import Grin.PrimOpsPrelude
import Test.Hspec
import Test.Assertions
import AbstractInterpretation.Reduce (AbstractInterpretationResult(..),evalAbstractProgram)
import AbstractInterpretation.EffectTracking.CodeGen hiding (live)
import AbstractInterpretation.EffectTracking.Result
runTests :: IO ()
runTests = hspec spec
calcEffects :: Exp -> ETResult
calcEffects prog
| (etProgram, etMapping) <- codeGen (withPrimPrelude prog)
, computer <- _airComp . evalAbstractProgram $ etProgram
= toETResult etMapping computer
calcEffectsWithoutPrimopsPrelude :: Exp -> ETResult
calcEffectsWithoutPrimopsPrelude prog
| (etProgram, etMapping) <- codeGen prog
, computer <- _airComp . evalAbstractProgram $ etProgram
= toETResult etMapping computer
spec :: Spec
spec = describe "Effect Tracking Analysis" $ do
it "simple_print" $ do
let exp = [prog|
grinMain =
_prim_int_print 0
|]
let expected = mempty
{ _register = []
, _function = [ ("grinMain", Effects ["_prim_int_print"]) ]
}
calculated = (calcEffects exp) { _external = mempty }
calculated `sameAs` expected
it "bound_print" $ do
let exp = [prog|
grinMain =
x <- _prim_int_print 0
pure x
|]
let expected = mempty
{ _register = [ ("x", Effects ["_prim_int_print"]) ]
, _function = [ ("grinMain", Effects ["_prim_int_print"]) ]
}
calculated = (calcEffects exp) { _external = mempty }
calculated `sameAs` expected
it "fun_print" $ do
let exp = [prog|
grinMain = f 0
f x = _prim_int_print x
|]
let expected = mempty
{ _register = []
, _function = [ ("f", Effects ["_prim_int_print"])
, ("grinMain", Effects ["_prim_int_print"])
]
}
calculated = (calcEffects exp) { _external = mempty }
calculated `sameAs` expected
it "bound_fun_print" $ do
let exp = [prog|
grinMain =
y <- f 0
pure y
f x = _prim_int_print x
|]
let expected = mempty
{ _register = [ ("y", Effects ["_prim_int_print"]) ]
, _function = [ ("f", Effects ["_prim_int_print"])
, ("grinMain", Effects ["_prim_int_print"])
]
}
calculated = (calcEffects exp) { _external = mempty }
calculated `sameAs` expected
it "bound_in_fun_print" $ do
let exp = [prog|
grinMain =
z <- f 0
pure z
f x =
y <- _prim_int_print x
pure y
|]
let expected = mempty
{ _register = [ ("y", Effects ["_prim_int_print"])
, ("z", Effects ["_prim_int_print"])
]
, _function = [ ("f", Effects ["_prim_int_print"])
, ("grinMain", Effects ["_prim_int_print"])
]
}
calculated = (calcEffects exp) { _external = mempty }
calculated `sameAs` expected
-- NOTE: overapproximation
it "simple_case" $ do
let exp = [prog|
grinMain =
n <- pure (COne)
y <- case n of
(COne) -> _prim_int_print 0
(CTwo) -> _prim_string_print #"asd"
(CFoo) -> pure ()
pure y
|]
let expected = mempty
{ _register = [ ("y", Effects ["_prim_int_print", "_prim_string_print"])
, ("n", Effects [])
]
, _function = [ ("grinMain", Effects ["_prim_int_print", "_prim_string_print"]) ]
}
calculated = (calcEffects exp) { _external = mempty }
calculated `sameAs` expected
it "fun_case" $ do
let exp = [prog|
grinMain =
n <- pure (COne)
y <- case n of
(COne) -> f 0
(CTwo) -> g #"asd"
(CFoo) -> h
pure y
f x1 = _prim_int_print x1
g x2 = _prim_string_print x2
h = pure ()
|]
let expected = mempty
{ _register = [ ("y", Effects ["_prim_int_print", "_prim_string_print"])
, ("n", Effects [])
]
, _function = [ ("f", Effects ["_prim_int_print"])
, ("g", Effects ["_prim_string_print"])
, ("h", Effects [])
, ("grinMain", Effects ["_prim_int_print", "_prim_string_print"])
]
}
calculated = (calcEffects exp) { _external = mempty }
calculated `sameAs` expected
it "case_in_case" $ do
let exp = [prog|
grinMain =
n <- pure (COne)
y <- case n of
(COne) ->
z <- case n of
(COne) -> _prim_int_print 0
(CTwo) -> _prim_error "Never should have come here"
pure z
(CTwo) -> _prim_string_print #"asd"
(CFoo) -> pure ()
pure y
|]
let expected = mempty
{ _register = [ ("y", Effects ["_prim_int_print", "_prim_string_print", "_prim_error"])
, ("z", Effects ["_prim_int_print", "_prim_error"])
, ("n", Effects [])
]
, _function = [ ("grinMain", Effects ["_prim_int_print", "_prim_string_print", "_prim_error"]) ]
}
calculated = (calcEffects exp) { _external = mempty }
calculated `sameAs` expected
it "bind_sequence" $ do
let exp = [prog|
grinMain =
x1 <- pure (COne)
x2 <- _prim_int_print 0
x3 <- pure 0
x4 <- _prim_int_add 0 0
x5 <- _prim_string_print #"asd"
pure ()
|]
let expected = mempty
{ _register = [ ("x1", Effects [])
, ("x2", Effects ["_prim_int_print"])
, ("x3", Effects [])
, ("x4", Effects [])
, ("x5", Effects ["_prim_string_print"])
]
, _function = [ ("grinMain", Effects ["_prim_int_print", "_prim_string_print"]) ]
}
calculated = (calcEffects exp) { _external = mempty }
calculated `sameAs` expected
it "bind_sequence_in_fun" $ do
let exp = [prog|
grinMain =
k <- pure 0
y1 <- f k
y2 <- pure (CInt 0)
y3 <- g k
pure ()
f n =
x1 <- pure (COne)
x2 <- _prim_int_print n
x3 <- pure n
x4 <- _prim_int_add n n
x5 <- _prim_string_print #"asd"
pure ()
g m =
z1 <- pure (CTwo)
z2 <- pure n
z3 <- _prim_error "ERROR"
z4 <- _prim_int_add n n
pure ()
|]
let expected = mempty
{ _register = [ ("k", Effects [])
, ("x1", Effects [])
, ("x2", Effects ["_prim_int_print"])
, ("x3", Effects [])
, ("x4", Effects [])
, ("x5", Effects ["_prim_string_print"])
, ("y1", Effects ["_prim_int_print", "_prim_string_print"])
, ("y2", Effects [])
, ("y3", Effects ["_prim_error"])
, ("z1", Effects [])
, ("z2", Effects [])
, ("z3", Effects ["_prim_error"])
, ("z4", Effects [])
]
, _function = [ ("f", Effects ["_prim_int_print", "_prim_string_print"])
, ("g", Effects ["_prim_error"])
, ("grinMain", Effects ["_prim_int_print", "_prim_string_print", "_prim_error"])
]
}
calculated = (calcEffects exp) { _external = mempty }
calculated `sameAs` expected
it "custom_externals" $ do
let exp = [prog|
primop effectful
_prim_string_print :: T_String -> T_Unit
_prim_read_string :: T_String
"newPrimSomething#" :: {"GHC.Prim.SomePrimType#"}
primop pure
_prim_string_concat :: T_String -> T_String -> T_String
ffi pure
newPrimSomething :: {GHC.Prim.SomePrimType}
grinMain =
x0 <- _prim_string_print "Hello World!"
x1 <- _prim_read_string
x2 <- "newPrimSomething#" $
x3 <- _prim_string_concat "Hello" "World"
x4 <- newPrimSomething
pure ()
|]
let expected = mempty
{ _register = [ ("x0", Effects ["_prim_string_print"])
, ("x1", Effects ["_prim_read_string"])
, ("x2", Effects ["newPrimSomething#"])
, ("x3", Effects [])
, ("x4", Effects [])
]
, _function = [ ("grinMain", Effects ["_prim_string_print", "_prim_read_string", "newPrimSomething#"]) ]
}
calculated = (calcEffectsWithoutPrimopsPrelude exp) { _external = mempty }
calculated `sameAs` expected
it "mixed_externals" $ do
let exp = [prog|
primop effectful
"newPrimSomething#" :: {"GHC.Prim.SomePrimType#"}
ffi pure
newPrimSomething :: {GHC.Prim.SomePrimType}
grinMain =
x0 <- _prim_string_print "Hello World!"
x1 <- _prim_read_string
x2 <- "newPrimSomething#" $
x3 <- _prim_string_concat "Hello" "World"
x4 <- newPrimSomething
pure ()
|]
let expected = mempty
{ _register = [ ("x0", Effects ["_prim_string_print"])
, ("x1", Effects ["_prim_read_string"])
, ("x2", Effects ["newPrimSomething#"])
, ("x3", Effects [])
, ("x4", Effects [])
]
, _function = [ ("grinMain", Effects ["_prim_string_print", "_prim_read_string", "newPrimSomething#"]) ]
}
calculated = (calcEffects exp) { _external = mempty }
calculated `sameAs` expected
it "redefining an already existing external is not allowed" $ do
let exp = [prog|
primop effectful
-- already defined in PrimopsPrelude
_prim_string_print :: T_String -> T_Unit
grinMain =
x0 <- _prim_string_print "Hello World!"
pure x
|]
let expected = mempty
{ _register = [ ("x0", Effects ["_prim_string_print"])
, ("x1", Effects ["_prim_read_string"])
, ("x2", Effects ["newPrimSomething#"])
, ("x3", Effects [])
, ("x4", Effects [])
]
, _function = [ ("grinMain", Effects ["_prim_string_print", "_prim_read_string", "newPrimSomething#"]) ]
}
calculated = (calcEffects exp) { _external = mempty }
(return $! calculated) `shouldThrow` anyException

669
grin/test/AbstractInterpretation/LiveVariableSpec.hs
View File

@ -18,6 +18,7 @@ import AbstractInterpretation.Reduce (AbstractInterpretationResult(..),evalAbstr
import AbstractInterpretation.LiveVariable.CodeGen hiding (live)
import AbstractInterpretation.LiveVariable.Result
import AbstractInterpretation.EffectTrackingSpec (calcEffects)
runTests :: IO ()
runTests = hspec spec
@ -40,12 +41,13 @@ spec = describe "Live Variable Analysis" $ do
(CWord c1) -> pure (CNode c1)
#default -> pure (CWord a0)
|]
let caseAnonymousExpected = LVAResult
{ _memory = []
, _register = [ ("a0", deadVal), ("c0", liveVal), ("c1", deadVal) ]
, _function = [ ("grinMain", fun (nodeSet [ (cBool, [live]) ], [])) ]
let caseAnonymousExpected = emptyLVAResult
{ _memory = []
, _registerLv = [ ("a0", deadVal), ("c0", liveVal), ("c1", deadVal) ]
, _functionLv = [ ("grinMain", fun (nodeSet [ (cBool, [live]) ], [])) ]
}
(calcLiveness exp) `sameAs` caseAnonymousExpected
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` caseAnonymousExpected
it "case_min_lit" $ do
let exp = [prog|
@ -60,18 +62,19 @@ spec = describe "Live Variable Analysis" $ do
1 -> pure c
2 -> pure d
|]
let caseMinLitExpected = LVAResult
{ _memory = []
, _register =
let caseMinLitExpected = emptyLVAResult
{ _memory = []
, _registerLv =
[ ("a", liveVal)
, ("b", liveVal)
, ("c", liveVal)
, ("d", liveVal)
, ("e", deadVal)
]
, _function = mkFunctionLivenessMap []
, _functionLv = mkFunctionLivenessMap []
}
(calcLiveness exp) `sameAs` caseMinLitExpected
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` caseMinLitExpected
it "case_min_nodes" $ do
let exp = [prog|
@ -84,20 +87,21 @@ spec = describe "Live Variable Analysis" $ do
(CNode b0) <- pure n1
pure b0
|]
let caseMinNodesExpected = LVAResult
{ _memory = []
, _register =
let caseMinNodesExpected = emptyLVAResult
{ _memory = []
, _registerLv =
[ ("n0", livenessN0)
, ("n1", livenessN1)
, ("c0", liveVal)
, ("c1", deadVal)
, ("b0", liveVal)
]
, _function = mkFunctionLivenessMap []
, _functionLv = mkFunctionLivenessMap []
}
livenessN0 = nodeSet [ (cBool, [live]) ]
livenessN1 = nodeSet [ (cNode, [live]) ]
(calcLiveness exp) `sameAs` caseMinNodesExpected
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` caseMinNodesExpected
it "case_nested" $ do
let exp = [prog|
@ -119,10 +123,10 @@ spec = describe "Live Variable Analysis" $ do
0 -> pure (CBool 0)
1 -> pure (CWord 0)
|]
let caseNestedExpected = LVAResult
{ _memory = []
, _register = caseNestedExpectedRegisters
, _function = caseNestedExpectedFunctions
let caseNestedExpected = emptyLVAResult
{ _memory = []
, _registerLv = caseNestedExpectedRegisters
, _functionLv = caseNestedExpectedFunctions
}
livenessFRet = nodeSet [ (cBool, [live]), (cWord, [live]) ]
livenessMainRet = nodeSet [ (cBool, [live]), (cWord, [live]) ]
@ -144,7 +148,8 @@ spec = describe "Live Variable Analysis" $ do
[ ("f", fun (livenessFRet, [liveVal]))
, ("grinMain", fun (livenessMainRet,[]))
]
(calcLiveness exp) `sameAs` caseNestedExpected
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` caseNestedExpected
it "case_restricted" $ do
let exp = [prog|
@ -162,10 +167,10 @@ spec = describe "Live Variable Analysis" $ do
0 -> pure (CInt 0)
1 -> pure (CWord 0)
|]
caseRestrictedExpected = LVAResult
{ _memory = []
, _register = caseRestrictedExpectedRegisters
, _function = caseRestrictedExpectedFunctions
caseRestrictedExpected = emptyLVAResult
{ _memory = []
, _registerLv = caseRestrictedExpectedRegisters
, _functionLv = caseRestrictedExpectedFunctions
}
caseRestrictedExpectedRegisters =
[ ("n0", livenessFRet)
@ -178,7 +183,8 @@ spec = describe "Live Variable Analysis" $ do
caseRestrictedExpectedFunctions = mkFunctionLivenessMap
[ ("f", fun (livenessFRet, [liveVal])) ]
livenessFRet = nodeSet [ (cInt, [live]), (cWord, [live]) ]
(calcLiveness exp) `sameAs` caseRestrictedExpected
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` caseRestrictedExpected
it "case_restricted_nodes" $ do
let exp = [prog|
@ -201,10 +207,10 @@ spec = describe "Live Variable Analysis" $ do
1 -> pure (CBool 0)
2 -> pure (CWord 0)
|]
caseRestrictedNodesExpected = LVAResult
{ _memory = []
, _register = caseRestrictedNodesExpectedRegisters
, _function = caseRestrictedNodesExpectedFunctions
caseRestrictedNodesExpected = emptyLVAResult
{ _memory = []
, _registerLv = caseRestrictedNodesExpectedRegisters
, _functionLv = caseRestrictedNodesExpectedFunctions
}
caseRestrictedNodesExpectedRegisters =
[ ("n0", livenessFRet)
@ -223,8 +229,25 @@ spec = describe "Live Variable Analysis" $ do
, ("grinMain", fun (livenessFRet, []))
]
livenessFRet = nodeSet [ (cInt, [live]), (cBool, [live]), (cWord, [live]) ]
(calcLiveness exp) `sameAs` caseRestrictedNodesExpected
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` caseRestrictedNodesExpected
{- NOTE: Here, we trusts code instead of relying on
the gathered static information about the possible
tags of a variable.
Here statically `n4` could be any of `CNil`, `CCons`
or `CInt` because LVA is flow-insensitive. However,
we know that during every possible execution of the
program `n4` could only be a `CInt`. So instead of
marking all tags live, we only mark those that appear
amongst the alternatives. Also, if there is a #default
alternative, we mark all tags lives.
Certain front ends could generate code like this, and
it is their responsibility to make sure the pattern
matches cannot fail.
-}
it "dead_tags" $ do
let exp = [prog|
grinMain =
@ -245,17 +268,16 @@ spec = describe "Live Variable Analysis" $ do
pure n3
case n4 of
(CWord c0) -> pure 0
#default -> pure 1
(CInt c0) -> pure 0
|]
deadTagsExpected = LVAResult
{ _memory = [ livenessN2, livenessN3 ]
, _register = deadTagsExpectedRegisters
, _function = mkFunctionLivenessMap []
deadTagsExpected = emptyLVAResult
{ _memory = [ livenessN2, livenessN3 ]
, _registerLv = deadTagsExpectedRegisters
, _functionLv = mkFunctionLivenessMap []
}
deadTagsExpectedRegisters =
[ ("p0", deadVal)
, ("p1", deadVal)
[ ("p0", liveLoc)
, ("p1", liveLoc)
, ("n0", livenessN0)
, ("n1", livenessN1)
, ("n2", livenessN2)
@ -265,10 +287,11 @@ spec = describe "Live Variable Analysis" $ do
]
livenessN0 = deadNodeSet [ (cNil, 0) ]
livenessN1 = deadNodeSet [ (cCons, 2) ]
livenessN2 = deadNodeSet [ (cNil, 0), (cInt, 1) ]
livenessN3 = deadNodeSet [ (cCons, 2), (cInt, 1) ]
livenessN4 = deadNodeSet [ (cNil, 0), (cCons, 2), (cInt, 1) ]
(calcLiveness exp) `sameAs` deadTagsExpected
livenessN2 = nodeSet' [ (cNil, [dead]) , (cInt, [live, dead]) ]
livenessN3 = nodeSet' [ (cCons, [dead, dead, dead]), (cInt, [live, dead]) ]
livenessN4 = nodeSet' [ (cNil, [dead]), (cCons, [dead, dead, dead]), (cInt, [live, dead]) ]
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` deadTagsExpected
it "fields" $ do
let exp = [prog|
@ -284,10 +307,10 @@ spec = describe "Live Variable Analysis" $ do
case x of
(CNode c2 c3) -> pure c3
|]
let fieldsExpected = LVAResult
{ _memory = []
, _register = fieldsExpectedRegisters
, _function = fieldsExpectedFunctions
let fieldsExpected = emptyLVAResult
{ _memory = []
, _registerLv = fieldsExpectedRegisters
, _functionLv = fieldsExpectedFunctions
}
fieldsExpectedRegisters =
[ ("a0", deadVal)
@ -303,7 +326,8 @@ spec = describe "Live Variable Analysis" $ do
fieldsExpectedFunctions = mkFunctionLivenessMap
[ ("f", fun (liveVal, [livenessX])) ]
livenessX = nodeSet [ (cNode, [dead, live]) ]
(calcLiveness exp) `sameAs` fieldsExpected
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` fieldsExpected
it "function_call_1" $ do
let exp = [prog|
@ -317,10 +341,10 @@ spec = describe "Live Variable Analysis" $ do
(CFoo c0) -> pure c0
(CBar c1) -> pure 5
|]
let functionCall1Expected = LVAResult
{ _memory = []
, _register = functionCall1ExpectedRegisters
, _function = functionCall1ExpectedFunctions
let functionCall1Expected = emptyLVAResult
{ _memory = []
, _registerLv = functionCall1ExpectedRegisters
, _functionLv = functionCall1ExpectedFunctions
}
functionCall1ExpectedRegisters =
[ ("n", livenessN)
@ -333,7 +357,8 @@ spec = describe "Live Variable Analysis" $ do
livenessX = nodeSet [ (cFoo, [live]) ]
functionCall1ExpectedFunctions = mkFunctionLivenessMap
[ ("f", fun (liveVal, [livenessX])) ]
(calcLiveness exp) `sameAs` functionCall1Expected
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` functionCall1Expected
it "function_call_2" $ do
let exp = [prog|
@ -347,10 +372,10 @@ spec = describe "Live Variable Analysis" $ do
b0 <- pure 0
pure (CTwo a0 b0)
|]
let functionCall2Expected = LVAResult
{ _memory = []
, _register = functionCall2ExpectedRegisters
, _function = functionCall2ExpectedFunctions
let functionCall2Expected = emptyLVAResult
{ _memory = []
, _registerLv = functionCall2ExpectedRegisters
, _functionLv = functionCall2ExpectedFunctions
}
functionCall2ExpectedRegisters =
[ ("a0", liveVal)
@ -364,7 +389,8 @@ spec = describe "Live Variable Analysis" $ do
[ ("f", fun (nodeSet [ (cTwo, [live, dead]) ], []))
, ("grinMain", fun (nodeSet [ (cOne, [live]) ], []))
]
(calcLiveness exp) `sameAs` functionCall2Expected
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` functionCall2Expected
it "heap_case_min" $ do
let exp = [prog|
@ -374,13 +400,14 @@ spec = describe "Live Variable Analysis" $ do
(CBool a1) <- fetch p0
pure a1
|]
let heapCaseMinExpected = LVAResult
{ _memory = [ livenessLoc1 ]
, _register = [ ("p0", liveVal), ("c1", liveVal), ("a1", liveVal) ]
, _function = mkFunctionLivenessMap []
let heapCaseMinExpected = emptyLVAResult
{ _memory = [ livenessLoc1 ]
, _registerLv = [ ("p0", liveVal), ("c1", liveVal), ("a1", liveVal) ]
, _functionLv = mkFunctionLivenessMap []
}
livenessLoc1 = nodeSet [ (cBool, [live]) ]
(calcLiveness exp) `sameAs` heapCaseMinExpected
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` heapCaseMinExpected
it "heap_case" $ do
let exp = [prog|
@ -401,10 +428,10 @@ spec = describe "Live Variable Analysis" $ do
0 -> pure (CBool 0)
1 -> pure (CWord 0)
|]
let heapCaseExpected = LVAResult
{ _memory = heapCaseExpectedHeap
, _register = heapCaseExpectedRegisters
, _function = heapCaseExpectedFunctions
let heapCaseExpected = emptyLVAResult
{ _memory = heapCaseExpectedHeap
, _registerLv = heapCaseExpectedRegisters
, _functionLv = heapCaseExpectedFunctions
}
heapCaseExpectedHeap =
[ nodeSet [ (cWordH, [dead]) ]
@ -428,7 +455,44 @@ spec = describe "Live Variable Analysis" $ do
[ ("f", fun (livenessFRet,[liveVal])) ]
livenessLoc1 = nodeSet [ (cBoolH, [live]), (cWordH, [dead]) ]
livenessFRet = nodeSet [ (cBool, [live]), (cWord, [dead]) ]
(calcLiveness exp) `sameAs` heapCaseExpected
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` heapCaseExpected
it "heap_case_default_pat" $ do
let exp = [prog|
grinMain =
n0 <- pure (CNil 0)
n1 <- pure (COne 1)
n2 <- pure (CTwo 2)
p0 <- store n0
update p0 n1
update p0 n2
n <- fetch p0
x <- case n of
(CNil c0) -> pure 0
(COne c1) -> pure 0
#default -> pure 0
pure x
|]
let heapCaseMinExpected = emptyLVAResult
{ _memory = [ livenessLoc1 ]
, _registerLv = [ ("n0", nodeSet' [ cNilLiveness ])
, ("n1", nodeSet' [ cOneLiveness ])
, ("n2", nodeSet' [ cTwoLiveness ])
, ("p0", liveLoc)
, ("n", nodeSet' [ cNilLiveness, cOneLiveness, cTwoLiveness ] )
, ("c0", deadVal)
, ("c1", deadVal)
, ("x", liveVal)
]
, _functionLv = mkFunctionLivenessMap []
}
cNilLiveness = (cNil, [live, dead])
cOneLiveness = (cOne, [live, dead])
cTwoLiveness = (cTwo, [live, dead])
livenessLoc1 = nodeSet' [ cNilLiveness, cOneLiveness, cTwoLiveness ]
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` heapCaseMinExpected
it "heap_indirect_simple" $ do
let exp = [prog|
@ -445,10 +509,10 @@ spec = describe "Live Variable Analysis" $ do
pure xs'
pure r
|]
let heapIndirectSimpleExpected = LVAResult
{ _memory = [ nodeSet [ (cNil, []) ] ]
, _register = heapIndirectSimpleExpectedRegisters
, _function = [ ("grinMain", fun (livenessMainRet,[])) ]
let heapIndirectSimpleExpected = emptyLVAResult
{ _memory = [ nodeSet [ (cNil, []) ] ]
, _registerLv = heapIndirectSimpleExpectedRegisters
, _functionLv = [ ("grinMain", fun (livenessMainRet,[])) ]
}
heapIndirectSimpleExpectedRegisters =
[ ("a0", deadVal)
@ -463,7 +527,8 @@ spec = describe "Live Variable Analysis" $ do
livenessN0 = nodeSet [ (cNil, []) ]
livenessN1 = nodeSet [ (cCons, [dead,live]) ]
livenessMainRet = nodeSet [ (cNil, []) ]
(calcLiveness exp) `sameAs` heapIndirectSimpleExpected
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` heapIndirectSimpleExpected
it "heap_simple" $ do
let exp = [prog|
@ -474,10 +539,10 @@ spec = describe "Live Variable Analysis" $ do
(CTwo a b) <- pure x
pure a
|]
let heapSimpleExpected = LVAResult
{ _memory = heapSimpleExpectedHeap
, _register = heapSimpleExpectedRegisters
, _function = mkFunctionLivenessMap []
let heapSimpleExpected = emptyLVAResult
{ _memory = heapSimpleExpectedHeap
, _registerLv = heapSimpleExpectedRegisters
, _functionLv = mkFunctionLivenessMap []
}
heapSimpleExpectedHeap = [ nodeSet $ [ (cTwo, [live, dead]) ] ]
heapSimpleExpectedRegisters =
@ -489,7 +554,8 @@ spec = describe "Live Variable Analysis" $ do
]
livenessN = nodeSet $ [ (cTwo, [live, dead]) ]
livenessX = livenessN
(calcLiveness exp) `sameAs` heapSimpleExpected
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` heapSimpleExpected
it "heap_update_complex" $ do
let exp = [prog|
@ -508,10 +574,10 @@ spec = describe "Live Variable Analysis" $ do
(CNode c2) -> pure c2
(CNope c3) -> pure c3
|]
let heapUpdateComplexExpected = LVAResult
{ _memory = heapUpdateComplexExpectedHeap
, _register = heapUpdateComplexExpectedRegisters
, _function = mkFunctionLivenessMap []
let heapUpdateComplexExpected = emptyLVAResult
{ _memory = heapUpdateComplexExpectedHeap
, _registerLv = heapUpdateComplexExpectedRegisters
, _functionLv = mkFunctionLivenessMap []
}
heapUpdateComplexExpectedHeap =
[ nodeSet [ (cBool, [live]), (cNode, [live]) ]
@ -535,7 +601,8 @@ spec = describe "Live Variable Analysis" $ do
, (cWord, [dead])
, (cNode, [live])
]
(calcLiveness exp) `sameAs` heapUpdateComplexExpected
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` heapUpdateComplexExpected
it "heap_update_fun_call" $ do
let exp = [prog|
@ -560,10 +627,10 @@ spec = describe "Live Variable Analysis" $ do
g u v =
update u v
|]
let heapUpdateFunCallExpected = LVAResult
{ _memory = heapUpdateFunCallExpectedHeap
, _register = heapUpdateFunCallExpectedRegisters
, _function = heapUpdateFunCallExpectedFunctions
let heapUpdateFunCallExpected = emptyLVAResult
{ _memory = heapUpdateFunCallExpectedHeap
, _registerLv = heapUpdateFunCallExpectedRegisters
, _functionLv = heapUpdateFunCallExpectedFunctions
}
heapUpdateFunCallExpectedHeap =
[ nodeSet [ (cBool, [live]), (cNode, [live]) ]
@ -597,7 +664,8 @@ spec = describe "Live Variable Analysis" $ do
livenessN0 = nodeSet [ (cBool, [live]) ]
livenessN1 = nodeSet [ (cWord, [dead]) ]
livenessN2 = nodeSet [ (cNode, [live]) ]
(calcLiveness exp) `sameAs` heapUpdateFunCallExpected
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` heapUpdateFunCallExpected
it "heap_update_local" $ do
let exp = [prog|
@ -612,10 +680,10 @@ spec = describe "Live Variable Analysis" $ do
(CWord c1) -> pure 5
(CNope c2) -> pure c2
|]
let heapUpdateLocalExpected = LVAResult
{ _memory = heapUpdateLocalExpectedHeap
, _register = heapUpdateLocalExpectedRegisters
, _function = mkFunctionLivenessMap []
let heapUpdateLocalExpected = emptyLVAResult
{ _memory = heapUpdateLocalExpectedHeap
, _registerLv = heapUpdateLocalExpectedRegisters
, _functionLv = mkFunctionLivenessMap []
}
heapUpdateLocalExpectedHeap =
[ nodeSet [ (cBool, [live]), (cWord, [dead]) ] ]
@ -631,7 +699,8 @@ spec = describe "Live Variable Analysis" $ do
livenessN0 = nodeSet [ (cBool, [live]) ]
livenessN1 = nodeSet [ (cWord, [dead]) ]
livenessN2 = nodeSet [ (cBool, [live]), (cWord, [dead]) ]
(calcLiveness exp) `sameAs` heapUpdateLocalExpected
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` heapUpdateLocalExpected
it "lit_pat" $ do
let exp = [prog|
@ -642,14 +711,60 @@ spec = describe "Live Variable Analysis" $ do
f x = pure x
|]
let litPatExpected = LVAResult
{ _memory = []
, _register = [ ("y", liveVal), ("x", liveVal) ]
, _function = litPatExpectedFunctions
let litPatExpected = emptyLVAResult
{ _memory = []
, _registerLv = [ ("y", liveVal), ("x", liveVal) ]
, _functionLv = litPatExpectedFunctions
}
litPatExpectedFunctions = mkFunctionLivenessMap
[ ("f", fun (liveVal, [liveVal])) ]
(calcLiveness exp) `sameAs` litPatExpected
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` litPatExpected
it "var_pat" $ do
let exp = [prog|
grinMain =
y <- pure 0
z <- f y
pure y
f x = pure x
|]
let varPatExpected = emptyLVAResult
{ _memory = []
, _registerLv = [ ("z", deadVal), ("y", liveVal), ("x", deadVal) ]
, _functionLv = varPatExpectedFunctions
}
varPatExpectedFunctions = mkFunctionLivenessMap
[ ("f", fun (deadVal, [deadVal])) ]
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` varPatExpected
it "node_pat" $ do
let exp = [prog|
grinMain =
y <- pure (CInt 5)
(CInt n) <- f y
pure y
f x = pure x
|]
let nodePatExpected = emptyLVAResult
{ _memory = []
, _registerLv = [ ("n", deadVal), ("y", livenessY), ("x", livenessFRet) ]
, _functionLv = nodePatExpectedFunctions
}
nodePatExpectedFunctions =
[ ("f", fun (livenessFRet, [livenessFArg]))
, ("grinMain", fun (livenessY, []))
]
livenessY = nodeSet [ (cInt, [live]) ]
livenessFRet = nodeSet [ (cInt, [dead]) ]
livenessFArg = livenessFRet
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` nodePatExpected
it "main_node_ret" $ do
let exp = [prog|
@ -659,10 +774,10 @@ spec = describe "Live Variable Analysis" $ do
n <- pure (CTwo a b)
pure n
|]
let mainNodeRetExpected = LVAResult
{ _memory = []
, _register = mainNodeRetExpectedRegisters
, _function = [ ("grinMain", fun (livenessN, [])) ]
let mainNodeRetExpected = emptyLVAResult
{ _memory = []
, _registerLv = mainNodeRetExpectedRegisters
, _functionLv = [ ("grinMain", fun (livenessN, [])) ]
}
mainNodeRetExpectedRegisters =
[ ("a", liveVal)
@ -670,7 +785,8 @@ spec = describe "Live Variable Analysis" $ do
, ("n", livenessN)
]
livenessN = nodeSet [ (cTwo, [live, live]) ]
(calcLiveness exp) `sameAs` mainNodeRetExpected
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` mainNodeRetExpected
it "nodes_simple" $ do
let exp = [prog|
@ -688,10 +804,10 @@ spec = describe "Live Variable Analysis" $ do
0 -> pure (CInt y)
1 -> pure (CBool z)
|]
let nodesSimpleExpected = LVAResult
{ _memory = []
, _register = nodesSimpleExpectedRegisters
, _function = nodesSimpleExpectedFunctions
let nodesSimpleExpected = emptyLVAResult
{ _memory = []
, _registerLv = nodesSimpleExpectedRegisters
, _functionLv = nodesSimpleExpectedFunctions
}
nodesSimpleExpectedRegisters =
[ ("a0", liveVal)
@ -708,9 +824,11 @@ spec = describe "Live Variable Analysis" $ do
nodesSimpleExpectedFunctions = mkFunctionLivenessMap
[ ("f", fun (livenessN0, [liveVal, liveVal, deadVal])) ]
livenessN0 = nodeSet [ (cInt, [live]), (cBool, [dead]) ]
(calcLiveness exp) `sameAs` nodesSimpleExpected
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` nodesSimpleExpected
it "nodes_tricky" $ do
pendingWith "illegal grin code: every node tag must have a single arity for the whole program"
let exp = [prog|
grinMain =
n0 <- f 0
@ -723,10 +841,10 @@ spec = describe "Live Variable Analysis" $ do
0 -> pure (COne x)
1 -> pure (CTwo 0 x)
|]
let nodesTrickyExpected = LVAResult
{ _memory = []
, _register = nodesTrickyExpectedRegisters
, _function = nodesTrickyExpectedFunctions
let nodesTrickyExpected = emptyLVAResult
{ _memory = []
, _registerLv = nodesTrickyExpectedRegisters
, _functionLv = nodesTrickyExpectedFunctions
}
nodesTrickyExpectedRegisters =
[ ("n0", livenessN0)
@ -739,7 +857,8 @@ spec = describe "Live Variable Analysis" $ do
nodesTrickyExpectedFunctions = mkFunctionLivenessMap
[ ("f", fun (livenessN0, [liveVal])) ]
livenessN0 = nodeSet [ (cOne, [dead]), (cTwo, [live, dead]) ]
(calcLiveness exp) `sameAs` nodesTrickyExpected
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` nodesTrickyExpected
it "sum_opt" $ do
let exp = withPrimPrelude [prog|
@ -756,10 +875,12 @@ spec = describe "Live Variable Analysis" $ do
n28 <- _prim_int_add n29 n30
sum n28 n18 n31
|]
let sumOptExpected = LVAResult
{ _memory = []
, _register = sumOptExpectedRegisters
, _function = sumOptExpectedFunctions
let sumOptExpected = emptyLVAResult
{ _memory = []
, _registerLv = sumOptExpectedRegisters
, _functionLv = sumOptExpectedFunctions
, _registerEff = sumOptExpectedRegisterEffects
, _functionEff = sumOptExpectedFunctionEffects
}
sumOptExpectedRegisters =
[ ("n13", liveVal)
@ -773,11 +894,26 @@ spec = describe "Live Variable Analysis" $ do
]
sumOptExpectedFunctions = mkFunctionLivenessMap
[ ("sum", fun (liveVal, [liveVal, liveVal, liveVal]))
, ("_prim_int_add", fun (liveVal, [liveVal, liveVal]))
, ("_prim_int_gt", fun (liveVal, [liveVal, liveVal]))
, ("_prim_int_print", fun (liveVal, [liveVal]))
]
(calcLiveness exp) `sameAs` sumOptExpected
sumOptExpectedRegisterEffects =
[ ("n13", noEffect)
, ("n29", noEffect)
, ("n29", noEffect)
, ("n30", noEffect)
, ("n31", noEffect)
, ("b2", noEffect)
, ("n18", noEffect)
, ("n28", noEffect)
]
sumOptExpectedFunctionEffects =
[ ("sum", noEffect)
, ("grinMain", hasEffect)
]
calculated = calcLiveness exp
calculated `sameAs` sumOptExpected
it "undefined" $ do
let exp = [prog|
@ -792,10 +928,10 @@ spec = describe "Live Variable Analysis" $ do
x1 <- fetch c0
pure x1
|]
let undefinedExpected = LVAResult
{ _memory = undefinedExpectedHeap
, _register = undefinedExpectedRegisters
, _function = mkFunctionLivenessMap []
let undefinedExpected = emptyLVAResult
{ _memory = undefinedExpectedHeap
, _registerLv = undefinedExpectedRegisters
, _functionLv = mkFunctionLivenessMap []
}
undefinedExpectedHeap =
[ deadNodeSet [ (cNil, 0) ]
@ -816,7 +952,8 @@ spec = describe "Live Variable Analysis" $ do
livenessN1 = cConsBothDead
livenessN2 = nodeSet [ (cCons, [live, dead]) ]
cConsBothDead = deadNodeSet [ (cCons, 2) ]
(calcLiveness exp) `sameAs` undefinedExpected
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` undefinedExpected
it "undefined_with_loc_info" $ do
let exp = [prog|
@ -827,10 +964,10 @@ spec = describe "Live Variable Analysis" $ do
x0 <- fetch c0
pure x0
|]
let undefinedWithLocInfoExpected = LVAResult
{ _memory = [ cNilLiveness ]
, _register = undefinedWithLocInfoExpectedRegisters
, _function = undefinedWithLocInfoExpectedFunctions
let undefinedWithLocInfoExpected = emptyLVAResult
{ _memory = [ cNilLiveness ]
, _registerLv = undefinedWithLocInfoExpectedRegisters
, _functionLv = undefinedWithLocInfoExpectedFunctions
}
undefinedWithLocInfoExpectedRegisters =
[ ("p0", deadVal)
@ -843,7 +980,273 @@ spec = describe "Live Variable Analysis" $ do
[ ("grinMain", fun (cNilLiveness, [])) ]
livenessN0 = nodeSet [ (cCons, [live, dead]) ]
cNilLiveness = nodeSet [ (cNil, []) ]
(calcLiveness exp) `sameAs` undefinedWithLocInfoExpected
calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty }
calculated `sameAs` undefinedWithLocInfoExpected
it "case_lit_pat_side_effect" $ do
let exp = withPrimPrelude [prog|
grinMain =
n <- pure 0
y <- case n of
0 -> _prim_int_print 0
1 -> _prim_string_print #"asd"
2 -> pure ()
pure ()
|]
let expected = emptyLVAResult
{ _memory = []
, _registerLv = expectedRegisterLiveness
, _functionLv = expectedFunctionLiveness
, _registerEff = expectedRegisterEffects
, _functionEff = expectedFunctionEffects
}
expectedRegisterLiveness =
[ ("n", liveVal)
, ("y", deadVal)
]
expectedFunctionLiveness = mkFunctionLivenessMap []
expectedRegisterEffects =
[ ("n", noEffect)
, ("y", hasEffect)
]
expectedFunctionEffects =
[ ("grinMain", hasEffect)
]
calculated = calcLiveness exp
calculated `sameAs` expected
it "case_node_pat_side_effect" $ do
let exp = withPrimPrelude [prog|
grinMain =
n <- pure (COne 1)
y <- case n of
(COne c1) -> _prim_int_print 0
(CTwo c2) -> _prim_string_print #"asd"
(CFoo c3) -> pure ()
pure ()
|]
let expected = emptyLVAResult
{ _memory = []
, _registerLv = expectedRegisterLiveness
, _functionLv = expectedFunctionLiveness
, _registerEff = expectedRegisterEffects
, _functionEff = expectedFunctionEffects
}
expectedRegisterLiveness =
[ ("n", nodeSet [ (cOne, [dead]) ])
, ("y", deadVal)
, ("c1", deadVal)
, ("c2", deadVal)
, ("c3", deadVal)
]
expectedFunctionLiveness = mkFunctionLivenessMap []
expectedRegisterEffects =
[ ("n", noEffect)
, ("y", hasEffect)
, ("c1", noEffect)
, ("c2", noEffect)
, ("c3", noEffect)
]
expectedFunctionEffects =
[ ("grinMain", hasEffect)
]
calculated = calcLiveness exp
calculated `sameAs` expected
it "case_default_alt_side_effect" $ do
let exp = withPrimPrelude [prog|
grinMain =
n <- pure (COne 1)
y <- case n of
(CFoo c2) -> pure ()
#default -> _prim_int_print 0
pure ()
|]
let expected = emptyLVAResult
{ _memory = []
, _registerLv = expectedRegisterLiveness
, _functionLv = expectedFunctionLiveness
, _registerEff = expectedRegisterEffects
, _functionEff = expectedFunctionEffects
}
expectedRegisterLiveness =
[ ("n", nodeSet' [ (cOne, [live, dead]) ])
, ("y", deadVal)
, ("c2", deadVal)
]
expectedFunctionLiveness = mkFunctionLivenessMap []
expectedRegisterEffects =
[ ("n", noEffect)
, ("y", hasEffect)
, ("c2", noEffect)
]
expectedFunctionEffects =
[ ("grinMain", hasEffect)
]
calculated = calcLiveness exp
calculated `sameAs` expected
it "case_dead_tags_side_effect" $ do
let exp = withPrimPrelude [prog|
grinMain =
n1 <- pure (COne 1)
p <- store n1
n2 <- pure (CTwo 2)
update p n2
n3 <- fetch p
y <- case n3 of
(CTwo c) -> _prim_string_print #"asd"
pure ()
|]
let expected = emptyLVAResult
{ _memory = expectedHeapLiveness
, _registerLv = expectedRegisterLiveness
, _functionLv = expectedFunctionLiveness
, _registerEff = expectedRegisterEffects
, _functionEff = expectedFunctionEffects
}
livenessN1 = nodeSet' [ (cOne, [dead, dead]) ]
livenessN2 = nodeSet' [ (cTwo, [live, dead]) ]
livenessN3 = nodeSet' [ (cOne, [dead, dead]), (cTwo, [live, dead]) ]
expectedHeapLiveness =
[ livenessN3
]
expectedRegisterLiveness =
[ ("n1", livenessN1)
, ("n2", livenessN2)
, ("n3", livenessN3)
, ("p", liveLoc)
, ("y", deadVal)
, ("c", deadVal)
]
expectedFunctionLiveness = mkFunctionLivenessMap []
expectedRegisterEffects =
[ ("n1", noEffect)
, ("n2", noEffect)
, ("n3", noEffect)
, ("p", noEffect)
, ("y", hasEffect)
, ("c", noEffect)
]
expectedFunctionEffects =
[ ("grinMain", hasEffect)
]
calculated = calcLiveness exp
calculated `sameAs` expected
it "case_fun_side_effect" $ do
let exp = withPrimPrelude [prog|
grinMain =
n <- pure (COne 1)
y <- case n of
(COne c1) -> f 0
(CTwo c2) -> g #"asd"
(CFoo c3) -> h
pure ()
f x1 = _prim_int_print x1
g x2 = _prim_int_print x2
h = pure ()
|]
let expected = emptyLVAResult
{ _memory = []
, _registerLv = expectedRegisterLiveness
, _functionLv = expectedFunctionLiveness
, _registerEff = expectedRegisterEffects
, _functionEff = expectedFunctionEffects
}
expectedRegisterLiveness =
[ ("n", nodeSet [ (cOne, [dead]) ])
, ("y", deadVal)
, ("c1", deadVal)
, ("c2", deadVal)
, ("c3", deadVal)
, ("x1", liveVal)
, ("x2", liveVal)
]
expectedFunctionLiveness = mkFunctionLivenessMap
[ ("f", fun (deadVal, [liveVal]))
, ("g", fun (deadVal, [liveVal]))
, ("h", fun (deadVal, []))
]
expectedRegisterEffects =
[ ("n", noEffect)
, ("y", hasEffect)
, ("c1", noEffect)
, ("c2", noEffect)
, ("c3", noEffect)
, ("x1", noEffect)
, ("x2", noEffect)
]
expectedFunctionEffects =
[ ("f", hasEffect)
, ("g", hasEffect)
, ("h", noEffect)
, ("grinMain", hasEffect)
]
calculated = calcLiveness exp
calculated `sameAs` expected
it "case_nested_side_effect" $ do
let exp = withPrimPrelude [prog|
grinMain =
x <- pure (CInt 5)
y <- case x of
(CInt n) ->
z <- case n of
#default ->
_prim_int_print 5
pure ()
pure z
pure 0
|]
let expected = emptyLVAResult
{ _memory = []
, _registerLv = expectedRegisterLiveness
, _functionLv = expectedFunctionLiveness
, _registerEff = expectedRegisterEffects
, _functionEff = expectedFunctionEffects
}
expectedRegisterLiveness =
[ ("x", nodeSet [ (cInt, [live]) ])
, ("y", deadVal)
, ("z", deadVal)
, ("n", liveVal)
]
expectedFunctionLiveness = mkFunctionLivenessMap []
expectedRegisterEffects =
[ ("x", noEffect)
, ("y", hasEffect)
, ("z", hasEffect)
, ("n", noEffect)
]
expectedFunctionEffects =
[ ("grinMain", hasEffect)
]
calculated = calcLiveness exp
calculated `sameAs` expected
live :: Bool
live = True
@ -894,3 +1297,9 @@ fun = fmap V.fromList
mkFunctionLivenessMap :: [(Name, (Liveness, Vector Liveness))]
-> Map Name (Liveness, Vector Liveness)
mkFunctionLivenessMap = M.insert "grinMain" (fun (liveVal,[])) . M.fromList
hasEffect :: Effect
hasEffect = Effect True
noEffect :: Effect
noEffect = Effect False

Some files were not shown because too many files have changed in this diff Show More