Compare commits
13 Commits
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
1a0ef46df8 | ||
|
|
1436f1124f | ||
|
|
2e13ec2cf4 | ||
|
|
36a17d092b | ||
|
|
ccc71a751c | ||
|
|
c57da862ae | ||
|
|
4c9ceb74d1 | ||
|
|
8267548fab | ||
|
|
968832bfaf | ||
|
|
81b019e659 | ||
|
|
cd2a283493 | ||
|
|
bb41d3c196 | ||
|
|
de16bf12df |
15
README.md
15
README.md
@@ -26,12 +26,14 @@ $ cabal test --test-show-details=direct
|
|||||||
#### TLDR
|
#### TLDR
|
||||||
|
|
||||||
```sh
|
```sh
|
||||||
# Compile and evaluate examples/factorial.cr, with evaluation info dumped to stderr
|
# Compile and evaluate examples/rlp/QuickSort.rl
|
||||||
$ rlpc -ddump-eval examples/factorial.cr
|
$ rlpc examples/QuickSort.rl
|
||||||
# Compile and evaluate t.cr, with evaluation info dumped to t.log
|
# Compile and evaluate t.cr, with evaluation info dumped to t.log
|
||||||
$ rlpc -ddump-eval -l t.log t.cr
|
$ rlpc -ddump-eval -l t.log t.cr
|
||||||
# Compile and evaluate t.rl, dumping the desugared Core
|
# Compile and evaluate t.rl, dumping the desugared Core
|
||||||
$ rlpc -ddump-desugared t.rl
|
$ rlpc -ddump-desugared t.rl
|
||||||
|
# Compile and evaluate t.rl with all compiler messages enabled
|
||||||
|
$ rlpc -dALL t.rl
|
||||||
```
|
```
|
||||||
|
|
||||||
#### Options
|
#### Options
|
||||||
@@ -126,7 +128,7 @@ parsing remains.
|
|||||||
- [x] Garbage Collection
|
- [x] Garbage Collection
|
||||||
- [ ] Stable documentation for the evaluation model
|
- [ ] Stable documentation for the evaluation model
|
||||||
|
|
||||||
### February Release Plan
|
### ~~February Release Plan~~
|
||||||
- [x] Beta rl' to Core
|
- [x] Beta rl' to Core
|
||||||
- [x] UX improvements
|
- [x] UX improvements
|
||||||
- [x] Actual compiler errors -- no more unexceptional `error` calls
|
- [x] Actual compiler errors -- no more unexceptional `error` calls
|
||||||
@@ -134,12 +136,14 @@ parsing remains.
|
|||||||
- [x] Annotate the AST with token positions for errors (NOTE: As of Feb. 1,
|
- [x] Annotate the AST with token positions for errors (NOTE: As of Feb. 1,
|
||||||
this has been done, but the locational info is not yet used in error messages)
|
this has been done, but the locational info is not yet used in error messages)
|
||||||
- [x] Compiler architecture diagram
|
- [x] Compiler architecture diagram
|
||||||
- [ ] More examples
|
- [x] More examples
|
||||||
|
|
||||||
### March Release Plan
|
### March Release Plan
|
||||||
- [ ] Tests
|
- [ ] Tests
|
||||||
- [ ] rl' parser
|
- [ ] rl' parser
|
||||||
- [ ] rl' lexer
|
- [ ] rl' lexer
|
||||||
|
- [ ] Ditch TTG in favour of a simpler AST focusing on extendability via Fix, Free,
|
||||||
|
Cofree, etc. rather than boilerplate-heavy type families
|
||||||
|
|
||||||
### Indefinite Release Plan
|
### Indefinite Release Plan
|
||||||
|
|
||||||
@@ -150,8 +154,6 @@ than the other release plans.
|
|||||||
- [ ] Complete all TODOs
|
- [ ] Complete all TODOs
|
||||||
- [ ] Replace mtl with effectful
|
- [ ] Replace mtl with effectful
|
||||||
- [ ] rl' type-checker
|
- [ ] rl' type-checker
|
||||||
- [ ] Ditch TTG in favour of a simpler AST focusing on extendability via Fix, Free,
|
|
||||||
Cofree, etc. rather than boilerplate-heavy type families
|
|
||||||
- [ ] Stable rl' to Core
|
- [ ] Stable rl' to Core
|
||||||
- [ ] Core polish
|
- [ ] Core polish
|
||||||
- [ ] Better, stable parser
|
- [ ] Better, stable parser
|
||||||
@@ -160,3 +162,4 @@ than the other release plans.
|
|||||||
- [ ] Less hacky pragmas
|
- [ ] Less hacky pragmas
|
||||||
- [ ] Choose a target. LLVM, JS, C, and WASM are currently top contenders
|
- [ ] Choose a target. LLVM, JS, C, and WASM are currently top contenders
|
||||||
- [ ] https://proglangdesign.net/wiki/challenges
|
- [ ] https://proglangdesign.net/wiki/challenges
|
||||||
|
|
||||||
|
|||||||
@@ -6,7 +6,7 @@ module CoreDriver
|
|||||||
import Compiler.RLPC
|
import Compiler.RLPC
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Data.Text qualified as T
|
import Data.Text qualified as T
|
||||||
import Lens.Micro.Platform
|
import Control.Lens.Combinators
|
||||||
|
|
||||||
import Core.Lex
|
import Core.Lex
|
||||||
import Core.Parse
|
import Core.Parse
|
||||||
|
|||||||
@@ -19,7 +19,7 @@ import System.Exit (exitSuccess)
|
|||||||
import Core
|
import Core
|
||||||
import TI
|
import TI
|
||||||
import GM
|
import GM
|
||||||
import Lens.Micro.Platform
|
import Control.Lens.Combinators hiding (argument)
|
||||||
|
|
||||||
import CoreDriver qualified
|
import CoreDriver qualified
|
||||||
import RlpDriver qualified
|
import RlpDriver qualified
|
||||||
|
|||||||
@@ -63,52 +63,13 @@ an assembly target. The goal of our new G-Machine is to compile a *linear
|
|||||||
sequence of instructions* which, **when executed**, build up a graph
|
sequence of instructions* which, **when executed**, build up a graph
|
||||||
representing the code.
|
representing the code.
|
||||||
|
|
||||||
**************************
|
*************
|
||||||
Trees and Vines, in Theory
|
The G-Machine
|
||||||
**************************
|
*************
|
||||||
|
|
||||||
Rather than instantiating an expression at runtime -- traversing the AST and
|
|
||||||
building a graph -- we want to compile all expressions at compile-time,
|
|
||||||
generating a linear sequence of instructions which may be executed to build the
|
|
||||||
graph.
|
|
||||||
|
|
||||||
**************************
|
|
||||||
Evaluation: Slurping Vines
|
|
||||||
**************************
|
|
||||||
|
|
||||||
WIP.
|
|
||||||
|
|
||||||
Laziness
|
|
||||||
--------
|
|
||||||
|
|
||||||
WIP.
|
|
||||||
|
|
||||||
* Instead of :code:`Slide (n+1); Unwind`, do :code:`Update n; Pop n; Unwind`
|
|
||||||
|
|
||||||
****************************
|
|
||||||
Compilation: Squashing Trees
|
|
||||||
****************************
|
|
||||||
|
|
||||||
WIP.
|
|
||||||
|
|
||||||
Notice that we do not keep a (local) environment at run-time. The environment
|
|
||||||
only exists at compile-time to map local names to stack indices. When compiling
|
|
||||||
a supercombinator, the arguments are enumerated from zero (the top of the
|
|
||||||
stack), and passed to :code:`compileR` as an environment.
|
|
||||||
|
|
||||||
.. literalinclude:: /../../src/GM.hs
|
.. literalinclude:: /../../src/GM.hs
|
||||||
:dedent:
|
:dedent:
|
||||||
:start-after: -- >> [ref/compileSc]
|
:start-after: -- >> [ref/Instr]
|
||||||
:end-before: -- << [ref/compileSc]
|
:end-before: -- << [ref/Instr]
|
||||||
:caption: src/GM.hs
|
|
||||||
|
|
||||||
Of course, variables being indexed relative to the top of the stack means that
|
|
||||||
they will become inaccurate the moment we push or pop the stack a single time.
|
|
||||||
The way around this is quite simple: simply offset the stack when w
|
|
||||||
|
|
||||||
.. literalinclude:: /../../src/GM.hs
|
|
||||||
:dedent:
|
|
||||||
:start-after: -- >> [ref/compileC]
|
|
||||||
:end-before: -- << [ref/compileC]
|
|
||||||
:caption: src/GM.hs
|
:caption: src/GM.hs
|
||||||
|
|
||||||
|
|||||||
@@ -62,159 +62,6 @@ braces and semicolons. In developing our *layout* rules, we will follow in the
|
|||||||
pattern of translating the whitespace-sensitive source language to an explicitly
|
pattern of translating the whitespace-sensitive source language to an explicitly
|
||||||
sectioned language.
|
sectioned language.
|
||||||
|
|
||||||
But What About Haskell?
|
|
||||||
***********************
|
|
||||||
|
|
||||||
Parsing Haskell -- and thus rl' -- is only slightly more complex than Python,
|
|
||||||
but the design is certainly more sensitive.
|
|
||||||
|
|
||||||
.. code-block:: haskell
|
|
||||||
|
|
||||||
-- line folds
|
|
||||||
something = this is a
|
|
||||||
single expression
|
|
||||||
|
|
||||||
-- an extremely common style found in haskell
|
|
||||||
data Some = Data
|
|
||||||
{ is :: Presented
|
|
||||||
, in :: This
|
|
||||||
, silly :: Style
|
|
||||||
}
|
|
||||||
|
|
||||||
-- another style oddity
|
|
||||||
-- note that this is not a single
|
|
||||||
-- continued line! `look at`,
|
|
||||||
-- `this odd`, and `alignment` are all
|
|
||||||
-- discrete items!
|
|
||||||
anotherThing = do look at
|
|
||||||
this odd
|
|
||||||
alignment
|
|
||||||
|
|
||||||
But enough fear, lets actually think about implementation. Firstly, some
|
|
||||||
formality: what do we mean when we say layout? We will define layout as the
|
|
||||||
rules we apply to an implicitly-sectioned language in order to yield one that is
|
|
||||||
explicitly-sectioned. We will also define indentation of a lexeme as the column
|
|
||||||
number of its first character.
|
|
||||||
|
|
||||||
Thankfully for us, our entry point is quite clear; layouts only appear after a
|
|
||||||
select few keywords, (with a minor exception; TODO: elaborate) being :code:`let`
|
|
||||||
(followed by supercombinators), :code:`where` (followed by supercombinators),
|
|
||||||
:code:`do` (followed by expressions), and :code:`of` (followed by alternatives)
|
|
||||||
(TODO: all of these terms need linked glossary entries). In order to manage the
|
|
||||||
cascade of layout contexts, our lexer will record a stack for which each element
|
|
||||||
is either :math:`\varnothing`, denoting an explicit layout written with braces
|
|
||||||
and semicolons, or a :math:`\langle n \rangle`, denoting an implicitly laid-out
|
|
||||||
layout where the start of each item belonging to the layout is indented
|
|
||||||
:math:`n` columns.
|
|
||||||
|
|
||||||
.. code-block:: haskell
|
|
||||||
|
|
||||||
-- layout stack: []
|
|
||||||
module M where -- layout stack: [∅]
|
|
||||||
|
|
||||||
f x = let -- layout keyword; remember indentation of next token
|
|
||||||
y = w * w -- layout stack: [∅, <10>]
|
|
||||||
w = x + x
|
|
||||||
-- layout ends here
|
|
||||||
in do -- layout keyword; next token is a brace!
|
|
||||||
{ -- layout stack: [∅]
|
|
||||||
print y;
|
|
||||||
print x;
|
|
||||||
}
|
|
||||||
|
|
||||||
Finally, we also need the concept of "virtual" brace tokens, which as far as
|
|
||||||
we're concerned at this moment are exactly like normal brace tokens, except
|
|
||||||
implicitly inserted by the compiler. With the presented ideas in mind, we may
|
|
||||||
begin to introduce a small set of informal rules describing the lexer's handling
|
|
||||||
of layouts, the first being:
|
|
||||||
|
|
||||||
1. If a layout keyword is followed by the token '{', push :math:`\varnothing`
|
|
||||||
onto the layout context stack. Otherwise, push :math:`\langle n \rangle` onto
|
|
||||||
the layout context stack where :math:`n` is the indentation of the token
|
|
||||||
following the layout keyword. Additionally, the lexer is to insert a virtual
|
|
||||||
opening brace after the token representing the layout keyword.
|
|
||||||
|
|
||||||
Consider the following observations from that previous code sample:
|
|
||||||
|
|
||||||
* Function definitions should belong to a layout, each of which may start at
|
|
||||||
column 1.
|
|
||||||
|
|
||||||
* A layout can enclose multiple bodies, as seen in the :code:`let`-bindings and
|
|
||||||
the :code:`do`-expression.
|
|
||||||
|
|
||||||
* Semicolons should *terminate* items, rather than *separate* them.
|
|
||||||
|
|
||||||
Our current focus is the semicolons. In an implicit layout, items are on
|
|
||||||
separate lines each aligned with the previous. A naïve implementation would be
|
|
||||||
to insert the semicolon token when the EOL is reached, but this proves unideal
|
|
||||||
when you consider the alignment requirement. In our implementation, our lexer
|
|
||||||
will wait until the first token on a new line is reached, then compare
|
|
||||||
indentation and insert a semicolon if appropriate. This comparison -- the
|
|
||||||
nondescript measurement of "more, less, or equal indentation" rather than a
|
|
||||||
numeric value -- is referred to as *offside* by myself internally and the
|
|
||||||
Haskell report describing layouts. We informally formalise this rule as follows:
|
|
||||||
|
|
||||||
2. When the first token on a line is preceeded only by whitespace, if the
|
|
||||||
token's first grapheme resides on a column number :math:`m` equal to the
|
|
||||||
indentation level of the enclosing context -- i.e. the :math:`\langle n
|
|
||||||
\rangle` on top of the layout stack. Should no such context exist on the
|
|
||||||
stack, assume :math:`m > n`.
|
|
||||||
|
|
||||||
We have an idea of how to begin layouts, delimit the enclosed items, and last
|
|
||||||
we'll need to end layouts. This is where the distinction between virtual and
|
|
||||||
non-virtual brace tokens comes into play. The lexer needs only partial concern
|
|
||||||
towards closing layouts; the complete responsibility is shared with the parser.
|
|
||||||
This will be elaborated on in the next section. For now, we will be content with
|
|
||||||
naïvely inserting a virtual closing brace when a token is indented right of the
|
|
||||||
layout.
|
|
||||||
|
|
||||||
3. Under the same conditions as rule 2., when :math:`m < n` the lexer shall
|
|
||||||
insert a virtual closing brace and pop the layout stack.
|
|
||||||
|
|
||||||
This rule covers some cases including the top-level, however, consider
|
|
||||||
tokenising the :code:`in` in a :code:`let`-expression. If our lexical analysis
|
|
||||||
framework only allows for lexing a single token at a time, we cannot return both
|
|
||||||
a virtual right-brace and a :code:`in`. Under this model, the lexer may simply
|
|
||||||
pop the layout stack and return the :code:`in` token. As we'll see in the next
|
|
||||||
section, as long as the lexer keeps track of its own context (i.e. the stack),
|
|
||||||
the parser will cope just fine without the virtual end-brace.
|
|
||||||
|
|
||||||
Parsing Lonely Braces
|
|
||||||
*********************
|
|
||||||
|
|
||||||
When viewed in the abstract, parsing and tokenising are near-identical tasks yet
|
|
||||||
the two are very often decomposed into discrete systems with very different
|
|
||||||
implementations. Lexers operate on streams of text and tokens, while parsers
|
|
||||||
are typically far less linear, using a parse stack or recursing top-down. A
|
|
||||||
big reason for this separation is state management: the parser aims to be as
|
|
||||||
context-free as possible, while the lexer tends to burden the necessary
|
|
||||||
statefulness. Still, the nature of a stream-oriented lexer makes backtracking
|
|
||||||
difficult and quite inelegant.
|
|
||||||
|
|
||||||
However, simply declaring a parse error to be not an error at all
|
|
||||||
counterintuitively proves to be an elegant solution our layout problem which
|
|
||||||
minimises backtracking and state in both the lexer and the parser. Consider the
|
|
||||||
following definitions found in rlp's BNF:
|
|
||||||
|
|
||||||
.. productionlist:: rlp
|
|
||||||
VOpen : `vopen`
|
|
||||||
VClose : `vclose` | `error`
|
|
||||||
|
|
||||||
A parse error is recovered and treated as a closing brace. Another point of note
|
|
||||||
in the BNF is the difference between virtual and non-virtual braces (TODO: i
|
|
||||||
don't like that the BNF is formatted without newlines :/):
|
|
||||||
|
|
||||||
.. productionlist:: rlp
|
|
||||||
LetExpr : `let` VOpen Bindings VClose `in` Expr | `let` `{` Bindings `}` `in` Expr
|
|
||||||
|
|
||||||
This ensures that non-virtual braces are closed explicitly.
|
|
||||||
|
|
||||||
This set of rules is adequete enough to satisfy our basic concerns about line
|
|
||||||
continations and layout lists. For a more pedantic description of the layout
|
|
||||||
system, see `chapter 10
|
|
||||||
<https://www.haskell.org/onlinereport/haskell2010/haskellch10.html>`_ of the
|
|
||||||
2010 Haskell Report, which I heavily referenced here.
|
|
||||||
|
|
||||||
References
|
References
|
||||||
----------
|
----------
|
||||||
|
|
||||||
|
|||||||
31
examples/rlp/QuickSort.rl
Normal file
31
examples/rlp/QuickSort.rl
Normal file
@@ -0,0 +1,31 @@
|
|||||||
|
data List a = Nil | Cons a (List a)
|
||||||
|
|
||||||
|
data Bool = False | True
|
||||||
|
|
||||||
|
filter :: (a -> Bool) -> List a -> List a
|
||||||
|
filter p l = case l of
|
||||||
|
Nil -> Nil
|
||||||
|
Cons a as ->
|
||||||
|
case p a of
|
||||||
|
True -> Cons a (filter p as)
|
||||||
|
False -> filter p as
|
||||||
|
|
||||||
|
append :: List a -> List a -> List a
|
||||||
|
append p q = case p of
|
||||||
|
Nil -> q
|
||||||
|
Cons a as -> Cons a (append as q)
|
||||||
|
|
||||||
|
qsort :: List Int# -> List Int#
|
||||||
|
qsort l = case l of
|
||||||
|
Nil -> Nil
|
||||||
|
Cons a as ->
|
||||||
|
let lesser = filter (>=# a) as
|
||||||
|
greater = filter (<# a) as
|
||||||
|
in append (append (qsort lesser) (Cons a Nil)) (qsort greater)
|
||||||
|
|
||||||
|
list :: List Int#
|
||||||
|
list = Cons 9 (Cons 2 (Cons 3 (Cons 2
|
||||||
|
(Cons 5 (Cons 2 (Cons 12 (Cons 89 Nil)))))))
|
||||||
|
|
||||||
|
main = print# (qsort list)
|
||||||
|
|
||||||
@@ -7,5 +7,5 @@ foldr f z l = case l of
|
|||||||
|
|
||||||
list = Cons 1 (Cons 2 (Cons 3 Nil))
|
list = Cons 1 (Cons 2 (Cons 3 Nil))
|
||||||
|
|
||||||
main = foldr (+#) 0 list
|
main = print# (foldr (+#) 0 list)
|
||||||
|
|
||||||
|
|||||||
26
rlp.cabal
26
rlp.cabal
@@ -50,32 +50,26 @@ library
|
|||||||
build-tool-depends: happy:happy, alex:alex
|
build-tool-depends: happy:happy, alex:alex
|
||||||
|
|
||||||
-- other-extensions:
|
-- other-extensions:
|
||||||
build-depends: base >=4.17 && <4.20
|
build-depends: base >=4.17 && <4.21
|
||||||
-- required for happy
|
-- required for happy
|
||||||
, array >= 0.5.5 && < 0.6
|
, array >= 0.5.5 && < 0.6
|
||||||
, containers >= 0.6.7 && < 0.7
|
, containers >= 0.6.7 && < 0.7
|
||||||
, template-haskell >= 2.20.0 && < 2.21
|
, template-haskell >= 2.20.0 && < 2.23
|
||||||
, pretty >= 1.1.3 && < 1.2
|
, pretty >= 1.1.3 && < 1.2
|
||||||
, data-default >= 0.7.1 && < 0.8
|
, data-default >= 0.7.1 && < 0.8
|
||||||
, data-default-class >= 0.1.2 && < 0.2
|
, data-default-class >= 0.1.2 && < 0.2
|
||||||
, hashable >= 1.4.3 && < 1.5
|
, hashable >= 1.4.3 && < 1.5
|
||||||
, mtl >= 2.3.1 && < 2.4
|
, mtl >= 2.3.1 && < 2.4
|
||||||
, text >= 2.0.2 && < 2.1
|
, text >= 2.0.2 && < 2.3
|
||||||
, megaparsec >= 9.6.1 && < 9.7
|
|
||||||
, microlens >= 0.4.13 && < 0.5
|
|
||||||
, microlens-mtl >= 0.2.0 && < 0.3
|
|
||||||
, microlens-platform >= 0.4.3 && < 0.5
|
|
||||||
, microlens-th >= 0.4.3 && < 0.5
|
|
||||||
, unordered-containers >= 0.2.20 && < 0.3
|
, unordered-containers >= 0.2.20 && < 0.3
|
||||||
, recursion-schemes >= 5.2.2 && < 5.3
|
, recursion-schemes >= 5.2.2 && < 5.3
|
||||||
, data-fix >= 0.3.2 && < 0.4
|
, data-fix >= 0.3.2 && < 0.4
|
||||||
, utf8-string >= 1.0.2 && < 1.1
|
, utf8-string >= 1.0.2 && < 1.1
|
||||||
, extra >= 1.7.0 && < 2
|
, extra >= 1.7.0 && <2
|
||||||
, semigroupoids
|
, semigroupoids >=6.0 && <6.1
|
||||||
, comonad
|
, comonad >=5.0.0 && <6
|
||||||
, lens
|
, lens >=5.2.3 && <6.0
|
||||||
, text-ansi
|
, text-ansi >=0.2.0 && <0.4
|
||||||
, microlens-pro ^>=0.2.0
|
|
||||||
, effectful-core ^>=2.3.0.0
|
, effectful-core ^>=2.3.0.0
|
||||||
, deriving-compat ^>=0.6.0
|
, deriving-compat ^>=0.6.0
|
||||||
, these >=0.2 && <2.0
|
, these >=0.2 && <2.0
|
||||||
@@ -102,10 +96,10 @@ executable rlpc
|
|||||||
build-depends: base >=4.17.0.0 && <4.20.0.0
|
build-depends: base >=4.17.0.0 && <4.20.0.0
|
||||||
, rlp
|
, rlp
|
||||||
, optparse-applicative >= 0.18.1 && < 0.19
|
, optparse-applicative >= 0.18.1 && < 0.19
|
||||||
, microlens-platform
|
|
||||||
, mtl >= 2.3.1 && < 2.4
|
, mtl >= 2.3.1 && < 2.4
|
||||||
, unordered-containers >= 0.2.20 && < 0.3
|
, unordered-containers >= 0.2.20 && < 0.3
|
||||||
, text >= 2.0.2 && < 2.1
|
, lens >=5.2.3 && <6.0
|
||||||
|
, text >= 2.0.2 && < 2.3
|
||||||
|
|
||||||
hs-source-dirs: app
|
hs-source-dirs: app
|
||||||
default-language: GHC2021
|
default-language: GHC2021
|
||||||
|
|||||||
@@ -11,6 +11,7 @@ module Compiler.JustRun
|
|||||||
( justLexCore
|
( justLexCore
|
||||||
, justParseCore
|
, justParseCore
|
||||||
, justTypeCheckCore
|
, justTypeCheckCore
|
||||||
|
, justHdbg
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
@@ -20,14 +21,22 @@ import Core.HindleyMilner
|
|||||||
import Core.Syntax (Program')
|
import Core.Syntax (Program')
|
||||||
import Compiler.RLPC
|
import Compiler.RLPC
|
||||||
import Control.Arrow ((>>>))
|
import Control.Arrow ((>>>))
|
||||||
import Control.Monad ((>=>))
|
import Control.Monad ((>=>), void)
|
||||||
import Control.Comonad
|
import Control.Comonad
|
||||||
import Control.Lens
|
import Control.Lens
|
||||||
import Data.Text qualified as T
|
import Data.Text qualified as T
|
||||||
import Data.Function ((&))
|
import Data.Function ((&))
|
||||||
|
import System.IO
|
||||||
import GM
|
import GM
|
||||||
|
import Rlp.Parse
|
||||||
|
import Rlp2Core
|
||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
justHdbg :: String -> IO GmState
|
||||||
|
justHdbg s = do
|
||||||
|
p <- evalRLPCIO def (parseRlpProgR >=> desugarRlpProgR $ T.pack s)
|
||||||
|
withFile "/tmp/t.log" WriteMode $ hdbgProg p
|
||||||
|
|
||||||
justLexCore :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
|
justLexCore :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
|
||||||
justLexCore s = lexCoreR (T.pack s)
|
justLexCore s = lexCoreR (T.pack s)
|
||||||
& mapped . each %~ extract
|
& mapped . each %~ extract
|
||||||
|
|||||||
@@ -64,8 +64,8 @@ import Data.Text.IO qualified as T
|
|||||||
import System.IO
|
import System.IO
|
||||||
import Text.ANSI qualified as Ansi
|
import Text.ANSI qualified as Ansi
|
||||||
import Text.PrettyPrint hiding ((<>))
|
import Text.PrettyPrint hiding ((<>))
|
||||||
import Lens.Micro.Platform
|
import Control.Lens
|
||||||
import Lens.Micro.Platform.Internal
|
import Data.Text.Lens (packed, unpacked, IsText)
|
||||||
import System.Exit
|
import System.Exit
|
||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
|||||||
@@ -21,8 +21,7 @@ import Control.Monad.Errorful
|
|||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Text qualified as T
|
import Data.Text qualified as T
|
||||||
import GHC.Exts (IsString(..))
|
import GHC.Exts (IsString(..))
|
||||||
import Lens.Micro.Platform
|
import Control.Lens
|
||||||
import Lens.Micro.Platform.Internal
|
|
||||||
import Compiler.Types
|
import Compiler.Types
|
||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
|||||||
@@ -20,7 +20,7 @@ import Data.Functor.Identity
|
|||||||
import Data.Coerce
|
import Data.Coerce
|
||||||
import Data.HashSet (HashSet)
|
import Data.HashSet (HashSet)
|
||||||
import Data.HashSet qualified as H
|
import Data.HashSet qualified as H
|
||||||
import Lens.Micro
|
import Control.Lens
|
||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
|
|
||||||
newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Maybe a, [e]) }
|
newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Maybe a, [e]) }
|
||||||
|
|||||||
@@ -16,9 +16,7 @@ module Core.HindleyMilner
|
|||||||
)
|
)
|
||||||
where
|
where
|
||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
import Lens.Micro
|
import Control.Lens hiding (Context', Context)
|
||||||
import Lens.Micro.Mtl
|
|
||||||
import Lens.Micro.Platform
|
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import Data.Text qualified as T
|
import Data.Text qualified as T
|
||||||
import Data.Pretty (rpretty)
|
import Data.Pretty (rpretty)
|
||||||
|
|||||||
@@ -26,8 +26,7 @@ import Compiler.RLPC
|
|||||||
import Compiler.Types
|
import Compiler.Types
|
||||||
-- TODO: unify Located definitions
|
-- TODO: unify Located definitions
|
||||||
import Compiler.RlpcError
|
import Compiler.RlpcError
|
||||||
import Lens.Micro
|
import Control.Lens
|
||||||
import Lens.Micro.TH
|
|
||||||
}
|
}
|
||||||
|
|
||||||
%wrapper "monad-strict-text"
|
%wrapper "monad-strict-text"
|
||||||
|
|||||||
@@ -24,7 +24,7 @@ import Core.Syntax
|
|||||||
import Core.Lex
|
import Core.Lex
|
||||||
import Compiler.RLPC
|
import Compiler.RLPC
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Lens.Micro
|
import Control.Lens hiding (snoc)
|
||||||
import Data.Default.Class (def)
|
import Data.Default.Class (def)
|
||||||
import Data.Hashable (Hashable)
|
import Data.Hashable (Hashable)
|
||||||
import Data.List.Extra
|
import Data.List.Extra
|
||||||
|
|||||||
@@ -60,8 +60,6 @@ import Data.Bifoldable (bifoldr)
|
|||||||
import GHC.Generics (Generic, Generically(..))
|
import GHC.Generics (Generic, Generically(..))
|
||||||
-- Lift instances for the Core quasiquoters
|
-- Lift instances for the Core quasiquoters
|
||||||
import Language.Haskell.TH.Syntax (Lift)
|
import Language.Haskell.TH.Syntax (Lift)
|
||||||
-- import Lens.Micro.TH (makeLenses)
|
|
||||||
-- import Lens.Micro
|
|
||||||
import Control.Lens
|
import Control.Lens
|
||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
|||||||
@@ -13,7 +13,7 @@ import Data.Functor.Foldable
|
|||||||
import Data.Set (Set)
|
import Data.Set (Set)
|
||||||
import Data.Set qualified as S
|
import Data.Set qualified as S
|
||||||
import Core.Syntax
|
import Core.Syntax
|
||||||
import Lens.Micro
|
import Control.Lens
|
||||||
import GHC.Exts (IsList(..))
|
import GHC.Exts (IsList(..))
|
||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
|||||||
@@ -24,7 +24,6 @@ import Numeric (showHex)
|
|||||||
|
|
||||||
import Data.Pretty
|
import Data.Pretty
|
||||||
import Compiler.RLPC
|
import Compiler.RLPC
|
||||||
-- import Lens.Micro.Platform
|
|
||||||
import Control.Lens
|
import Control.Lens
|
||||||
import Core.Syntax
|
import Core.Syntax
|
||||||
import Core.Utils
|
import Core.Utils
|
||||||
@@ -70,7 +69,7 @@ tagData p = let ?dt = p ^. programDataTags
|
|||||||
go x = embed x
|
go x = embed x
|
||||||
|
|
||||||
tagAlts :: (?dt :: HashMap Name (Tag, Int)) => Alter' -> Alter'
|
tagAlts :: (?dt :: HashMap Name (Tag, Int)) => Alter' -> Alter'
|
||||||
tagAlts (Alter (AltData c) bs e) = Alter (AltTag tag) bs e
|
tagAlts (Alter (AltData c) bs e) = Alter (AltTag tag) bs (cata go e)
|
||||||
where tag = case ?dt ^. at c of
|
where tag = case ?dt ^. at c of
|
||||||
Just (t,_) -> t
|
Just (t,_) -> t
|
||||||
-- TODO: errorful
|
-- TODO: errorful
|
||||||
|
|||||||
37
src/GM.hs
37
src/GM.hs
@@ -9,8 +9,12 @@ module GM
|
|||||||
( hdbgProg
|
( hdbgProg
|
||||||
, evalProg
|
, evalProg
|
||||||
, evalProgR
|
, evalProgR
|
||||||
|
, GmState(..)
|
||||||
|
, gmCode, gmStack, gmDump, gmHeap, gmEnv, gmStats
|
||||||
, Node(..)
|
, Node(..)
|
||||||
|
, showState
|
||||||
, gmEvalProg
|
, gmEvalProg
|
||||||
|
, Stats(..)
|
||||||
, finalStateOf
|
, finalStateOf
|
||||||
, resultOf
|
, resultOf
|
||||||
, resultOfExpr
|
, resultOfExpr
|
||||||
@@ -22,11 +26,8 @@ import Data.List (mapAccumL)
|
|||||||
import Data.Maybe (fromMaybe, mapMaybe)
|
import Data.Maybe (fromMaybe, mapMaybe)
|
||||||
import Data.Monoid (Endo(..))
|
import Data.Monoid (Endo(..))
|
||||||
import Data.Tuple (swap)
|
import Data.Tuple (swap)
|
||||||
import Lens.Micro
|
import Control.Lens
|
||||||
import Lens.Micro.Extras (view)
|
import Data.Text.Lens (IsText, packed, unpacked)
|
||||||
import Lens.Micro.TH
|
|
||||||
import Lens.Micro.Platform (packed, unpacked)
|
|
||||||
import Lens.Micro.Platform.Internal (IsText(..))
|
|
||||||
import Text.Printf
|
import Text.Printf
|
||||||
import Text.PrettyPrint hiding ((<>))
|
import Text.PrettyPrint hiding ((<>))
|
||||||
import Text.PrettyPrint.HughesPJ (maybeParens)
|
import Text.PrettyPrint.HughesPJ (maybeParens)
|
||||||
@@ -89,6 +90,7 @@ data Key = NameKey Name
|
|||||||
| ConstrKey Tag Int
|
| ConstrKey Tag Int
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
|
-- >> [ref/Instr]
|
||||||
data Instr = Unwind
|
data Instr = Unwind
|
||||||
| PushGlobal Name
|
| PushGlobal Name
|
||||||
| PushConstr Tag Int
|
| PushConstr Tag Int
|
||||||
@@ -103,13 +105,14 @@ data Instr = Unwind
|
|||||||
-- arith
|
-- arith
|
||||||
| Neg | Add | Sub | Mul | Div
|
| Neg | Add | Sub | Mul | Div
|
||||||
-- comparison
|
-- comparison
|
||||||
| Equals | Lesser
|
| Equals | Lesser | GreaterEq
|
||||||
| Pack Tag Int -- Pack Tag Arity
|
| Pack Tag Int -- Pack Tag Arity
|
||||||
| CaseJump [(Tag, Code)]
|
| CaseJump [(Tag, Code)]
|
||||||
| Split Int
|
| Split Int
|
||||||
| Print
|
| Print
|
||||||
| Halt
|
| Halt
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
-- << [ref/Instr]
|
||||||
|
|
||||||
data Node = NNum Int
|
data Node = NNum Int
|
||||||
| NAp Addr Addr
|
| NAp Addr Addr
|
||||||
@@ -152,7 +155,7 @@ evalProg p = res <&> (,sts)
|
|||||||
resAddr = final ^. gmStack ^? _head
|
resAddr = final ^. gmStack ^? _head
|
||||||
res = resAddr >>= flip hLookup h
|
res = resAddr >>= flip hLookup h
|
||||||
|
|
||||||
hdbgProg :: Program' -> Handle -> IO (Node, Stats)
|
hdbgProg :: Program' -> Handle -> IO GmState
|
||||||
hdbgProg p hio = do
|
hdbgProg p hio = do
|
||||||
(renderOut . showState) `traverse_` states
|
(renderOut . showState) `traverse_` states
|
||||||
-- TODO: i'd like the statistics to be at the top of the file, but `sts`
|
-- TODO: i'd like the statistics to be at the top of the file, but `sts`
|
||||||
@@ -160,7 +163,7 @@ hdbgProg p hio = do
|
|||||||
-- *can't* get partial logs in the case of a crash. this is in opposition to
|
-- *can't* get partial logs in the case of a crash. this is in opposition to
|
||||||
-- the above traversal which *will* produce partial logs. i love laziness :3
|
-- the above traversal which *will* produce partial logs. i love laziness :3
|
||||||
renderOut . showStats $ sts
|
renderOut . showStats $ sts
|
||||||
pure (res, sts)
|
pure final
|
||||||
where
|
where
|
||||||
renderOut r = hPutStrLn hio $ render r ++ "\n"
|
renderOut r = hPutStrLn hio $ render r ++ "\n"
|
||||||
|
|
||||||
@@ -228,6 +231,7 @@ step st = case head (st ^. gmCode) of
|
|||||||
Div -> divI
|
Div -> divI
|
||||||
Equals -> equalsI
|
Equals -> equalsI
|
||||||
Lesser -> lesserI
|
Lesser -> lesserI
|
||||||
|
GreaterEq -> greaterEqI
|
||||||
Split n -> splitI n
|
Split n -> splitI n
|
||||||
Pack t n -> packI t n
|
Pack t n -> packI t n
|
||||||
CaseJump as -> caseJumpI as
|
CaseJump as -> caseJumpI as
|
||||||
@@ -451,9 +455,10 @@ step st = case head (st ^. gmCode) of
|
|||||||
mulI = primitive2 boxInt unboxInt (*) st
|
mulI = primitive2 boxInt unboxInt (*) st
|
||||||
divI = primitive2 boxInt unboxInt div st
|
divI = primitive2 boxInt unboxInt div st
|
||||||
|
|
||||||
lesserI, equalsI :: GmState
|
lesserI, greaterEqI, equalsI :: GmState
|
||||||
equalsI = primitive2 boxBool unboxInt (==) st
|
equalsI = primitive2 boxBool unboxInt (==) st
|
||||||
lesserI = primitive2 boxBool unboxInt (<) st
|
lesserI = primitive2 boxBool unboxInt (<) st
|
||||||
|
greaterEqI = primitive2 boxBool unboxInt (>=) st
|
||||||
|
|
||||||
splitI :: Int -> GmState
|
splitI :: Int -> GmState
|
||||||
splitI n = st
|
splitI n = st
|
||||||
@@ -638,8 +643,9 @@ compiledPrims =
|
|||||||
, binop "/#" Div
|
, binop "/#" Div
|
||||||
, binop "==#" Equals
|
, binop "==#" Equals
|
||||||
, binop "<#" Lesser
|
, binop "<#" Lesser
|
||||||
|
, binop ">=#" GreaterEq
|
||||||
, ("print#", 1, [ Push 0, Eval, Print, Pack tag_Unit_unit 0, Update 1, Pop 1
|
, ("print#", 1, [ Push 0, Eval, Print, Pack tag_Unit_unit 0, Update 1, Pop 1
|
||||||
, Unwind])
|
, Unwind ])
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
unop k i = (k, 1, [Push 0, Eval, i, Update 1, Pop 1, Unwind])
|
unop k i = (k, 1, [Push 0, Eval, i, Update 1, Pop 1, Unwind])
|
||||||
@@ -743,14 +749,12 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
|
|||||||
mconcat binders <> compileE g' e <> [Slide d]
|
mconcat binders <> compileE g' e <> [Slide d]
|
||||||
where
|
where
|
||||||
d = length bs
|
d = length bs
|
||||||
(g',binders) = mapAccumL compileBinder (argOffset d g) addressed
|
(g',binders) = mapAccumL compileBinder g bs
|
||||||
-- kinda gross. revisit this
|
|
||||||
addressed = bs `zip` reverse [0 .. d-1]
|
|
||||||
|
|
||||||
compileBinder :: Env -> (Binding', Int) -> (Env, Code)
|
compileBinder :: Env -> Binding' -> (Env, Code)
|
||||||
compileBinder m (k := v, a) = (m',c)
|
compileBinder m (k := v) = (m',c)
|
||||||
where
|
where
|
||||||
m' = (NameKey k, a) : m
|
m' = (NameKey k, 0) : argOffset 1 m
|
||||||
-- make note that we use m rather than m'!
|
-- make note that we use m rather than m'!
|
||||||
c = compileC m v
|
c = compileC m v
|
||||||
|
|
||||||
@@ -779,6 +783,7 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
|
|||||||
compileE g ("/#" :$ a :$ b) = inlineOp2 g Div a b
|
compileE g ("/#" :$ a :$ b) = inlineOp2 g Div a b
|
||||||
compileE g ("==#" :$ a :$ b) = inlineOp2 g Equals a b
|
compileE g ("==#" :$ a :$ b) = inlineOp2 g Equals a b
|
||||||
compileE g ("<#" :$ a :$ b) = inlineOp2 g Lesser a b
|
compileE g ("<#" :$ a :$ b) = inlineOp2 g Lesser a b
|
||||||
|
compileE g (">=#" :$ a :$ b) = inlineOp2 g GreaterEq a b
|
||||||
|
|
||||||
compileE g (Case e as) = compileE g e <> [CaseJump (compileD g as)]
|
compileE g (Case e as) = compileE g e <> [CaseJump (compileD g as)]
|
||||||
|
|
||||||
|
|||||||
@@ -27,8 +27,7 @@ import Data.Text (Text)
|
|||||||
import Data.Text qualified as T
|
import Data.Text qualified as T
|
||||||
import Data.Word
|
import Data.Word
|
||||||
import Data.Default
|
import Data.Default
|
||||||
import Lens.Micro.Mtl
|
import Control.Lens
|
||||||
import Lens.Micro
|
|
||||||
|
|
||||||
import Debug.Trace
|
import Debug.Trace
|
||||||
import Rlp.Parse.Types
|
import Rlp.Parse.Types
|
||||||
|
|||||||
@@ -13,7 +13,7 @@ import Rlp.Lex
|
|||||||
import Rlp.Syntax
|
import Rlp.Syntax
|
||||||
import Rlp.Parse.Types
|
import Rlp.Parse.Types
|
||||||
import Rlp.Parse.Associate
|
import Rlp.Parse.Associate
|
||||||
import Lens.Micro.Platform
|
import Control.Lens hiding (snoc, (.>), (<.), (<<~))
|
||||||
import Data.List.Extra
|
import Data.List.Extra
|
||||||
import Data.Fix
|
import Data.Fix
|
||||||
import Data.Functor.Const
|
import Data.Functor.Const
|
||||||
|
|||||||
@@ -11,7 +11,7 @@ import Data.Functor.Const
|
|||||||
import Data.Functor
|
import Data.Functor
|
||||||
import Data.Text qualified as T
|
import Data.Text qualified as T
|
||||||
import Text.Printf
|
import Text.Printf
|
||||||
import Lens.Micro
|
import Control.Lens
|
||||||
import Rlp.Parse.Types
|
import Rlp.Parse.Types
|
||||||
import Rlp.Syntax
|
import Rlp.Syntax
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|||||||
@@ -44,8 +44,7 @@ import Data.HashMap.Strict qualified as H
|
|||||||
import Data.Void
|
import Data.Void
|
||||||
import Data.Word (Word8)
|
import Data.Word (Word8)
|
||||||
import Data.Text qualified as T
|
import Data.Text qualified as T
|
||||||
import Lens.Micro.TH
|
import Control.Lens hiding ((<<~))
|
||||||
import Lens.Micro
|
|
||||||
import Rlp.Syntax
|
import Rlp.Syntax
|
||||||
import Compiler.Types
|
import Compiler.Types
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|||||||
@@ -57,8 +57,7 @@ import Data.Functor.Identity
|
|||||||
import Data.Kind (Type)
|
import Data.Kind (Type)
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
import Language.Haskell.TH.Syntax (Lift)
|
import Language.Haskell.TH.Syntax (Lift)
|
||||||
import Lens.Micro.Pro
|
import Control.Lens
|
||||||
import Lens.Micro.Pro.TH
|
|
||||||
import Core.Syntax hiding (Lit, Type, Binding, Binding')
|
import Core.Syntax hiding (Lit, Type, Binding, Binding')
|
||||||
import Core (HasRHS(..), HasLHS(..))
|
import Core (HasRHS(..), HasLHS(..))
|
||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
|
|||||||
@@ -13,8 +13,6 @@ import Control.Monad.Utils
|
|||||||
import Control.Arrow
|
import Control.Arrow
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Comonad
|
import Control.Comonad
|
||||||
-- import Lens.Micro
|
|
||||||
-- import Lens.Micro.Internal
|
|
||||||
import Control.Lens
|
import Control.Lens
|
||||||
import Compiler.RLPC
|
import Compiler.RLPC
|
||||||
import Data.List (mapAccumL, partition)
|
import Data.List (mapAccumL, partition)
|
||||||
|
|||||||
@@ -20,8 +20,7 @@ import System.IO (Handle, hPutStr)
|
|||||||
import Text.Printf (printf, hPrintf)
|
import Text.Printf (printf, hPrintf)
|
||||||
import Data.Proxy (Proxy(..))
|
import Data.Proxy (Proxy(..))
|
||||||
import Data.Monoid (Endo(..))
|
import Data.Monoid (Endo(..))
|
||||||
import Lens.Micro
|
import Control.Lens
|
||||||
import Lens.Micro.TH
|
|
||||||
import Data.Pretty
|
import Data.Pretty
|
||||||
import Data.Heap
|
import Data.Heap
|
||||||
import Core.Examples
|
import Core.Examples
|
||||||
|
|||||||
@@ -41,6 +41,7 @@ evalArith (a ::* b) = evalArith a * evalArith b
|
|||||||
evalArith (a ::- b) = evalArith a - evalArith b
|
evalArith (a ::- b) = evalArith a - evalArith b
|
||||||
|
|
||||||
instance Arbitrary ArithExpr where
|
instance Arbitrary ArithExpr where
|
||||||
|
-- TODO: implement shrink
|
||||||
arbitrary = gen 4
|
arbitrary = gen 4
|
||||||
where
|
where
|
||||||
gen :: Int -> Gen ArithExpr
|
gen :: Int -> Gen ArithExpr
|
||||||
|
|||||||
Reference in New Issue
Block a user