mirror of
https://github.com/grin-compiler/grin.git
synced 2024-09-11 07:25:28 +03:00
Merge branch 'master' into update-nix-setup
This commit is contained in:
commit
9ac2ec72f4
13
.github/FUNDING.yml
vendored
Normal file
13
.github/FUNDING.yml
vendored
Normal 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
4
.gitignore
vendored
@ -24,3 +24,7 @@ output/
|
||||
*.agdai
|
||||
.output
|
||||
.grin-output/
|
||||
.vscode/
|
||||
*.out
|
||||
*.out.ll
|
||||
*.out.s
|
||||
|
@ -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
55
BACKERS.md
Normal file
@ -0,0 +1,55 @@
|
||||
<h1 align="center">Sponsors & 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
172
README.md
@ -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
|
||||
|
@ -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
44
docs/Analysis-Experiment.md
Normal 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)
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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;">
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
10
grin/app/CLI/Main.hs
Normal 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
118
grin/grin.cabal
@ -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
|
||||
|
@ -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)
|
@ -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)
|
@ -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
|
@ -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
|
@ -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)
|
@ -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
|
@ -1,5 +0,0 @@
|
||||
grinMain =
|
||||
p0 <- case (CBool 0) of
|
||||
(CBool c1) -> store (CBool c1)
|
||||
(CBool a1) <- fetch p0
|
||||
pure a1
|
@ -1,6 +0,0 @@
|
||||
grinMain =
|
||||
n <- pure (CTwo 0 1)
|
||||
p <- store n
|
||||
x <- fetch p
|
||||
(CTwo a b) <- pure x
|
||||
pure a
|
@ -1,6 +0,0 @@
|
||||
grinMain =
|
||||
y <- pure 0
|
||||
5 <- f y
|
||||
pure 0
|
||||
|
||||
f x = pure x
|
@ -1,5 +0,0 @@
|
||||
grinMain =
|
||||
a <- pure 0
|
||||
b <- pure 0
|
||||
n <- pure (CTwo a b)
|
||||
pure n
|
@ -1,4 +0,0 @@
|
||||
grinMain =
|
||||
a <- pure 0
|
||||
b <- pure 0
|
||||
pure (CTwo a b)
|
@ -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)
|
@ -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)
|
@ -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
|
@ -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
243
grin/prim_ops.c
Normal 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
36
grin/prim_ops.h
Normal 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
251
grin/src/AbstractInterpretation/BinaryIR.hs
Normal 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
65
grin/src/AbstractInterpretation/BinaryResult.hs
Normal 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
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
116
grin/src/AbstractInterpretation/EffectTracking/CodeGen.hs
Normal 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
136
grin/src/AbstractInterpretation/EffectTracking/CodeGenBase.hs
Normal 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
30
grin/src/AbstractInterpretation/EffectTracking/Pretty.hs
Normal 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
82
grin/src/AbstractInterpretation/EffectTracking/Result.hs
Normal 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
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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 ()) ->
|
||||
|
@ -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
|
||||
}
|
||||
|
@ -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)
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
25
grin/src/AbstractInterpretation/ReduceCpp.hs
Normal 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
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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-}
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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]
|
||||
|
@ -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 = []
|
||||
|
@ -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}
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
||||
|
@ -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
|
||||
|
@ -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))
|
||||
]
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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"
|
||||
|
@ -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
|
||||
|
@ -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.
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
@ -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
1
grin/test-data/.gitignore
vendored
Normal file
@ -0,0 +1 @@
|
||||
experimental/
|
50
grin/test-data/dead-data-elimination/length2.grin
Normal file
50
grin/test-data/dead-data-elimination/length2.grin
Normal 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
|
@ -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
|
@ -0,0 +1,5 @@
|
||||
outputExtension: "out"
|
||||
grinOptions:
|
||||
- "--quiet"
|
||||
- "--dpe"
|
||||
- "--save-grin=$$$OUT$$$"
|
BIN
grin/test-data/sum-simple/sum_simple.binary
Normal file
BIN
grin/test-data/sum-simple/sum_simple.binary
Normal file
Binary file not shown.
37
grin/test-data/sum-simple/sum_simple_exp.grin
Normal file
37
grin/test-data/sum-simple/sum_simple_exp.grin
Normal 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
24
grin/test-data/sum-simple/sum_simple_exp.grin.expected
Normal 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
6
grin/test-data/sum-simple/sum_simple_exp.grin.opts
Normal file
@ -0,0 +1,6 @@
|
||||
outputExtension: "out.s"
|
||||
grinOptions:
|
||||
- "--optimize"
|
||||
- "--hpt"
|
||||
- "--quiet"
|
||||
- "--save-llvm=$$$OUT$$$"
|
22
grin/test-runtime/runtime.c
Normal file
22
grin/test-runtime/runtime.c
Normal 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
336
grin/test/AbstractInterpretation/EffectTrackingSpec.hs
Normal 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
|
@ -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
Loading…
Reference in New Issue
Block a user