├── .gitignore
├── CNAME
├── HACKING.md
├── LICENSE
├── LICENSE.MinCaml
├── MinCaml.md
├── README.md
├── bundle.js
├── dune-project
├── examples
├── ack.ml
├── echo.ml
├── fact.ml
├── fib.ml
├── gcd.ml
└── metacirc.ml
├── footer.pug
├── framework.js
├── header.pug
├── index.html
├── index.pug
├── joe.opam
├── main.css
├── package.json
├── src
├── arm64
│ ├── dune
│ ├── emit.ml
│ ├── emit.mli
│ ├── libmincaml.S
│ ├── libmincaml.c
│ ├── regAlloc.ml
│ ├── regAlloc.mli
│ └── stub.c
├── joe
│ ├── alpha.ml
│ ├── alpha.mli
│ ├── asm.ml
│ ├── asm.mli
│ ├── assoc.ml
│ ├── assoc.mli
│ ├── beta.ml
│ ├── beta.mli
│ ├── closure.ml
│ ├── closure.mli
│ ├── constFold.ml
│ ├── constFold.mli
│ ├── dune
│ ├── elim.ml
│ ├── elim.mli
│ ├── id.ml
│ ├── inline.ml
│ ├── inline.mli
│ ├── kNormal.ml
│ ├── kNormal.mli
│ ├── lexer.mll
│ ├── m.ml
│ ├── main.ml
│ ├── main.mli
│ ├── parser.mly
│ ├── s.ml
│ ├── simm.ml
│ ├── simm.mli
│ ├── syntax.ml
│ ├── type.ml
│ ├── typing.ml
│ ├── typing.mli
│ ├── unparser.ml
│ ├── unparser.mli
│ ├── util.ml
│ ├── virtual.ml
│ └── virtual.mli
├── sparc
│ └── emit.ml
├── ulc
│ └── ulc.ml
├── vm
│ ├── config.ml
│ ├── dune
│ ├── emit.ml
│ ├── emit.mli
│ ├── float.c
│ ├── insts.ml
│ ├── insts.mli
│ ├── libmincaml.c
│ ├── main.ml
│ └── vM.ml
├── x64
│ ├── dune
│ ├── emit.ml
│ ├── emit.mli
│ ├── lib.c
│ ├── libmincaml.S
│ ├── libmincaml.c
│ ├── regAlloc.ml
│ ├── regAlloc.mli
│ └── stub.c
└── x86
│ ├── dune
│ ├── emit.ml
│ ├── emit.mli
│ ├── libmincaml.S
│ └── libmincaml.c
├── styles
├── _aside.scss
├── _canvas.scss
├── _code.scss
├── _exe.scss
├── _footer.scss
├── _header.scss
├── _index.scss
├── _intro.scss
├── _list.scss
├── _om.scss
├── _resources.scss
├── _semantics.scss
├── _stack.scss
├── _status.scss
├── _types.scss
├── main.scss
└── mathjax.js
└── vm.opam
/.gitignore:
--------------------------------------------------------------------------------
1 | _build
2 | .vscode
3 | *.s
4 | *.joe
5 | *.exe
--------------------------------------------------------------------------------
/CNAME:
--------------------------------------------------------------------------------
1 | joe.groupoid.space
2 |
--------------------------------------------------------------------------------
/HACKING.md:
--------------------------------------------------------------------------------
1 | Перелік можливих завдань для виконання
2 | ======================================
3 |
4 | ВИКОНАНО 01 Зробити по прикладу PRП (Department of Mathematical
5 | and Computing Science, Tokyo Institute of Technology)
6 | свій форк MinCaml — два бінарника vm (віртуальну машину і компілятор)
7 | і joe (компілятор і бінарні бекенди Intel та ARM).
8 | Зменшити кількість опцій, зробити дефаулти і
9 | дослідіти ack.ml на граничні можливі обчислювальні
10 | координати m та n.
11 |
12 | ВИКОНАНО 02 Перекласти
13 | A Crash Course for the MinCaml Compiler. Переклад
14 | з англійської версії автора, яка отримана перекладом з японської.
15 |
16 | ВИКОНАНО 03 Імпорт бекенда для ARM64 (thata/min-caml-aarch64).
17 | В цьому бекенді інструкція проміжного асемблера Set
18 | називається Load Immediate (Li). Також ARM бекенд
19 | не містить операцій множення і ділення (замінені
20 | на виклики функцій runtime).
21 |
22 | ВИКОНАНО 04 Імпорт бекендів для x64 x86 та BAC (prg.is.titech.ac.jp).
23 | x64 бекенд не завершений, BAC бекенд не достатньо перевірений.
24 | x86 бекенд не перевірений.
25 |
26 | ВІДКРИТА 05 Бекенд для RISC-V.
27 |
28 | ВІДКРИТА 06 Не працює байт-код програми метациркулярного
29 | інтерпретатора після вводу першого числа — розміру
30 | байтів в стрічці байт-коду. Дослідити і усунути проблему.
31 |
32 | ВИКОНАНО 07 Порт на OCaml 5.0.
33 | Проблема була у префіксах імен функцій для лінкера в runtime файлах.
34 |
35 | ВІДКРИТА 08 Бекенд для Motorola 68000.
36 |
37 | ВІДКРИТА 09 Бекенд для MIPS.
38 |
39 | ВІДКРИТА 10 Бекенд для PowerPC або POWER.
40 |
41 | ВІДКРИТА 11 Бекенд для SPARC (відновити працездатність оригінального
42 | першого бекенда Ейдзіру Суміі).
43 |
44 | ВІДКРИТА 12 Бекенд для SH4.
45 |
46 | ВІДКРИТА 13 Бекенд для PDP-11.
47 |
48 | ВИКОНАНО 14 Після генерації асемблера в компіляторі joe
49 | Зробити виклик gcc через exec прямо в main модулі.
50 | Звернути увагу, що для різних бекендів можуть бути
51 | різні gcc компілятори і параметри, а для vm бекенда
52 | це взагалі непотрібно.
53 |
54 | ВІДКРИТА 15 Потрібно зменшити футпрінт бінарника joe
55 | з 35 кб до 8-12 кб хоча б (двох-трьох сторінок).
56 | Системне програмування.
57 |
58 |
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2024 Groupoid Infinity
2 |
3 | Permission to use, copy, modify, and/or distribute this software for any
4 | purpose with or without fee is hereby granted, provided that the above
5 | copyright notice and this permission notice appear in all copies.
6 |
7 | YOU CANNOT USE THIS SOFTWARE IN ANY (PROVABLE BY MONEY TRACE)
8 | PROCESS CHAIN OF EXTERMINATING UKRAINIANS BY ANY MEANS OF FASCIST
9 | ACTIONS AGAINST OUR TERRITORIAL INTEGRITY, CULTURAL DIVERSITY BY
10 | APPLYING MILITARY INVASIONS, ECONOMICAL WARS, HUMANITARIAN DISASTERS,
11 | ARTFICIAL HOLODOMORS, GENOCIDE, RAPING, LOOTING, ROBBERIES, SPREADING
12 | FAKE INFORMATION, AND OTHER CONTEMPORARY WEAPONS OF WAR AT SCALE
13 | OR IN INVIDIVUAL MANNER.
14 |
15 | YOU CANNOT USE THIS SOFTWARE BY ANY MEANS IN INTEREST OF LEGAL
16 | ENTITIES OR INDIVIDUALS WHO IS SUPPORTING NOW OR WAS SUPPORTING
17 | BACK THEN FASCISM, RUSCISM, COMMUNISM, CHAUVINISM, HUMILIATION,
18 | AND OTHER SUPPRESSIVE IDEOLOGIES IN DIFFERENT EXPRESSIONS.
19 |
20 | STOP KILLING UKRAINIANS,
21 | THE COUNTER RENDERS TENS OF MILLIONS.
22 |
23 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
24 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
25 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
26 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
27 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
28 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
29 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
30 |
--------------------------------------------------------------------------------
/LICENSE.MinCaml:
--------------------------------------------------------------------------------
1 | Copyright (c) 2005-2024 Eijiro Sumii, Moe Masuko, and Kenichi Asai
2 |
3 | Redistribution and use in source and binary forms, with or without
4 | modification, are permitted provided that the following conditions are met:
5 |
6 | - Redistributions of source code must retain the above copyright
7 | notice, this list of conditions and the following disclaimer.
8 |
9 | - Redistributions in binary form must reproduce the above copyright
10 | notice, this list of conditions and the following disclaimer in the
11 | documentation and/or other materials provided with the
12 | distribution.
13 |
14 | - Neither the name of Information-Technology Promotion Agency, the
15 | name of University of Pennsylvania, the name of University of
16 | Tokyo, the name of Tohoku University, the name of Ochanomizu
17 | University, the name of Eijiro Sumii, the name of Moe Masuko, nor
18 | the name of Kenichi Asai may be used to endorse or promote products
19 | derived from this software without specific prior written
20 | permission.
21 |
22 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
23 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
24 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
25 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
26 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
27 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
28 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
29 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
30 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
31 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
32 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
33 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | Joe: MinCaml compiler and virtual machine
2 | =========================================
3 |
4 | Features
5 | --------
6 |
7 | * 4K LOC
8 | * Intel/ARM 64-bit native compiler (joe)
9 | * Byte-code IR compiler (joe)
10 | * Byte-code IR virtual machine (vm)
11 | * Original MinCaml codebase
12 |
13 | Setup
14 | -----
15 |
16 | ```
17 | $ opam install ppx_deriving ppx_inline_test
18 | $ dune build
19 | ```
20 |
21 | Samples
22 | -------
23 |
24 | Compile sample for MinCaml bytecode:
25 |
26 | ```sh
27 | $ _build/install/default/bin/vm -compile examples/fact.ml
28 | ```
29 |
30 | Run sample from MinCaml bytecode in VM interpreter:
31 |
32 | ```sh
33 | $ _build/install/default/bin/vm -exec examples/fact.joe
34 | 10
35 | 3628800
36 | ```
37 |
38 | Compile sample for Apple M1 (from MinCaml to Assembler):
39 |
40 | ```sh
41 | $ _build/install/default/bin/joe -arm examples/ack.ml
42 | Generating assembly...OK
43 | ```
44 |
45 | Compile assembler and link for macOS:
46 |
47 | ```sh
48 | $ gcc examples/ack.arm.s src/arm64/libmincaml.c src/arm64/stub.c -o ack
49 | ```
50 |
51 | Run sample natively on M1:
52 |
53 | ```sh
54 | $ ./ack
55 | 509
56 | ```
57 |
58 | Resources
59 | ---------
60 |
61 | * Kenji Nozawa. SICP in Standard ML.
62 | * Eijiro Sumii. A Crash Course for the MinCaml compiler.
63 | * Eijiro Sumii. MinCaml: A Simple and Efficient Compiler for a Minimal Functional Language.
64 | * М. Сохацький. Інформатика.
65 | * C. Okasaki. Purely Functional Data Structures.
66 | * R. Harper. Programming in Standard ML.
67 | * Andrew W. Appel. Modern Compiler Implementation in ML.
68 | * Andreas Rossberg. HaMLet: To Be Or Not To Be Standard ML.
69 |
70 | Credits
71 | -------
72 |
73 | * Namdak Tonpa
74 |
--------------------------------------------------------------------------------
/dune-project:
--------------------------------------------------------------------------------
1 | (lang dune 2.9)
2 |
--------------------------------------------------------------------------------
/examples/ack.ml:
--------------------------------------------------------------------------------
1 | let rec ack m n =
2 | if m = 0 then n + 1 else
3 | if n = 0 then ack (m-1) 1 else ack (m-1) (ack m (n-1)) in
4 | let res = ack 3 3 in
5 | let _ = print_int res in
6 | print_newline()
7 |
--------------------------------------------------------------------------------
/examples/echo.ml:
--------------------------------------------------------------------------------
1 | print_string(read_string ())
--------------------------------------------------------------------------------
/examples/fact.ml:
--------------------------------------------------------------------------------
1 | let rec fact x = if x = 0 then 1 else mul x (fact (x-1)) in
2 | let z = read_int() in print_int (fact z);print_newline()
3 |
--------------------------------------------------------------------------------
/examples/fib.ml:
--------------------------------------------------------------------------------
1 | let rec fib n = if n <= 1 then 1 else fib(n-1) + fib(n-2) in print_int(fib (read_int()));print_newline()
2 |
--------------------------------------------------------------------------------
/examples/gcd.ml:
--------------------------------------------------------------------------------
1 | let rec gcd m n =
2 | if m <= 2 then n else
3 | if m <= n then gcd m (n-m) else
4 | gcd n (m - n) in
5 | print_int (gcd 1230 262728293)
6 |
7 |
--------------------------------------------------------------------------------
/examples/metacirc.ml:
--------------------------------------------------------------------------------
1 | let rec is_mj _ = false in
2 |
3 | let rec cast_fAII x = x in
4 | let rec cast_fIAI x = x in
5 |
6 | let rec pop stack sp = stack.(sp - 1) in
7 | let rec push stack sp v = stack.(sp) <- v in
8 |
9 | let rec interp stack sp bytecode pc =
10 | let instr = bytecode.(pc) in
11 | if instr = 0000000 then interp stack sp bytecode (pc+1)
12 | else if instr = 01 then let v2 = stack.(sp-1) in let v1 = stack.(sp-2) in stack.(sp-2) <- (v1+v2) ; interp stack (sp-1) bytecode (pc+1)
13 | else if instr = 02 then let v2 = stack.(sp-1) in let v1 = stack.(sp-2) in stack.(sp-2) <- (v1-v2) ; interp stack (sp-1) bytecode (pc+1)
14 | else if instr = 03 then let v2 = stack.(sp-1) in let v1 = stack.(sp-2) in stack.(sp-2) <- (mul v1 v2) ; interp stack (sp-1) bytecode (pc+1)
15 | else if instr = 04 then let v2 = stack.(sp-1) in let v1 = stack.(sp-2) in stack.(sp-2) <- (div v1 v2) ; interp stack (sp-1) bytecode (pc+1)
16 | else if instr = 05 then let v2 = stack.(sp-1) in let v1 = stack.(sp-2) in stack.(sp-2) <- (rem v1 v2) ; interp stack (sp-1) bytecode (pc+1)
17 | else if instr = 06 then let v1 = stack.(sp-1) in let n = (if v1 = 0 then 1 else 0) in stack.(sp-1) <- n; interp stack sp bytecode (pc+1)
18 | else if instr = 07 then let v1 = stack.(sp-1) in stack.(sp-1) <- (-v1); interp stack sp bytecode (pc+1)
19 | else if instr = 08 then let v2 = stack.(sp-1) in let v1 = stack.(sp-2) in let n = (if v1 < v2 then 1 else 0) in stack.(sp-2) <- n ; interp stack (sp-1) bytecode (pc+1)
20 | else if instr = 09 then let v1 = stack.(sp-1) in let v2 = stack.(sp-2) in let v = (if v1 > v2 then 1 else 0) in stack.(sp-2) <- v ; interp stack (sp-1) bytecode (pc+1)
21 | else if instr = 10 then let v1 = stack.(sp-1) in let v2 = stack.(sp-2) in let v = (if v1 = v2 then 1 else 0) in stack.(sp-2) <- v ; interp stack (sp-1) bytecode (pc+1)
22 | else if instr = 11 then stack.(sp-1)
23 | else if instr = 12 then let addr = bytecode.(pc+1) in let v = stack.(sp-1) in let sp2 = sp - 1 in if v = 0 then (interp stack sp2 bytecode addr) else interp stack sp2 bytecode (pc + 2)
24 | else if instr = 13 then let addr = bytecode.(pc+1) in interp stack sp bytecode addr
25 | else if instr = 14 then let addr = bytecode.(pc+1) in let rands = bytecode.(pc+2) in
26 | (stack.(sp) <- 200 ; (* push jit flag *) stack.(sp+1) <- pc+3 ; interp stack (sp+2) bytecode addr)
27 | else if instr = 16 then let n = bytecode.(pc+1) in let v = stack.(sp-n-1) in stack.(sp) <- v ; interp stack (sp+1) bytecode (pc+2)
28 | else if instr = 17 then let v = stack.(sp-1) in stack.(sp) <- v ; interp stack (sp+1) bytecode (pc+1)
29 | else if instr = 18 then let v = stack.(sp-1) in let _ = stack.(sp-2) in stack.(sp-2) <- v ; interp stack (sp-1) bytecode (pc+1)
30 | else if instr = 19 then let _ = stack.(sp-1) in interp stack (sp-1) bytecode (pc+1)
31 | else if instr = 20 then (stack.(sp) <- 0 ; interp stack (sp+1) bytecode (pc+1))
32 | else if instr = 21 then let c = bytecode.(pc+1) in stack.(sp) <- c; interp stack (sp+1) bytecode (pc+2)
33 | else if instr = 22 then let n = stack.(sp-1) in let arr = cast_fIAI(stack.(sp-2)) in stack.(sp-2) <- arr.(n); interp stack (sp-1) bytecode (pc+1)
34 | else if instr = 23 then let i = stack.(sp-1) in let arr = cast_fIAI(stack.(sp-2)) in let n = stack.(sp-3) in arr.(i) <- n; stack.(sp-3) <- cast_fAII(arr); interp stack (sp-2) bytecode (pc+1)
35 | else if instr = 24 then let init = stack.(sp-1) in let size = stack.(sp-2) in let a = Array.make size init in stack.(sp-2) <- cast_fAII(a); interp stack (sp-1) bytecode (pc+1)
36 | else if instr = 26 then interp stack sp bytecode (pc+1)
37 | else if instr = 28 then let n = read_int () in stack.(sp) <- n ; interp stack (sp+1) bytecode (pc+1)
38 | else if instr = 30 then let v = stack.(sp-1) in print_int v ; interp stack (sp-1) bytecode (pc+1)
39 | else if instr = 31 then let _ = print_newline() in interp stack sp bytecode (pc+1)
40 | (* else if instr = 32 then let v = stack.(sp-1) in print_string v ; interp stack (sp-1) bytecode (pc+1) *)
41 | else -1000 in
42 |
43 | let stk = Array.make 20000 (-987) in
44 | let n = read_int () in
45 | let rec read_code i n arr = if i = n then arr else ((cast_fIAI arr).(i) <- read_int (); read_code (i+1) n arr) in
46 | let code = read_code 0 n (cast_fAII(Array.make n 0)) in
47 | let _ = (interp stk 1 (cast_fIAI code) 0) in
48 | print_newline ()
49 |
--------------------------------------------------------------------------------
/footer.pug:
--------------------------------------------------------------------------------
1 | link(rel='stylesheet' href='https://groupoid.space/main.css')
2 |
3 | footer.footer
4 | a(href='https://5HT.co/license/')
5 | img.footer__logo(src='https://longchenpa.guru/seal.png',width=50)
6 | span.footer__copy 2016—2025 © Namdak Tönpa
7 | script(src='https://groupoid.space/highlight.js?v=1')
8 | script(src='https://groupoid.space/bundle.js')
9 |
--------------------------------------------------------------------------------
/framework.js:
--------------------------------------------------------------------------------
1 | // Mixin usages in PUG:
2 |
3 | // +tex(false, false).
4 | // $\mathbf{Definition}$ (Space of Sections). Let $\mathbf{H}$ be
5 | // a $(\infty,1)$-topos, and let $E \rightarrow B : \mathbf{H}_{/B}$ a bundle in
6 | // $\mathbf{H}$, object in the slice topos. Then the space of sections $\Gamma_\Sigma(E)$
7 | // of this bundle is the Dependent Product.
8 |
9 | // +tex(true, false).
10 | // $$
11 | // \Gamma_\Sigma(E) = \Pi_\Sigma (E) \in \mathbf{H}.
12 | // $$
13 |
14 | // +code.
15 | // def Pi (A : U) (B : A → U) : U := Π (x : A), B x
16 |
17 | const {mathjax} = require('mathjax-full/js/mathjax.js');
18 | const {TeX} = require('mathjax-full/js/input/tex.js');
19 | const {SVG} = require('mathjax-full/js/output/svg.js');
20 | const {liteAdaptor} = require('mathjax-full/js/adaptors/liteAdaptor.js');
21 | const {RegisterHTMLHandler} = require('mathjax-full/js/handlers/html.js');
22 | const {AssistiveMmlHandler} = require('mathjax-full/js/a11y/assistive-mml.js');
23 | const {AllPackages} = require('mathjax-full/js/input/tex/AllPackages.js');
24 |
25 | const adaptor = liteAdaptor();
26 | const handler = RegisterHTMLHandler(adaptor);
27 |
28 | const tex = new TeX({
29 | packages: ['base', 'autoload', 'require', 'ams', 'amscd', 'newcommand', 'configmacros'],
30 | inlineMath: [ ["$", "$"] ],
31 | macros: { // Plug your Glyphs here
32 | llparenthesis: '\\mathopen{\u2987}',
33 | rrparenthesis: '\\mathclose{\u2988}',
34 | llbracket: '\\mathopen{\u27E6}',
35 | rrbracket: '\\mathclose{\u27E7}',
36 | incmap: '\\mathclose{\u21AA}',
37 | meet: '\\mathopen{\u2227}',
38 | map: '\\mathopen{\u21A6}',
39 | join: '\\mathopen{\u2228}',
40 | trans: '\\, \\mathbin{\\vcenter{\\rule{.3ex}{.3ex}}} \\,',
41 | mapright: ['\\xrightarrow{{#1}}', 1],
42 | mapdown: ['\\Big\\downarrow\\rlap{\\raise2pt{\\scriptstyle{#1}}}', 1],
43 | mapdiagl: ['\\vcenter{\\searrow}\\rlap{\\raise2pt{\\scriptstyle{#1}}}', 1],
44 | mapdiagr: ['\\vcenter{\\swarrow}\\rlap{\\raise2pt{\\scriptstyle{#1}}}', 1],
45 | }
46 | });
47 |
48 | tex.postFilters.add(({math, data}) => {
49 | if (!data.error) return;
50 | data.root.walkTree((node) => {
51 | if (node.isKind('merror')) {
52 | console.log('TeX error:\n ' + node.attributes.get('data-mjx-error'));
53 | }
54 | });
55 | });
56 |
57 | const svg = new SVG({fontCache: 'local'});
58 |
59 | function renderPug(block) {
60 | var recv; with({pug_html: ""}){
61 | eval(`(${block})();`); recv = pug_html;
62 | }; return recv
63 | }
64 |
65 | function renderTeX(formulae) {
66 | return adaptor.innerHTML(mathjax.document(formulae, {
67 | InputJax: tex, OutputJax: svg
68 | }).render().document.body);
69 | }
70 |
71 | exports.tex = function (block) {
72 | return renderTeX(renderPug(block));
73 | }
74 |
75 | exports.highlight = function (block) {
76 | return renderPug(block)
77 | .replace(/([(){}→=]+|:|:=)/g,
78 | '$1')
79 | .replace(/\b(∀|Π|Σ|W|λ|glue|unglue|Glue|transp|hcomp|where|def|begin|end|module|import|option|false|true|indᵂ|sup|.1|.2|𝟎|𝟏|𝟐|ind₂|ind₁|ind₀|★|0₂|1₂|PathP|PartialP|inc|ouc|axiom|theorem|lemdata|ma|U|V)\b(?!:)/g,
80 | '$1');
81 | }
82 |
--------------------------------------------------------------------------------
/header.pug:
--------------------------------------------------------------------------------
1 | mixin tex(center=false, paragraph=true)
2 | if paragraph
3 | p(style=center ? {'text-align': 'center' } : null)!= tex(`${block}`)
4 | else
5 | span(style=center ? {
6 | 'text-align': 'center',
7 | 'display': 'block',
8 | 'padding-top': '8px',
9 | 'padding-bottom': '8px',
10 | } : null)!= tex(`${block}`)
11 |
12 | mixin tex2(center=false, paragraph=true)
13 | p(style=center ? {
14 | 'text-align': 'center',
15 | 'display': 'block',
16 | 'padding-top': '8px',
17 | 'padding-bottom': '8px',
18 | } : null)!= tex(`${block}`)
19 |
20 | mixin code
21 | code!= highlight(`${block}`)
22 |
23 | mixin header(logo, title, subtitle)
24 | header.header
25 | .header__titles
26 | h1.header__title!= title
27 | h4.header__subtitle!= subtitle
28 |
29 | doctype html
30 | html
31 | head
32 | meta(charset='utf-8')
33 | meta(http-equiv='x-ua-compatible' content='ie=edge')
34 | meta(property='fb:app_id' content='118554188236439')
35 | meta(name='viewport' content='width=device-width, initial-scale=1')
36 | meta(name='author' content='Maxim Sokhatsky')
37 | meta(name='twitter:site' content='@5HT')
38 | meta(name='twitter:creator' content='@5HT')
39 | meta(property='og:type' content='website')
40 | meta(property='og:image' content='https://avatars.githubusercontent.com/u/17128096?s=400&u=66a63d4cdd9625b2b4b37d724cc00fe6401e5bd8&v=4')
41 | meta(name='msapplication-TileColor' content='#ffffff')
42 | meta(name='msapplication-TileImage' content='https://anders.groupoid.space/images/ms-icon-144x144.png')
43 | meta(name='theme-color' content='#ffffff')
44 |
45 | link(rel='stylesheet' href='https://anders.groupoid.space/main.css?v=1')
46 | link(rel='apple-touch-icon' sizes='57x57' href='https://anders.groupoid.space/images/apple-icon-57x57.png')
47 | link(rel='apple-touch-icon' sizes='60x60' href='https://anders.groupoid.space/images/apple-icon-60x60.png')
48 | link(rel='apple-touch-icon' sizes='72x72' href='https://anders.groupoid.space/images/apple-icon-72x72.png')
49 | link(rel='apple-touch-icon' sizes='76x76' href='https://anders.groupoid.space/images/apple-icon-76x76.png')
50 | link(rel='apple-touch-icon' sizes='114x114' href='https://anders.groupoid.space/images/apple-icon-114x114.png')
51 | link(rel='apple-touch-icon' sizes='120x120' href='https://anders.groupoid.space/images/apple-icon-120x120.png')
52 | link(rel='apple-touch-icon' sizes='144x144' href='https://anders.groupoid.space/images/apple-icon-144x144.png')
53 | link(rel='apple-touch-icon' sizes='152x152' href='https://anders.groupoid.space/images/apple-icon-152x152.png')
54 | link(rel='apple-touch-icon' sizes='180x180' href='https://anders.groupoid.space/images//apple-icon-180x180.png')
55 | link(rel='icon' type='image/png' sizes='192x192' href='https://anders.groupoid.space/images/android-icon-192x192.png')
56 | link(rel='icon' type='image/png' sizes='32x32' href='https://anders.groupoid.space/images/favicon-32x32.png')
57 | link(rel='icon' type='image/png' sizes='96x96' href='https://anders.groupoid.space/images/favicon-96x96.png')
58 | link(rel='icon' type='image/png' sizes='16x16' href='https://anders.groupoid.space/images/favicon-16x16.png')
59 | link(rel='manifest' href='https://anders.groupoid.space/images/manifest.json')
60 |
61 | style.
62 | svg a{fill:blue;stroke:blue}
63 | [data-mml-node="merror"]>g{fill:red;stroke:red}
64 | [data-mml-node="merror"]>rect[data-background]{fill:yellow;stroke:none}
65 | [data-frame],[data-line]{stroke-width:70px;fill:none}
66 | .mjx-dashed{stroke-dasharray:140}
67 | .mjx-dotted{stroke-linecap:round;stroke-dasharray:0,140}
68 | use[data-c]{stroke-width:3px}
69 |
70 | body.content
71 | block vars
72 | block content
73 |
--------------------------------------------------------------------------------
/index.pug:
--------------------------------------------------------------------------------
1 | include header
2 |
3 | html
4 | head
5 | meta(property='og:title' content='Joe')
6 | meta(property='og:description' content='Чиста нетипізована мова для декартово-замкнених категорій')
7 | meta(property='og:url' content='https://joe.groupoid.space/')
8 |
9 | block title
10 | title JOE
11 |
12 | block content
13 | +header('', 'Joe', 'Мінімальна мова для послідовних обчислень в декартово-замкнених категоріях')
14 | article.main
15 | .exe
16 | section
17 | h1 Анотація
18 | aside Намдак Тонпа
19 | time ДАТА: 10 ЖОВТНЯ 2016
20 | section
21 | +tex.
22 | Мова програмування $\mathbf{Joe}$ — це чиста нетипізована мова, що є внутрішньою мовою декартово-замкнених категорій. Вона базується на лямбда-численні, розширеному парами, проєкціями та термінальним об’єктом, забезпечуючи мінімальну модель для обчислень у категорійному контексті.
23 |
24 | .semantics
25 | section
26 | h2#ast Синтаксис
27 | +tex.
28 | Терми $\mathbf{Joe}$ складаються зі змінних, лямбда-абстракцій, застосувань, пар, проєкцій (першої та другої) та термінального об’єкта. Це мінімальна мова, що підтримує обчислення через бета-редукцію та проєкції.
29 | code.
30 | I = #identifier
31 | O = I | ( O ) | O O | λ I -> O | O , O | O.1 | O.2 | 1
32 | br.
33 | code.
34 | type term =
35 | | Var of string
36 | | Lam of string * term
37 | | App of term * term
38 | | Pair of term * term
39 | | Fst of term
40 | | Snd of term
41 | | Unit
42 | br.
43 |
44 | h2#rules Правила обчислень
45 | +tex.
46 | Основними правилами обчислень у $\mathbf{Joe}$ є бета-редукція для лямбда-абстракцій та правила проєкцій для пар. Термінальний об’єкт є незвідним.
47 | code.
48 | App (Lam (x, b), a) → subst x a b
49 | Fst (Pair (t1, t2)) → t1
50 | Snd (Pair (t1, t2)) → t2
51 | br.
52 | +tex(true).
53 | $$
54 | \begin{align}
55 | \tag{$\beta$-reduction}
56 | \dfrac
57 | {(\lambda x . b)\ a}
58 | {b [a/x]} \\
59 | \tag{proj-1}
60 | \dfrac
61 | {\text{fst}\ \langle t_1, t_2 \rangle}
62 | {t_1} \\
63 | \tag{proj-2}
64 | \dfrac
65 | {\text{snd}\ \langle t_1, t_2 \rangle}
66 | {t_2}
67 | \end{align}
68 | $$
69 |
70 | h2 Підстановка
71 | code.
72 | let rec subst x s = function
73 | | Var y -> if x = y then s else Var y
74 | | Lam (y, t) when x <> y -> Lam (y, subst x s t)
75 | | App (f, a) -> App (subst x s f, subst x s a)
76 | | Pair (t1, t2) -> Pair (subst x s t1, subst x s t2)
77 | | Fst t -> Fst (subst x s t)
78 | | Snd t -> Snd (subst x s t)
79 | | Unit -> Unit
80 | | t -> t
81 | br.
82 |
83 | h2 Рівність
84 | code.
85 | let rec equal t1 t2 =
86 | match t1, t2 with
87 | | Var x, Var y -> x = y
88 | | Lam (x, b), Lam (y, b') -> equal b (subst y (Var x) b')
89 | | Lam (x, b), t -> equal b (App (t, Var x))
90 | | t, Lam (x, b) -> equal (App (t, Var x)) b
91 | | App (f1, a1), App (f2, a2) -> equal f1 f2 && equal a1 a2
92 | | Pair (t1, t2), Pair (t1', t2') -> equal t1 t1' && equal t2 t2'
93 | | Fst t, Fst t' -> equal t t'
94 | | Snd t, Snd t' -> equal t t'
95 | | Unit, Unit -> true
96 | | _ -> false
97 | br.
98 |
99 | h2 Редукція
100 | code.
101 | let rec reduce = function
102 | | App (Lam (x, b), a) -> subst x a b
103 | | App (f, a) -> App (reduce f, reduce a)
104 | | Pair (t1, t2) -> Pair (reduce t1, reduce t2)
105 | | Fst (Pair (t1, t2)) -> t1
106 | | Fst t -> Fst (reduce t)
107 | | Snd (Pair (t1, t2)) -> t2
108 | | Snd t -> Snd (reduce t)
109 | | Unit -> Unit
110 | | t -> t
111 | br.
112 |
113 | h2 Нормалізація
114 | code.
115 | let rec normalize t =
116 | let t' = reduce t in
117 | if equal t t' then t else normalize t'
118 | br.
119 |
120 | h2 Внутрішня мова ДЗК
121 | +tex.
122 | Мова $\mathbf{Joe}$ є внутрішньою мовою декартово-замкненої категорії (ДЗК).
123 | Вона включає лямбда-абстракції та застосування для замкнутої структури,
124 | пари та проєкції для декартового добутку, а також термінальний об’єкт для
125 | відновлення повної структури ДЗК.
126 |
127 | section
128 | h1 Бібліографія
129 | p(style="font-size:16px;").
130 | [1]. Alonzo Church. A Set of Postulates for the Foundation of Logic. 1933
131 | [2]. Alonzo Church. An Unsolvable Problem of Elementary Number Theory. 1941
132 | [3]. Haskell Curry, Robert Fey. Combinatory Logic, Volume I. 1951
133 | [4]. Dana Scott. A Type-Free Theory of Lambda Calculus. 1970
134 | [5]. John Reynolds. Towards a Theory of Type Structure. 1974
135 | [6]. Henk Barendregt. The Lambda Calculus: Its Syntax and Semantics. 1984
136 | [7]. G.Cousineau, P.-L.Curien, M.Mauny. The Categorical Abstract Machine. 1985
137 |
138 | include footer
139 |
--------------------------------------------------------------------------------
/joe.opam:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/groupoid/joe/4bbf1a33ef17e076df3bac47fe32e5604243b2d5/joe.opam
--------------------------------------------------------------------------------
/main.css:
--------------------------------------------------------------------------------
1 | @font-face {
2 | font-family: 'local';
3 | src: url("https://groupoid.space/Geometria-Light.otf");
4 | font-weight: normal;
5 | font-style: normal; }
6 |
7 | .MathJax_Display {
8 | overflow-x: auto;
9 | overflow-y: hidden; }
10 |
11 | nav a {
12 | font-size: 18px;
13 | border: 2px solid #dedede;
14 | background-color: white;
15 | color: lightblue;
16 | text-decoration: none;
17 | margin: 5px 5px;
18 | padding: 7px 12px;
19 | min-width: 150px;
20 | text-align: center; }
21 |
22 | nav a:visited {
23 | color: lightblue; }
24 |
25 | nav a:hover {
26 | border-bottom: 2px solid #00b8cf; }
27 |
28 | nav {
29 | display: flex;
30 | background-color: #FBFBFB;
31 | flex-direction: row;
32 | justify-content: center; }
33 |
34 | nav a {
35 | font-size: 18px;
36 | min-width: initial; }
37 |
38 | * {
39 | margin: 0;
40 | padding: 0;
41 | box-sizing: border-box; }
42 |
43 | sub,
44 | sup {
45 | font-size: 80%;
46 | line-height: 0;
47 | position: relative;
48 | vertical-align: baseline; }
49 |
50 | sub {
51 | bottom: -0.25em; }
52 |
53 | sup {
54 | top: -0.5em; }
55 |
56 | html {
57 | height: 100%; }
58 |
59 | body {
60 | min-height: 100%;
61 | text-rendering: optimizeLegibility;
62 | -webkit-font-smoothing: antialiased; }
63 |
64 | h1, h2, h3, h4 {
65 | font-weight: normal; }
66 |
67 | ul {
68 | list-style-type: none; }
69 |
70 | ol,
71 | ul {
72 | text-align: left;
73 | line-height: 1.5; }
74 |
75 | img, figure {
76 | vertical-align: middle; }
77 |
78 | img {
79 | margin-left: 20px; }
80 |
81 | .content {
82 | min-height: 100%;
83 | font-family: local;
84 | display: flex;
85 | flex-direction: column;
86 | position: relative; }
87 |
88 | .main {
89 | color: #586E75;
90 | background: #FBFBFB;
91 | padding: 50px 0px;
92 | text-align: center;
93 | box-shadow: 0 3px 10px rgba(0, 0, 0, 0);
94 | z-index: 5;
95 | flex: 1 1 auto; }
96 |
97 | figure {
98 | min-width: 300px;
99 | overflow-x: auto;
100 | padding: 10px 2px;
101 | font-size: 18px;
102 | display: block; }
103 |
104 | figure::after {
105 | content: "\A";
106 | white-space: pre; }
107 |
108 | h2 {
109 | font-size: 24px;
110 | color: #268BD2;
111 | margin: 34px 0 8px; }
112 | @media (min-width: 768px) {
113 | h2 {
114 | font-size: 32px; } }
115 |
116 | h3 {
117 | max-width: 100%;
118 | margin: 16px auto 0;
119 | padding: 0 0 0 8px;
120 | text-transform: uppercase;
121 | text-align: left;
122 | font-size: 22px; }
123 |
124 | p {
125 | max-width: 100%;
126 | width: 650px;
127 | margin: auto;
128 | padding: 8px;
129 | text-align: left;
130 | font-size: 18px;
131 | line-height: 1.4; }
132 | @media (min-width: 768px) {
133 | p {
134 | font-size: 22px; } }
135 |
136 | p:hover {
137 | background: white; }
138 |
139 | mark {
140 | background: #FDF6E3;
141 | padding: 0px 2px;
142 | border-radius: 2px;
143 | color: #586E75; }
144 |
145 | a {
146 | color: #3A98C8;
147 | text-decoration: none; }
148 | a:visited {
149 | color: #3A98C8; }
150 | a:hover {
151 | color: #D33682; }
152 | a:active {
153 | color: #D33682; }
154 |
155 | aside {
156 | max-width: 650px;
157 | margin: auto;
158 | padding: 8px;
159 | font-size: 20px;
160 | text-align: right; }
161 | aside time, aside div {
162 | margin-bottom: 20px;
163 | display: block; }
164 |
165 | .header {
166 | background: black;
167 | color: white;
168 | position: relative;
169 | min-height: 450px;
170 | padding: 16px 8px;
171 | display: flex;
172 | text-align: center;
173 | flex-direction: column;
174 | justify-content: center;
175 | align-items: center;
176 | width: 100%;
177 | z-index: 5; }
178 | .header__logo {
179 | width: 130px;
180 | position: relative; }
181 | .header__titles {
182 | position: relative;
183 | max-width: 800px;
184 | margin: 20px;
185 | text-shadow: 1px 1px 7px #56CCF2; }
186 | .header__title {
187 | font-size: 48px;
188 | line-height: 1.1; }
189 | .header__subtitle {
190 | font-size: 22px; }
191 | @media (min-width: 768px) {
192 | .header {
193 | flex-direction: row; }
194 | .header__logo {
195 | width: 160px;
196 | margin-right: 10px; }
197 | .header__title {
198 | font-size: 60px; }
199 | .header__subtitle {
200 | font-size: 30px; } }
201 |
202 | .footer {
203 | width: 100%;
204 | padding: 15px;
205 | background: #7F8C8D;
206 | color: white;
207 | text-align: center; }
208 | .footer__logo {
209 | width: 50px;
210 | margin: 20px; }
211 | .footer__copy {
212 | font-size: 16px;
213 | white-space: pre; }
214 | @media (min-width: 768px) {
215 | .footer__copy {
216 | font-size: 24px; } }
217 |
218 | .semantics {
219 | text-align: center; }
220 | .semantics figure {
221 | display: inline-block;
222 | max-width: min-content;
223 | font-size: 13px; }
224 | @media (min-width: 800px) {
225 | .semantics figure {
226 | font-size: 16px; } }
227 | .semantics h1 {
228 | color: #7D8A96;
229 | font-size: 32px;
230 | text-transform: uppercase;
231 | border-bottom: 1px solid rgba(0, 0, 0, 0.3);
232 | display: inline-block;
233 | margin-bottom: 8px; }
234 | .semantics section {
235 | margin-top: 40px; }
236 |
237 | .intro {
238 | width: 650px;
239 | max-width: 100%;
240 | margin: auto; }
241 |
242 | .status {
243 | text-align: left;
244 | display: inline-block;
245 | padding-left: 32px; }
246 | .status ol {
247 | line-height: 1.5;
248 | font-size: 18px; }
249 | @media (min-width: 768px) {
250 | .status ol {
251 | font-size: 22px; } }
252 |
253 | .resources {
254 | max-width: 650px;
255 | margin: 32px auto 0;
256 | text-align: left;
257 | padding: 8px; }
258 | .resources__title {
259 | display: inline-block;
260 | margin-bottom: 10px;
261 | color: #7D8A96;
262 | font-size: 32px;
263 | text-transform: uppercase;
264 | border-bottom: 1px solid rgba(0, 0, 0, 0.3); }
265 | @media (min-width: 768px) {
266 | .resources__title {
267 | font-size: 40px; } }
268 | .resources__list {
269 | padding-left: 32px;
270 | line-height: 1.5;
271 | font-size: 18px; }
272 | @media (min-width: 768px) {
273 | .resources__list {
274 | font-size: 22px; } }
275 |
276 | .index {
277 | max-width: 900px;
278 | margin: auto;
279 | padding: 20px 0;
280 | display: flex;
281 | flex-wrap: wrap;
282 | justify-content: center; }
283 | .index__col {
284 | white-space: nowrap;
285 | padding: 15px 25px;
286 | margin: 15px;
287 | background: #fefefe;
288 | box-shadow: 0 1px 4px rgba(0, 0, 100, 0.1), inset 0 0 0 1px rgba(0, 0, 0, 0.1);
289 | transition: box-shadow 0.5s cubic-bezier(0.23, 1, 0.32, 1); }
290 | .index__col:hover {
291 | box-shadow: 0 8px 40px rgba(0, 0, 100, 0.15), inset 0 0 0 1px rgba(0, 0, 0, 0.1); }
292 | .index a {
293 | line-height: 1.5;
294 | color: #888;
295 | font-size: 24px; }
296 | .index a[href^="#"] {
297 | color: #BBBBBB; }
298 | .index a:hover {
299 | color: #3A98C8; }
300 | .index a[href^="#"]:hover {
301 | color: #BBBBBB; }
302 | .index h2 {
303 | font-size: 24px;
304 | text-align: left;
305 | color: #707070;
306 | margin: 0 0 10px;
307 | text-transform: uppercase; }
308 |
309 | .om figure {
310 | max-width: inherit; }
311 |
312 | .om section h1 {
313 | margin-top: 50px; }
314 |
315 | .om h1 {
316 | color: #7D8A96;
317 | font-size: 32px;
318 | text-transform: uppercase;
319 | border-bottom: 1px solid rgba(0, 0, 0, 0.3);
320 | display: inline-block;
321 | margin-bottom: 32px; }
322 | @media (min-width: 768px) {
323 | .om h1 {
324 | font-size: 40px; } }
325 |
326 | .om h1 + h2 {
327 | margin-top: 20px; }
328 |
329 | .om h3 {
330 | max-width: 100%;
331 | margin: auto;
332 | width: 600px;
333 | padding: 16px 8px 0; }
334 |
335 | .exe figure {
336 | max-width: inherit; }
337 |
338 | .exe h1 {
339 | color: #7D8A96;
340 | font-size: 32px;
341 | text-transform: uppercase;
342 | border-bottom: 1px solid rgba(0, 0, 0, 0.3);
343 | display: inline-block;
344 | margin: 42px 0 10px; }
345 | @media (min-width: 768px) {
346 | .exe h1 {
347 | font-size: 40px; } }
348 |
349 | .exe h1 + h2 {
350 | margin-top: 0px; }
351 |
352 | .macro {
353 | margin: 0 auto;
354 | display: flex;
355 | justify-content: space-around;
356 | max-width: 600px;
357 | flex-wrap: wrap;
358 | width: 100%; }
359 | .macro__col {
360 | padding-left: 24px;
361 | line-height: 1.5;
362 | font-size: 14px; }
363 | .macro__col h3 {
364 | padding: 0;
365 | width: initial; }
366 | @media (min-width: 768px) {
367 | .macro__col {
368 | font-size: 22px; } }
369 |
370 | @media (min-width: 920px) {
371 | .langf {
372 | display: flex;
373 | flex-direction: row;
374 | justify-content: center; } }
375 |
376 | .langf ol {
377 | display: inline-block;
378 | max-width: 650px;
379 | margin: auto;
380 | font-size: 20px;
381 | padding-left: 36px; }
382 |
383 | @media (min-width: 920px) {
384 | .langf__col .langf-col:last-child {
385 | white-space: pre;
386 | margin-left: 20px; } }
387 |
388 | .types {
389 | display: inline-block;
390 | text-align: left;
391 | max-width: 100%;
392 | padding: 0 8px; }
393 | .types h1 {
394 | color: #7D8A96;
395 | font-size: 32px;
396 | text-transform: uppercase;
397 | border-bottom: 1px solid rgba(0, 0, 0, 0.3);
398 | display: inline-block;
399 | margin: 42px 0 10px; }
400 | @media (min-width: 768px) {
401 | .types h1 {
402 | font-size: 40px; } }
403 | .types section {
404 | max-width: 100%; }
405 | .types p {
406 | margin: 0;
407 | padding-left: 0; }
408 | .types h1 + h2 {
409 | margin-top: 0px; }
410 | .types .type {
411 | max-width: 660px;
412 | display: flex;
413 | flex-flow: row wrap; }
414 | .types .type__col {
415 | padding-left: 22px;
416 | flex: 1 0 15%; }
417 | .types .type__col h3 {
418 | width: initial;
419 | padding: 0;
420 | margin: 0; }
421 | @media (min-width: 600px) {
422 | .types .type__col {
423 | padding-right: 22px;
424 | flex: 1 0 15%;
425 | font-size: 20px; } }
426 | .types .legend {
427 | margin: 20px auto 0;
428 | display: inline-block;
429 | padding: 10px 20px;
430 | font-size: 24px;
431 | background: #FDF6E3;
432 | border-radius: 4px;
433 | box-shadow: 0 4px 6px rgba(50, 50, 93, 0.11), 0 1px 3px rgba(0, 0, 0, 0.08); }
434 |
435 | .list h1 {
436 | color: #7D8A96;
437 | font-size: 32px;
438 | text-transform: uppercase;
439 | border-bottom: 1px solid rgba(0, 0, 0, 0.3);
440 | display: inline-block;
441 | margin: 42px 8px 10px; }
442 | @media (min-width: 768px) {
443 | .list h1 {
444 | font-size: 40px; } }
445 |
446 | code {
447 | display: inline-block;
448 | overflow-x: auto;
449 | max-width: 100%;
450 | padding: 12px;
451 | margin: 8px 0;
452 | white-space: pre;
453 | text-align: left;
454 | border-radius: 4px;
455 | font-size: 14px;
456 | color: #00259c;
457 | background: white;
458 | box-shadow: 0 1px 4px #f1f0f0, inset 0 0 0 1px #e7e6e5; }
459 | @media (min-width: 768px) {
460 | code {
461 | font-size: 17px; } }
462 |
463 | pre {
464 | white-space: normal;
465 | max-width: 100%;
466 | width: 650px;
467 | padding: 12px;
468 | margin: 8px auto;
469 | text-align: left;
470 | border-radius: 4px;
471 | font-size: 14px;
472 | color: #00259c;
473 | background: white;
474 | box-shadow: 0 1px 4px #f1f0f0, inset 0 0 0 1px #e7e6e5; }
475 | @media (min-width: 768px) {
476 | pre {
477 | font-size: 17px; } }
478 |
479 | .h__name {
480 | color: #00259c;
481 | font-weight: bold; }
482 |
483 | .h__keyword {
484 | color: #ca30d4; }
485 |
486 | .h__symbol {
487 | color: #9f9fa3; }
488 |
489 | canvas {
490 | max-width: 100%;
491 | position: absolute;
492 | z-index: -10; }
493 |
494 | .stack {
495 | margin: auto;
496 | max-width: 100%;
497 | border-spacing: 10px;
498 | color: #282828;
499 | font-size: 20px; }
500 | .stack td {
501 | background-color: #fff9a6;
502 | padding: 4px;
503 | outline: 1px solid rgba(0, 0, 0, 0.3); }
504 | .stack th {
505 | padding: 4px;
506 | text-align: left;
507 | font-weight: normal; }
508 | .stack .empty {
509 | background-color: inherit;
510 | outline: inherit; }
511 |
512 | @media (max-width: 600px) {
513 | .stack {
514 | font-size: 16px;
515 | display: inline-block;
516 | border-spacing: 0; }
517 | .stack tbody {
518 | display: block; }
519 | .stack tr {
520 | display: block;
521 | text-align: left;
522 | vertical-align: top;
523 | position: relative; }
524 | .stack td {
525 | margin: 30px 0 10px;
526 | text-align: center;
527 | padding: 4px;
528 | display: inline-block;
529 | width: 90px; }
530 | .stack td[colspan="4"] {
531 | width: 360px; }
532 | .stack td[colspan="2"] {
533 | width: 180px; }
534 | .stack th {
535 | position: absolute;
536 | top: 0;
537 | width: 100%; } }
538 |
539 | @media (max-width: 320px) {
540 | .stack {
541 | font-size: 12px; }
542 | .stack td {
543 | margin: 20px 0 5px;
544 | width: 80px; }
545 | .stack td[colspan="4"] {
546 | width: 320px; }
547 | .stack td[colspan="2"] {
548 | width: 160px; } }
549 |
--------------------------------------------------------------------------------
/package.json:
--------------------------------------------------------------------------------
1 | {
2 | "name": "bob",
3 | "version": "1.0.1",
4 | "description": "Groupoid Infinity Institute",
5 | "main": "",
6 | "scripts": {
7 | "start": "node-sass ./styles -o ./ && pug -O ./framework.js index.pug ",
8 | "test": "echo \"Error: no test specified\" && exit 1"
9 | },
10 | "repository": {
11 | "type": "git",
12 | "url": "https://github.com/groupoid/bob"
13 | },
14 | "author": "Namdak Tonpa",
15 | "license": "DHARMA",
16 | "preinstall": "npm i -g node-sass && npm i -g pug-cli",
17 | "dependencies": {
18 | "mathjax-full": "^3.2.0",
19 | "npm": "^8.12.1",
20 | "pug": "^3.0.2",
21 | "pug-cli": "^1.0.0-alpha6",
22 | "sass": "^1.52.2"
23 | },
24 | "devDependencies": {
25 | "node-sass": "^7.0.3"
26 | }
27 | }
28 |
--------------------------------------------------------------------------------
/src/arm64/dune:
--------------------------------------------------------------------------------
1 | (library
2 | (name arm64)
3 | (public_name joe.arm64)
4 | (flags (-w -4-33-40-41))
5 | (libraries str MinCaml)
6 | (foreign_stubs (language c) (names libmincaml))
7 | (preprocess (pps ppx_deriving.show)))
8 |
--------------------------------------------------------------------------------
/src/arm64/emit.mli:
--------------------------------------------------------------------------------
1 | open MinCaml
2 |
3 | val f : out_channel -> Asm.prog -> unit
4 |
--------------------------------------------------------------------------------
/src/arm64/libmincaml.S:
--------------------------------------------------------------------------------
1 | .section __TEXT,__text,regular,pure_instructions
2 | .build_version macos, 12, 0 sdk_version 13, 1
3 | .globl min_caml_print_int ; -- Begin function min_caml_print_int
4 | .p2align 2
5 | min_caml_print_int: ; @"\01min_caml_print_int"
6 | .cfi_startproc
7 | ; %bb.0:
8 | sub sp, sp, #32
9 | stp x29, x30, [sp, #16] ; 16-byte Folded Spill
10 | add x29, sp, #16
11 | .cfi_def_cfa w29, 16
12 | .cfi_offset w30, -8
13 | .cfi_offset w29, -16
14 | str x0, [sp, #8]
15 | ldr x8, [sp, #8]
16 | mov x9, sp
17 | str x8, [x9]
18 | adrp x0, l_.str@PAGE
19 | add x0, x0, l_.str@PAGEOFF
20 | bl _printf
21 | ldp x29, x30, [sp, #16] ; 16-byte Folded Reload
22 | add sp, sp, #32
23 | ret
24 | .cfi_endproc
25 | ; -- End function
26 | .globl min_caml_print_newline ; -- Begin function min_caml_print_newline
27 | .p2align 2
28 | min_caml_print_newline: ; @"\01min_caml_print_newline"
29 | .cfi_startproc
30 | ; %bb.0:
31 | stp x29, x30, [sp, #-16]! ; 16-byte Folded Spill
32 | mov x29, sp
33 | .cfi_def_cfa w29, 16
34 | .cfi_offset w30, -8
35 | .cfi_offset w29, -16
36 | adrp x0, l_.str.1@PAGE
37 | add x0, x0, l_.str.1@PAGEOFF
38 | bl _printf
39 | ldp x29, x30, [sp], #16 ; 16-byte Folded Reload
40 | ret
41 | .cfi_endproc
42 | ; -- End function
43 | .globl min_caml_create_array ; -- Begin function min_caml_create_array
44 | .p2align 2
45 | min_caml_create_array: ; @"\01min_caml_create_array"
46 | .cfi_startproc
47 | ; %bb.0:
48 | sub sp, sp, #48
49 | .cfi_def_cfa_offset 48
50 | str x0, [sp, #40]
51 | str x1, [sp, #32]
52 | ; InlineAsm Start
53 | mov x8, x27
54 | ; InlineAsm End
55 | str x8, [sp, #24]
56 | ldr x8, [sp, #24]
57 | str x8, [sp, #16]
58 | str xzr, [sp, #8]
59 | b LBB2_1
60 | LBB2_1: ; =>This Inner Loop Header: Depth=1
61 | ldr x8, [sp, #8]
62 | ldr x9, [sp, #40]
63 | subs x8, x8, x9
64 | b.ge LBB2_4
65 | b LBB2_2
66 | LBB2_2: ; in Loop: Header=BB2_1 Depth=1
67 | ldr x8, [sp, #32]
68 | ldr x9, [sp, #24]
69 | str x8, [x9]
70 | ldr x8, [sp, #24]
71 | add x8, x8, #8
72 | str x8, [sp, #24]
73 | b LBB2_3
74 | LBB2_3: ; in Loop: Header=BB2_1 Depth=1
75 | ldr x8, [sp, #8]
76 | add x8, x8, #1
77 | str x8, [sp, #8]
78 | b LBB2_1
79 | LBB2_4:
80 | ldr x8, [sp, #24]
81 | ; InlineAsm Start
82 | mov x27, x8
83 | ; InlineAsm End
84 | ldr x0, [sp, #16]
85 | add sp, sp, #48
86 | ret
87 | .cfi_endproc
88 | ; -- End function
89 | .globl min_caml_create_float_array ; -- Begin function min_caml_create_float_array
90 | .p2align 2
91 | min_caml_create_float_array: ; @"\01min_caml_create_float_array"
92 | .cfi_startproc
93 | ; %bb.0:
94 | sub sp, sp, #48
95 | .cfi_def_cfa_offset 48
96 | str x0, [sp, #40]
97 | str d0, [sp, #32]
98 | ; InlineAsm Start
99 | mov x8, x27
100 | ; InlineAsm End
101 | str x8, [sp, #24]
102 | ldr x8, [sp, #24]
103 | str x8, [sp, #16]
104 | str xzr, [sp, #8]
105 | b LBB3_1
106 | LBB3_1: ; =>This Inner Loop Header: Depth=1
107 | ldr x8, [sp, #8]
108 | ldr x9, [sp, #40]
109 | subs x8, x8, x9
110 | b.ge LBB3_4
111 | b LBB3_2
112 | LBB3_2: ; in Loop: Header=BB3_1 Depth=1
113 | ldr d0, [sp, #32]
114 | ldr x8, [sp, #24]
115 | str d0, [x8]
116 | ldr x8, [sp, #24]
117 | add x8, x8, #8
118 | str x8, [sp, #24]
119 | b LBB3_3
120 | LBB3_3: ; in Loop: Header=BB3_1 Depth=1
121 | ldr x8, [sp, #8]
122 | add x8, x8, #1
123 | str x8, [sp, #8]
124 | b LBB3_1
125 | LBB3_4:
126 | ldr x8, [sp, #24]
127 | ; InlineAsm Start
128 | mov x27, x8
129 | ; InlineAsm End
130 | ldr x0, [sp, #16]
131 | add sp, sp, #48
132 | ret
133 | .cfi_endproc
134 | ; -- End function
135 | .globl min_caml_truncate ; -- Begin function min_caml_truncate
136 | .p2align 2
137 | min_caml_truncate: ; @"\01min_caml_truncate"
138 | .cfi_startproc
139 | ; %bb.0:
140 | sub sp, sp, #16
141 | .cfi_def_cfa_offset 16
142 | str d0, [sp, #8]
143 | ldr d0, [sp, #8]
144 | fcvtzs x0, d0
145 | add sp, sp, #16
146 | ret
147 | .cfi_endproc
148 | ; -- End function
149 | .globl min_caml_print_float ; -- Begin function min_caml_print_float
150 | .p2align 2
151 | min_caml_print_float: ; @"\01min_caml_print_float"
152 | .cfi_startproc
153 | ; %bb.0:
154 | sub sp, sp, #32
155 | stp x29, x30, [sp, #16] ; 16-byte Folded Spill
156 | add x29, sp, #16
157 | .cfi_def_cfa w29, 16
158 | .cfi_offset w30, -8
159 | .cfi_offset w29, -16
160 | str d0, [sp, #8]
161 | ldr d0, [sp, #8]
162 | mov x8, sp
163 | str d0, [x8]
164 | adrp x0, l_.str.2@PAGE
165 | add x0, x0, l_.str.2@PAGEOFF
166 | bl _printf
167 | ldp x29, x30, [sp, #16] ; 16-byte Folded Reload
168 | add sp, sp, #32
169 | ret
170 | .cfi_endproc
171 | ; -- End function
172 | .globl min_caml_print_byte ; -- Begin function min_caml_print_byte
173 | .p2align 2
174 | min_caml_print_byte: ; @"\01min_caml_print_byte"
175 | .cfi_startproc
176 | ; %bb.0:
177 | sub sp, sp, #32
178 | stp x29, x30, [sp, #16] ; 16-byte Folded Spill
179 | add x29, sp, #16
180 | .cfi_def_cfa w29, 16
181 | .cfi_offset w30, -8
182 | .cfi_offset w29, -16
183 | str x0, [sp, #8]
184 | ldr x8, [sp, #8]
185 | mov x0, x8
186 | bl _putchar
187 | ldp x29, x30, [sp, #16] ; 16-byte Folded Reload
188 | add sp, sp, #32
189 | ret
190 | .cfi_endproc
191 | ; -- End function
192 | .globl min_caml_read_int ; -- Begin function min_caml_read_int
193 | .p2align 2
194 | min_caml_read_int: ; @"\01min_caml_read_int"
195 | .cfi_startproc
196 | ; %bb.0:
197 | sub sp, sp, #32
198 | stp x29, x30, [sp, #16] ; 16-byte Folded Spill
199 | add x29, sp, #16
200 | .cfi_def_cfa w29, 16
201 | .cfi_offset w30, -8
202 | .cfi_offset w29, -16
203 | mov x9, sp
204 | add x8, sp, #8
205 | str x8, [x9]
206 | adrp x0, l_.str@PAGE
207 | add x0, x0, l_.str@PAGEOFF
208 | bl _scanf
209 | ldr x0, [sp, #8]
210 | ldp x29, x30, [sp, #16] ; 16-byte Folded Reload
211 | add sp, sp, #32
212 | ret
213 | .cfi_endproc
214 | ; -- End function
215 | .globl min_caml_read_float ; -- Begin function min_caml_read_float
216 | .p2align 2
217 | min_caml_read_float: ; @"\01min_caml_read_float"
218 | .cfi_startproc
219 | ; %bb.0:
220 | sub sp, sp, #32
221 | stp x29, x30, [sp, #16] ; 16-byte Folded Spill
222 | add x29, sp, #16
223 | .cfi_def_cfa w29, 16
224 | .cfi_offset w30, -8
225 | .cfi_offset w29, -16
226 | mov x9, sp
227 | add x8, sp, #8
228 | str x8, [x9]
229 | adrp x0, l_.str.2@PAGE
230 | add x0, x0, l_.str.2@PAGEOFF
231 | bl _scanf
232 | ldr d0, [sp, #8]
233 | ldp x29, x30, [sp, #16] ; 16-byte Folded Reload
234 | add sp, sp, #32
235 | ret
236 | .cfi_endproc
237 | ; -- End function
238 | .globl min_caml_atan ; -- Begin function min_caml_atan
239 | .p2align 2
240 | min_caml_atan: ; @"\01min_caml_atan"
241 | .cfi_startproc
242 | ; %bb.0:
243 | sub sp, sp, #32
244 | stp x29, x30, [sp, #16] ; 16-byte Folded Spill
245 | add x29, sp, #16
246 | .cfi_def_cfa w29, 16
247 | .cfi_offset w30, -8
248 | .cfi_offset w29, -16
249 | str d0, [sp, #8]
250 | ldr d0, [sp, #8]
251 | bl _atan
252 | ldp x29, x30, [sp, #16] ; 16-byte Folded Reload
253 | add sp, sp, #32
254 | ret
255 | .cfi_endproc
256 | ; -- End function
257 | .globl min_caml_cos ; -- Begin function min_caml_cos
258 | .p2align 2
259 | min_caml_cos: ; @"\01min_caml_cos"
260 | .cfi_startproc
261 | ; %bb.0:
262 | sub sp, sp, #32
263 | stp x29, x30, [sp, #16] ; 16-byte Folded Spill
264 | add x29, sp, #16
265 | .cfi_def_cfa w29, 16
266 | .cfi_offset w30, -8
267 | .cfi_offset w29, -16
268 | str d0, [sp, #8]
269 | ldr d0, [sp, #8]
270 | bl _cos
271 | ldp x29, x30, [sp, #16] ; 16-byte Folded Reload
272 | add sp, sp, #32
273 | ret
274 | .cfi_endproc
275 | ; -- End function
276 | .globl min_caml_floor ; -- Begin function min_caml_floor
277 | .p2align 2
278 | min_caml_floor: ; @"\01min_caml_floor"
279 | .cfi_startproc
280 | ; %bb.0:
281 | sub sp, sp, #16
282 | .cfi_def_cfa_offset 16
283 | str d0, [sp, #8]
284 | ldr d0, [sp, #8]
285 | frintm d0, d0
286 | add sp, sp, #16
287 | ret
288 | .cfi_endproc
289 | ; -- End function
290 | .globl min_caml_sin ; -- Begin function min_caml_sin
291 | .p2align 2
292 | min_caml_sin: ; @"\01min_caml_sin"
293 | .cfi_startproc
294 | ; %bb.0:
295 | sub sp, sp, #32
296 | stp x29, x30, [sp, #16] ; 16-byte Folded Spill
297 | add x29, sp, #16
298 | .cfi_def_cfa w29, 16
299 | .cfi_offset w30, -8
300 | .cfi_offset w29, -16
301 | str d0, [sp, #8]
302 | ldr d0, [sp, #8]
303 | bl _sin
304 | ldp x29, x30, [sp, #16] ; 16-byte Folded Reload
305 | add sp, sp, #32
306 | ret
307 | .cfi_endproc
308 | ; -- End function
309 | .globl min_caml_abs_float ; -- Begin function min_caml_abs_float
310 | .p2align 2
311 | min_caml_abs_float: ; @"\01min_caml_abs_float"
312 | .cfi_startproc
313 | ; %bb.0:
314 | sub sp, sp, #16
315 | .cfi_def_cfa_offset 16
316 | str d0, [sp, #8]
317 | ldr d0, [sp, #8]
318 | fabs d0, d0
319 | add sp, sp, #16
320 | ret
321 | .cfi_endproc
322 | ; -- End function
323 | .globl min_caml_float_of_int ; -- Begin function min_caml_float_of_int
324 | .p2align 2
325 | min_caml_float_of_int: ; @"\01min_caml_float_of_int"
326 | .cfi_startproc
327 | ; %bb.0:
328 | sub sp, sp, #16
329 | .cfi_def_cfa_offset 16
330 | str x0, [sp, #8]
331 | ldr d0, [sp, #8]
332 | scvtf d0, d0
333 | add sp, sp, #16
334 | ret
335 | .cfi_endproc
336 | ; -- End function
337 | .globl min_caml_int_of_float ; -- Begin function min_caml_int_of_float
338 | .p2align 2
339 | min_caml_int_of_float: ; @"\01min_caml_int_of_float"
340 | .cfi_startproc
341 | ; %bb.0:
342 | sub sp, sp, #16
343 | .cfi_def_cfa_offset 16
344 | str d0, [sp, #8]
345 | ldr d0, [sp, #8]
346 | fcvtzs x0, d0
347 | add sp, sp, #16
348 | ret
349 | .cfi_endproc
350 | ; -- End function
351 | .globl min_caml_sqrt ; -- Begin function min_caml_sqrt
352 | .p2align 2
353 | min_caml_sqrt: ; @"\01min_caml_sqrt"
354 | .cfi_startproc
355 | ; %bb.0:
356 | sub sp, sp, #16
357 | .cfi_def_cfa_offset 16
358 | str d0, [sp, #8]
359 | ldr d0, [sp, #8]
360 | fsqrt d0, d0
361 | add sp, sp, #16
362 | ret
363 | .cfi_endproc
364 | ; -- End function
365 | .section __TEXT,__cstring,cstring_literals
366 | l_.str: ; @.str
367 | .asciz "%ld"
368 |
369 | l_.str.1: ; @.str.1
370 | .asciz "\n"
371 |
372 | l_.str.2: ; @.str.2
373 | .asciz "%lf"
374 |
375 | .subsections_via_symbols
376 |
--------------------------------------------------------------------------------
/src/arm64/libmincaml.c:
--------------------------------------------------------------------------------
1 | #include
2 | #include
3 |
4 | // NOTE: コンパイル後のシンボルのプリフィックスに _ がつくのを避ける
5 | void min_caml_print_int(long n) asm("min_caml_print_int");
6 | void min_caml_print_newline() asm("min_caml_print_newline");
7 | long* min_caml_create_array(long number_of_element, long init_value) asm("min_caml_create_array");
8 | double* min_caml_create_float_array(long number_of_element, double float_value) asm("min_caml_create_float_array");
9 | long min_caml_truncate(double d) asm("min_caml_truncate");
10 | void min_caml_print_float(double d) asm("min_caml_print_float");
11 | void min_caml_print_byte(long n) asm("min_caml_print_byte");
12 | long min_caml_read_int() asm("min_caml_read_int");
13 | double min_caml_read_float() asm("min_caml_read_float");
14 | double min_caml_atan(double x) asm("min_caml_atan");
15 | long min_caml_mul(long x, long y) asm("min_caml_mul");
16 | long min_caml_div(long x, long y) asm("min_caml_div");
17 | long min_caml_rem(long x, long y) asm("min_caml_rem");
18 | double min_caml_cos(double x) asm("min_caml_cos");
19 | double min_caml_floor(double x) asm("min_caml_floor");
20 | double min_caml_sin(double x) asm("min_caml_sin");
21 | double min_caml_abs_float(double x) asm("min_caml_abs_float");
22 | double min_caml_float_of_int(long n) asm("min_caml_float_of_int");
23 | long min_caml_int_of_float(double d) asm("min_caml_int_of_float");
24 | double min_caml_sqrt(double d) asm("min_caml_sqrt");
25 |
26 | void min_caml_print_int(long n) {
27 | printf("%ld", n);
28 | }
29 |
30 | void min_caml_print_newline() {
31 | printf("\n");
32 | }
33 |
34 | long* min_caml_create_array(long number_of_element, long init_value) {
35 | long *heap_ptr;
36 |
37 | // x27 に格納されたヒープのアドレスを heap_ptr へ書き出す
38 | asm volatile ("mov %0, x27" : "=r"(heap_ptr));
39 |
40 | // Array の先頭アドレスを取得
41 | long *array_ptr = heap_ptr;
42 |
43 | for (long i = 0l; i < number_of_element; i++) {
44 | // Array へ書き込んだ後、ヒープの先頭アドレスを8バイト進める
45 | *heap_ptr = init_value;
46 | heap_ptr += 1;
47 | }
48 |
49 | // ヒープの先頭アドレスを x27 に書き戻す
50 | asm volatile ("mov x27, %0" : : "r"(heap_ptr));
51 |
52 | return array_ptr;
53 | }
54 |
55 | double* min_caml_create_float_array(long number_of_element, double float_value) {
56 | double *heap_ptr;
57 |
58 | // x27 に格納されたヒープのアドレスを heap_ptr へ書き出す
59 | asm volatile ("mov %0, x27" : "=r"(heap_ptr));
60 |
61 | // Array の先頭アドレスを取得
62 | double *array_ptr = heap_ptr;
63 |
64 | for (long i = 0l; i < number_of_element; i++) {
65 | // Array へ書き込んだ後、ヒープの先頭アドレスを8バイト進める
66 | *heap_ptr = float_value;
67 | heap_ptr += 1;
68 | }
69 |
70 | // ヒープの先頭アドレスを x27 に書き戻す
71 | asm volatile ("mov x27, %0" : : "r"(heap_ptr));
72 |
73 | return array_ptr;
74 | }
75 |
76 | // truncate
77 | long min_caml_truncate(double d) {
78 | return (long)d;
79 | }
80 |
81 | void min_caml_print_float(double d) {
82 | printf("%lf", d);
83 | }
84 |
85 | void min_caml_print_byte(long n) {
86 | putchar(n);
87 | }
88 |
89 | long min_caml_read_int() {
90 | long l;
91 | // fscanf(fp, "%ld", &l);
92 | scanf("%ld", &l);
93 | return l;
94 | }
95 |
96 | double min_caml_read_float() {
97 | double d;
98 | // fscanf(fp, "%lf", &d);
99 | scanf("%lf", &d);
100 | return d;
101 | }
102 |
103 | // atan
104 | double min_caml_atan(double x) {
105 | return atan(x);
106 | }
107 |
108 | // cos
109 | double min_caml_cos(double x) {
110 | return cos(x);
111 | }
112 |
113 | // floor
114 | double min_caml_floor(double x) {
115 | return floor(x);
116 | }
117 |
118 | // sin
119 | double min_caml_sin(double x) {
120 | return sin(x);
121 | }
122 |
123 | // abs_float
124 | double min_caml_abs_float(double x) {
125 | return fabs(x);
126 | }
127 |
128 | // float_of_int
129 | double min_caml_float_of_int(long n) {
130 | return (double)n;
131 | }
132 |
133 | // int_of_float
134 | long min_caml_int_of_float(double d) {
135 | return (long)d;
136 | }
137 |
138 | long min_caml_div(long x, long y) {
139 | return (long)(x/y);
140 | }
141 |
142 | long min_caml_rem(long x, long y) {
143 | return x % y;
144 | }
145 |
146 | long min_caml_mul(long x, long y) {
147 | return x * y;
148 | }
149 |
150 | // sqrt
151 | double min_caml_sqrt(double d) {
152 | return sqrt(d);
153 | }
154 |
--------------------------------------------------------------------------------
/src/arm64/regAlloc.ml:
--------------------------------------------------------------------------------
1 | open MinCaml
2 | open Asm
3 | open Asm.ARM64
4 |
5 | (* for register coalescing *)
6 | (* [XXX] Callがあったら、そこから先は無意味というか逆効果なので追わない。
7 | そのために「Callがあったかどうか」を返り値の第1要素に含める。 *)
8 | let rec target' src (dest, t) = function
9 | | Mr(x) when x = src && is_reg dest ->
10 | assert (t <> Type.Unit);
11 | assert (t <> Type.Float);
12 | false, [dest]
13 | | FMr(x) when x = src && is_reg dest ->
14 | assert (t = Type.Float);
15 | false, [dest]
16 | | IfEq(_, _, e1, e2) | IfLE(_, _, e1, e2) | IfGE(_, _, e1, e2)
17 | | IfFEq(_, _, e1, e2) | IfFLE(_, _, e1, e2) ->
18 | let c1, rs1 = target src (dest, t) e1 in
19 | let c2, rs2 = target src (dest, t) e2 in
20 | c1 && c2, rs1 @ rs2
21 | | CallCls(x, ys, zs) ->
22 | true, (target_args src regs 0 ys @
23 | target_args src fregs 0 zs @
24 | if x = src then [reg_cl] else [])
25 | | CallDir(_, ys, zs) ->
26 | true, (target_args src regs 0 ys @
27 | target_args src fregs 0 zs)
28 | | _ -> false, []
29 |
30 | and target src dest = function (* register targeting (caml2html: regalloc_target) *)
31 | | Ans(exp) -> target' src dest exp
32 | | Let(xt, exp, e) ->
33 | let c1, rs1 = target' src xt exp in
34 | if c1 then true, rs1 else
35 | let c2, rs2 = target src dest e in
36 | c2, rs1 @ rs2
37 |
38 | and target_args src all n = function (* auxiliary function for Call *)
39 | | [] -> []
40 | | y :: ys when src = y -> all.(n) :: target_args src all (n + 1) ys
41 | | _ :: ys -> target_args src all (n + 1) ys
42 |
43 | type alloc_result = (* allocにおいてspillingがあったかどうかを表すデータ型 *)
44 | | Alloc of Id.t (* allocated register *)
45 | | Spill of Id.t (* spilled variable *)
46 |
47 | let rec alloc dest cont regenv x t =
48 | (* allocate a register or spill a variable *)
49 | assert (not (M.mem x regenv));
50 | let all =
51 | match t with
52 | | Type.Unit -> ["%r0"] (* dummy *)
53 | | Type.Float -> allfregs
54 | | _ -> allregs in
55 | if all = ["%r0"] then Alloc("%r0") else (* [XX] ad hoc optimization *)
56 | if is_reg x then Alloc(x) else
57 | let free = fv cont in
58 | try
59 | let (c, prefer) = target x dest cont in
60 | let live = (* 生きているレジスタ *)
61 | List.fold_left
62 | (fun live y ->
63 | if is_reg y then S.add y live else
64 | try S.add (M.find y regenv) live
65 | with Not_found -> live)
66 | S.empty
67 | free in
68 | let r = (* そうでないレジスタを探す *)
69 | List.find
70 | (fun r -> not (S.mem r live))
71 | (prefer @ all) in
72 | (* Format.eprintf "allocated %s to %s@." x r; *)
73 | Alloc(r)
74 | with Not_found ->
75 | Format.eprintf "register allocation failed for %s@." x;
76 | let y = (* 型の合うレジスタ変数を探す *)
77 | List.find
78 | (fun y ->
79 | not (is_reg y) &&
80 | try List.mem (M.find y regenv) all
81 | with Not_found -> false)
82 | (List.rev free) in
83 | Format.eprintf "spilling %s from %s@." y (M.find y regenv);
84 | Spill(y)
85 |
86 | (* auxiliary function for g and g'_and_restore *)
87 | let add x r regenv =
88 | if is_reg x then (assert (x = r); regenv) else
89 | M.add x r regenv
90 |
91 | (* auxiliary functions for g' *)
92 | exception NoReg of Id.t * Type.t
93 |
94 | let find x t regenv =
95 | if is_reg x then x else
96 | try M.find x regenv
97 | with Not_found -> raise (NoReg(x, t))
98 |
99 | let find' x' regenv =
100 | match x' with
101 | | V(x) -> V(find x Type.Int regenv)
102 | | c -> c
103 |
104 | let rec g dest cont regenv = function (* 命令列のレジスタ割り当て (caml2html: regalloc_g) *)
105 | | Ans(exp) -> g'_and_restore dest cont regenv exp
106 | | Let((x, t) as xt, exp, e) ->
107 | assert (not (M.mem x regenv));
108 | let cont' = concat e dest cont in
109 | let (e1', regenv1) = g'_and_restore xt cont' regenv exp in
110 | (match alloc dest cont' regenv1 x t with
111 | | Spill(y) ->
112 | let r = M.find y regenv1 in
113 | let (e2', regenv2) = g dest cont (add x r (M.remove y regenv1)) e in
114 | let save =
115 | try Save(M.find y regenv, y)
116 | with Not_found -> Nop in
117 | (seq(save, concat e1' (r, t) e2'), regenv2)
118 | | Alloc(r) ->
119 | let (e2', regenv2) = g dest cont (add x r regenv1) e in
120 | (concat e1' (r, t) e2', regenv2))
121 |
122 | and g'_and_restore dest cont regenv exp = (* 使用される変数をスタックからレジスタへRestore (caml2html: regalloc_unspill) *)
123 | try g' dest cont regenv exp
124 | with NoReg(x, t) ->
125 | ((* Format.eprintf "restoring %s@." x; *)
126 | g dest cont regenv (Let((x, t), Restore(x), Ans(exp))))
127 |
128 | and g' dest cont regenv = function (* 各命令のレジスタ割り当て (caml2html: regalloc_gprime) *)
129 | | Nop | Li _ | SetL _ | Comment _ | Restore _ | FLi _ as exp -> (Ans(exp), regenv)
130 | | Mov x -> Ans (Mov (find x Type.Int regenv)), regenv
131 | | Mr(x) -> (Ans(Mr(find x Type.Int regenv)), regenv)
132 | | Neg(x) -> (Ans(Neg(find x Type.Int regenv)), regenv)
133 | | Add(x, y') -> (Ans(Add(find x Type.Int regenv, find' y' regenv)), regenv)
134 | | Sub(x, y') -> (Ans(Sub(find x Type.Int regenv, find' y' regenv)), regenv)
135 | | Mul(x, y') -> (Ans(Mul(find x Type.Int regenv, find' y' regenv)), regenv)
136 | | Div(x, y') -> (Ans(Div(find x Type.Int regenv, find' y' regenv)), regenv)
137 | | Mod(x, y') -> (Ans(Mod(find x Type.Int regenv, find' y' regenv)), regenv)
138 | | Lfd(x, y') -> (Ans(Lfd(find x Type.Int regenv, find' y' regenv)), regenv)
139 | | Lwz(x, y') -> (Ans(Lwz(find x Type.Int regenv, find' y' regenv)), regenv)
140 | | Ld(x, y', i) -> (Ans(Ld(find x Type.Int regenv, find' y' regenv, i)), regenv)
141 | | Slw(x, y') -> (Ans(Slw(find x Type.Int regenv, find' y' regenv)), regenv)
142 | | Stw(x, y, z') -> (Ans(Stw(find x Type.Int regenv, find y Type.Int regenv, find' z' regenv)), regenv)
143 | | Stfd(x, y, z') -> (Ans(Stfd(find x Type.Float regenv, find y Type.Int regenv, find' z' regenv)), regenv)
144 | | St(x, y, z', i) -> (Ans(St(find x Type.Int regenv, find y Type.Int regenv, find' z' regenv, i)), regenv)
145 | | FMr(x) -> (Ans(FMr(find x Type.Float regenv)), regenv)
146 | | FMov x -> Ans (FMov (find x Type.Float regenv)), regenv
147 | | FNeg(x) -> (Ans(FNeg(find x Type.Float regenv)), regenv)
148 | | FAdd(x, y) -> (Ans(FAdd(find x Type.Float regenv, find y Type.Float regenv)), regenv)
149 | | FSub(x, y) -> (Ans(FSub(find x Type.Float regenv, find y Type.Float regenv)), regenv)
150 | | FMul(x, y) -> (Ans(FMul(find x Type.Float regenv, find y Type.Float regenv)), regenv)
151 | | FDiv(x, y) -> (Ans(FDiv(find x Type.Float regenv, find y Type.Float regenv)), regenv)
152 | | IfEq(x, y', e1, e2) as exp -> g'_if dest cont regenv exp (fun e1' e2' -> IfEq(find x Type.Int regenv, find' y' regenv, e1', e2')) e1 e2
153 | | IfLE(x, y', e1, e2) as exp -> g'_if dest cont regenv exp (fun e1' e2' -> IfLE(find x Type.Int regenv, find' y' regenv, e1', e2')) e1 e2
154 | | IfGE(x, y', e1, e2) as exp -> g'_if dest cont regenv exp (fun e1' e2' -> IfGE(find x Type.Int regenv, find' y' regenv, e1', e2')) e1 e2
155 | | IfFEq(x, y, e1, e2) as exp -> g'_if dest cont regenv exp (fun e1' e2' -> IfFEq(find x Type.Float regenv, find y Type.Float regenv, e1', e2')) e1 e2
156 | | IfFLE(x, y, e1, e2) as exp -> g'_if dest cont regenv exp (fun e1' e2' -> IfFLE(find x Type.Float regenv, find y Type.Float regenv, e1', e2')) e1 e2
157 | | CallCls(x, ys, zs) as exp ->
158 | if List.length ys > Array.length regs - 2 || List.length zs > Array.length fregs - 1 then
159 | failwith (Format.sprintf "cannot allocate registers for arugments to %s" x)
160 | else g'_call dest cont regenv exp (fun ys zs -> CallCls(find x Type.Int regenv, ys, zs)) ys zs
161 | | CallDir(Id.L(x), ys, zs) as exp ->
162 | if List.length ys > Array.length regs - 1 || List.length zs > Array.length fregs - 1 then
163 | failwith (Format.sprintf "cannot allocate registers for arugments to %s" x)
164 | else g'_call dest cont regenv exp (fun ys zs -> CallDir(Id.L(x), ys, zs)) ys zs
165 | | Save(x, y) -> assert false
166 | | _ as exp -> (Ans(exp), regenv)
167 |
168 | and g'_if dest cont regenv exp constr e1 e2 = (* ifのレジスタ割り当て (caml2html: regalloc_if) *)
169 | let (e1', regenv1) = g dest cont regenv e1 in
170 | let (e2', regenv2) = g dest cont regenv e2 in
171 | let regenv' = (* 両方に共通のレジスタ変数だけ利用 *)
172 | List.fold_left
173 | (fun regenv' x ->
174 | try
175 | if is_reg x then regenv' else
176 | let r1 = M.find x regenv1 in
177 | let r2 = M.find x regenv2 in
178 | if r1 <> r2 then regenv' else
179 | M.add x r1 regenv'
180 | with Not_found -> regenv')
181 | M.empty
182 | (fv cont) in
183 | (List.fold_left
184 | (fun e x ->
185 | if x = fst dest || not (M.mem x regenv) || M.mem x regenv' then e else
186 | seq(Save(M.find x regenv, x), e)) (* そうでない変数は分岐直前にセーブ *)
187 | (Ans(constr e1' e2'))
188 | (fv cont),
189 | regenv')
190 |
191 | and g'_call dest cont regenv exp constr ys zs = (* 関数呼び出しのレジスタ割り当て (caml2html: regalloc_call) *)
192 | (List.fold_left
193 | (fun e x ->
194 | if x = fst dest || not (M.mem x regenv) then e else
195 | seq(Save(M.find x regenv, x), e))
196 | (Ans(constr
197 | (List.map (fun y -> find y Type.Int regenv) ys)
198 | (List.map (fun z -> find z Type.Float regenv) zs)))
199 | (fv cont),
200 | M.empty)
201 |
202 | let h { name = Id.L(x); args = ys; fargs = zs; body = e; ret = t ; annot } = (* 関数のレジスタ割り当て (caml2html: regalloc_h) *)
203 | let regenv = M.add x reg_cl M.empty in
204 | let (i, arg_regs, regenv) =
205 | List.fold_left
206 | (fun (i, arg_regs, regenv) y ->
207 | let r = regs.(i) in
208 | (i + 1,
209 | arg_regs @ [r],
210 | (assert (not (is_reg y));
211 | M.add y r regenv)))
212 | (0, [], regenv)
213 | ys in
214 | let (d, farg_regs, regenv) =
215 | List.fold_left
216 | (fun (d, farg_regs, regenv) z ->
217 | let fr = fregs.(d) in
218 | (d + 1,
219 | farg_regs @ [fr],
220 | (assert (not (is_reg z));
221 | M.add z fr regenv)))
222 | (0, [], regenv)
223 | zs in
224 | let a =
225 | match t with
226 | | Type.Unit -> Id.gentmp Type.Unit
227 | | Type.Float -> fregs.(0)
228 | | _ -> regs.(0) in
229 | let (e', regenv') = g (a, t) (Ans(Mr(a))) regenv e in
230 | { name = Id.L(x); args = arg_regs; fargs = farg_regs; body = e'; ret = t ; annot }
231 |
232 | let f (Prog(data, fundefs, e)) = (* プログラム全体のレジスタ割り当て (caml2html: regalloc_f) *)
233 | Format.eprintf "register allocation: may take some time (up to a few minutes, depending on the size of functions)@.";
234 | let fundefs' = List.map h fundefs in
235 | let e', regenv' = g (Id.gentmp Type.Unit, Type.Unit) (Ans(Nop)) M.empty e in
236 | Prog(data, fundefs', e')
237 |
--------------------------------------------------------------------------------
/src/arm64/regAlloc.mli:
--------------------------------------------------------------------------------
1 | open MinCaml
2 |
3 | val f : Asm.prog -> Asm.prog
4 |
--------------------------------------------------------------------------------
/src/arm64/stub.c:
--------------------------------------------------------------------------------
1 | #include
2 | #include
3 |
4 | extern void min_caml_start(char *, char *);
5 |
6 | /* "stderr" is a macro and cannot be referred to in libmincaml.S, so
7 | this "min_caml_stderr" is used (in place of "__iob+32") for better
8 | portability (under SPARC emulators, for example). Thanks to Steven
9 | Shaw for reporting the problem and proposing this solution. */
10 | FILE *min_caml_stderr;
11 |
12 | int main() {
13 | char *hp, *sp;
14 |
15 | min_caml_stderr = stderr;
16 | sp = alloca(1000000); hp = malloc(4000000);
17 | if (hp == NULL || sp == NULL) {
18 | fprintf(stderr, "malloc or alloca failed\n");
19 | return 1;
20 | }
21 | // fprintf(stderr, "sp = %p, hp = %p\n", sp, hp);
22 | min_caml_start(sp, hp);
23 |
24 | return 0;
25 | }
26 |
--------------------------------------------------------------------------------
/src/joe/alpha.ml:
--------------------------------------------------------------------------------
1 | (* rename identifiers to make them unique (alpha-conversion) *)
2 |
3 | open KNormal
4 |
5 | let find x env = try M.find x env with Not_found -> x
6 |
7 | let rec g env = function (* α変換ルーチン本体 (caml2html: alpha_g) *)
8 | | Unit -> Unit
9 | | Int i -> Int i
10 | | Float d -> Float d
11 | | Neg x -> Neg (find x env)
12 | | Add (x, y) -> Add (find x env, find y env)
13 | | Sub (x, y) -> Sub (find x env, find y env)
14 | | Mul (x, y) -> Mul (find x env, find y env)
15 | | Div (x, y) -> Div (find x env, find y env)
16 | | Mod (x, y) -> Mod (find x env, find y env)
17 | | FNeg x -> FNeg (find x env)
18 | | FAdd (x, y) -> FAdd (find x env, find y env)
19 | | FSub (x, y) -> FSub (find x env, find y env)
20 | | FMul (x, y) -> FMul (find x env, find y env)
21 | | FDiv (x, y) -> FDiv (find x env, find y env)
22 | | IfEq (x, y, e1, e2) -> IfEq (find x env, find y env, g env e1, g env e2)
23 | | IfLE (x, y, e1, e2) -> IfLE (find x env, find y env, g env e1, g env e2)
24 | | Let ((x, t), e1, e2) ->
25 | let x' = Id.genid x in (* letのα変換 (caml2html: alpha_let) *)
26 | Let ((x', t), g env e1, g (M.add x x' env) e2)
27 | | Var x -> Var (find x env)
28 | | LetRec ({ name = x, t; args = yts; body = e1; annot }, e2) -> (* let recのα変換 (caml2html: alpha_letrec) *)
29 | let env = M.add x (Id.genid x) env in
30 | let ys = List.map fst yts in
31 | let env' = M.add_list2 ys (List.map Id.genid ys) env in
32 | LetRec
33 | ( { name = find x env, t
34 | ; args = List.map (fun (y, t) -> find y env', t) yts
35 | ; body = g env' e1
36 | ; annot
37 | }
38 | , g env e2 )
39 | | App (x, ys) -> App (find x env, List.map (fun y -> find y env) ys)
40 | | Tuple xs -> Tuple (List.map (fun x -> find x env) xs)
41 | | LetTuple (xts, y, e) ->
42 | let xs = List.map fst xts in
43 | let env' = M.add_list2 xs (List.map Id.genid xs) env in
44 | LetTuple (List.map (fun (x, t) -> find x env', t) xts, find y env, g env' e)
45 | | Get (x, y) -> Get (find x env, find y env)
46 | | Put (x, y, z) -> Put (find x env, find y env, find z env)
47 | | ExtArray x -> ExtArray x
48 | | ExtFunApp (x, ys) -> ExtFunApp (x, List.map (fun y -> find y env) ys)
49 |
50 | let f = g M.empty
51 |
--------------------------------------------------------------------------------
/src/joe/alpha.mli:
--------------------------------------------------------------------------------
1 | val f : KNormal.t -> KNormal.t
2 | val g : Id.t M.t -> KNormal.t -> KNormal.t (* for Inline.g *)
3 |
--------------------------------------------------------------------------------
/src/joe/asm.ml:
--------------------------------------------------------------------------------
1 | type id_or_imm =
2 | | V of Id.t
3 | | C of int
4 | [@@deriving show]
5 |
6 | type t =
7 | | Ans of exp
8 | | Let of (Id.t * Type.t) * exp * t
9 | [@@deriving show]
10 |
11 | and exp =
12 | | Nop
13 | | Li of int
14 | | FLi of Id.l
15 | | SetL of Id.l
16 | | Mr of Id.t
17 | | Mov of Id.t
18 | (* ALU instructions *)
19 | | Neg of Id.t
20 | | Add of Id.t * id_or_imm
21 | | Sub of Id.t * id_or_imm
22 | | Mul of Id.t * id_or_imm
23 | | Div of Id.t * id_or_imm
24 | | Mod of Id.t * id_or_imm
25 | (* load/store instructions *)
26 | | Lfd of Id.t * id_or_imm
27 | | Lwz of Id.t * id_or_imm
28 | | Ld of Id.t * id_or_imm * int
29 | | Slw of Id.t * id_or_imm
30 | | Stw of Id.t * Id.t * id_or_imm
31 | | Stfd of Id.t * Id.t * id_or_imm
32 | | St of Id.t * Id.t * id_or_imm * int
33 | (* float instructions *)
34 | | FMov of Id.t
35 | | FNeg of Id.t
36 | | FAdd of Id.t * Id.t
37 | | FSub of Id.t * Id.t
38 | | FMul of Id.t * Id.t
39 | | FDiv of Id.t * Id.t
40 | | LdDF of Id.t * id_or_imm * int
41 | | StDF of Id.t * Id.t * id_or_imm * int
42 | | FMr of Id.t
43 | | Comment of string
44 | (* virtual instructions *)
45 | | IfEq of Id.t * id_or_imm * t * t
46 | | IfLE of Id.t * id_or_imm * t * t
47 | | IfGE of Id.t * id_or_imm * t * t (* 左右対称ではないので必要 *)
48 | | IfFEq of Id.t * Id.t * t * t
49 | | IfFLE of Id.t * Id.t * t * t
50 | (* closure address, integer arguments, and float arguments *)
51 | | CallCls of Id.t * Id.t list * Id.t list
52 | | CallDir of Id.l * Id.t list * Id.t list
53 | | Save of Id.t * Id.t (* レジスタ変数の値をスタック変数へ保存 (caml2html: sparcasm_save) *)
54 | | Restore of Id.t (* スタック変数から値を復元 (caml2html: sparcasm_restore) *)
55 | [@@deriving show]
56 |
57 | type fundef =
58 | { name : Id.l
59 | ; args : Id.t list
60 | ; fargs : Id.t list
61 | ; body : t
62 | ; ret : Type.t
63 | ; mutable annot : [ `TJ | `MJ ] option
64 | }
65 | [@@deriving show]
66 |
67 | (* プログラム全体 = 浮動小数点数テーブル + トップレベル関数 + メインの式 (caml2html: sparcasm_prog) *)
68 | type prog = Prog of (Id.l * float) list * fundef list * t [@@deriving show]
69 |
70 | let fletd (x, e1, e2) = Let ((x, Type.Float), e1, e2)
71 | let seq (e1, e2) = Let ((Id.gentmp Type.Unit, Type.Unit), e1, e2)
72 |
73 | module X86 = struct
74 | let regs = (* Array.init 16 (fun i -> Printf.sprintf "%%r%d" i) *) [| "%eax"; "%ebx"; "%ecx"; "%edx"; "%esi"; "%edi" |]
75 | let fregs = Array.init 8 (fun i -> Printf.sprintf "%%xmm%d" i)
76 | let allregs = Array.to_list regs
77 | let allfregs = Array.to_list fregs
78 | let reg_cl = regs.(Array.length regs - 1)
79 | (* closure address (caml2html: sparcasm_regcl) *)
80 | (* let reg_sw = regs.(Array.length regs - 1) (* temporary for swap *)
81 | let reg_fsw = fregs.(Array.length fregs - 1) (* temporary for swap *) *)
82 | let reg_sp = "%ebp" (* stack pointer *)
83 | let reg_hp = "min_caml_hp" (* heap pointer (caml2html: sparcasm_reghp) *)
84 | (* let reg_ra = "%eax" (* return address *) *)
85 | let is_reg x = x.[0] = '%' || x = reg_hp
86 | end
87 |
88 | module X64 = struct
89 | let regs = (* Array.init 16 (fun i -> Printf.sprintf "%%r%d" i) *) [| "%rax"; "%rbx"; "%rcx"; "%rdx"; "%rsi"; "%rdi" |]
90 | let fregs = Array.init 8 (fun i -> Printf.sprintf "%%xmm%d" i)
91 | let allregs = Array.to_list regs
92 | let allfregs = Array.to_list fregs
93 | let reg_cl = regs.(Array.length regs - 1)
94 | (* closure address (caml2html: sparcasm_regcl) *)
95 | let reg_sp = "%rbp" (* stack pointer *)
96 | let reg_hp = "min_caml_hp" (* heap pointer (caml2html: sparcasm_reghp) *)
97 | let is_reg x = x.[0] = '%' || x = reg_hp
98 | end
99 |
100 | module ARM64 = struct
101 | let regs = (* Array.init 27 (fun i -> Printf.sprintf "_R_%d" i) *)
102 | [| "%x0"; "%x1"; "%x2"; "%x3"; "%x4"; "%x5"; "%x6"; "%x7"; "%x8"; "%x9"; "%x10";
103 | "%x11"; "%x12"; "%x13"; "%x14"; "%x15"; "%x16"; "%x17"; "%x18"; "%x19"; "%x20";
104 | "%x21"; "%x22"; "%x23"; "%x24"; "%x25" |]
105 | let fregs = Array.init 32 (fun i -> Printf.sprintf "%%d%d" i)
106 | let allregs = Array.to_list regs
107 | let allfregs = Array.to_list fregs
108 | let reg_cl = regs.(Array.length regs - 1) (* closure address (caml2html: sparcasm_regcl) *)
109 | let reg_sw = regs.(Array.length regs - 2) (* temporary for swap *)
110 | let reg_fsw = fregs.(Array.length fregs - 1) (* temporary for swap *)
111 | let reg_sp = "%x28" (* stack pointer *)
112 | let reg_hp = "%x27" (* heap pointer (caml2html: sparcasm_reghp) *)
113 | let reg_tmp = "%x26" (* [XX] ad hoc *)
114 | let is_reg x = (x.[0] = '%')
115 | end
116 |
117 | (* super-tenuki *)
118 | let rec remove_and_uniq xs = function
119 | | [] -> []
120 | | x :: ys when S.mem x xs -> remove_and_uniq xs ys
121 | | x :: ys -> x :: remove_and_uniq (S.add x xs) ys
122 |
123 | (* free variables in the order of use (for spilling) (caml2html: sparcasm_fv) *)
124 | let fv_id_or_imm = function V x -> [ x ] | _ -> []
125 |
126 | let rec fv_exp = function
127 | | Nop | SetL _ | Comment _ | Restore _ -> []
128 | | Mov x | Neg x | FMov x | FNeg x | Save (x, _) -> [ x ]
129 | | Add (x, y') | Mul (x, y') | Sub (x, y') | Div (x, y') | Mod (x, y')
130 | | Ld (x, y', _) | LdDF (x, y', _) -> x :: fv_id_or_imm y'
131 | | St (x, y, z', _) | StDF (x, y, z', _) -> x :: y :: fv_id_or_imm z'
132 | | Slw(x, y') | Lfd(x, y') | Lwz(x, y') -> x :: fv_id_or_imm y'
133 | | Stw(x, y, z') | Stfd(x, y, z') -> x :: y :: fv_id_or_imm z'
134 | | FAdd (x, y) | FSub (x, y) | FMul (x, y) | FDiv (x, y) -> [ x; y ]
135 | | IfEq (x, y', e1, e2) | IfLE (x, y', e1, e2) | IfGE (x, y', e1, e2) -> (x :: fv_id_or_imm y') @ remove_and_uniq S.empty (fv e1 @ fv e2)
136 | (* uniq here just for efficiency *)
137 | | IfFEq (x, y, e1, e2) | IfFLE (x, y, e1, e2) -> x :: y :: remove_and_uniq S.empty (fv e1 @ fv e2)
138 | (* uniq here just for efficiency *)
139 | | CallCls (x, ys, zs) -> (x :: ys) @ zs
140 | | CallDir (_, ys, zs) -> ys @ zs
141 | | _ -> []
142 |
143 | and fv = function
144 | | Ans exp -> fv_exp exp
145 | | Let ((x, t), exp, e) -> fv_exp exp @ remove_and_uniq (S.singleton x) (fv e)
146 |
147 | let fv e = remove_and_uniq S.empty (fv e)
148 |
149 | let rec concat e1 xt e2 =
150 | match e1 with
151 | | Ans exp -> Let (xt, exp, e2)
152 | | Let (yt, exp, e1') -> Let (yt, exp, concat e1' xt e2)
153 |
154 | let align i = if i mod 8 = 0 then i else i + 4
155 |
156 | (* all local variables *)
157 | let rec localvs_exp = function
158 | | IfEq (_, _, e1, e2)
159 | | IfLE (_, _, e1, e2)
160 | | IfGE (_, _, e1, e2)
161 | | IfFEq (_, _, e1, e2)
162 | | IfFLE (_, _, e1, e2) ->
163 | localvs e1 @ localvs e2
164 | | _ -> []
165 |
166 | and localvs = function
167 | | Ans exp -> localvs_exp exp
168 | | Let (xt, exp, e) -> (xt :: localvs_exp exp) @ localvs e
169 |
--------------------------------------------------------------------------------
/src/joe/asm.mli:
--------------------------------------------------------------------------------
1 | type id_or_imm =
2 | | V of Id.t
3 | | C of int
4 |
5 | type t =
6 | | Ans of exp
7 | | Let of (Id.t * Type.t) * exp * t
8 |
9 | and exp =
10 | | Nop
11 | | Li of int
12 | | FLi of Id.l
13 | | SetL of Id.l
14 | | Mr of Id.t
15 | | Mov of Id.t
16 | (* ALU instructions *)
17 | | Neg of Id.t
18 | | Add of Id.t * id_or_imm
19 | | Sub of Id.t * id_or_imm
20 | | Mul of Id.t * id_or_imm
21 | | Div of Id.t * id_or_imm
22 | | Mod of Id.t * id_or_imm
23 | (* load/store instructions *)
24 | | Lfd of Id.t * id_or_imm
25 | | Lwz of Id.t * id_or_imm
26 | | Ld of Id.t * id_or_imm * int
27 | | Slw of Id.t * id_or_imm
28 | | Stw of Id.t * Id.t * id_or_imm
29 | | Stfd of Id.t * Id.t * id_or_imm
30 | | St of Id.t * Id.t * id_or_imm * int
31 | (* float instructions *)
32 | | FMov of Id.t
33 | | FNeg of Id.t
34 | | FAdd of Id.t * Id.t
35 | | FSub of Id.t * Id.t
36 | | FMul of Id.t * Id.t
37 | | FDiv of Id.t * Id.t
38 | | LdDF of Id.t * id_or_imm * int
39 | | StDF of Id.t * Id.t * id_or_imm * int
40 | | FMr of Id.t
41 | | Comment of string
42 | (* virtual instructions *)
43 | | IfEq of Id.t * id_or_imm * t * t
44 | | IfLE of Id.t * id_or_imm * t * t
45 | | IfGE of Id.t * id_or_imm * t * t (* 左右対称ではないので必要 *)
46 | | IfFEq of Id.t * Id.t * t * t
47 | | IfFLE of Id.t * Id.t * t * t
48 | (* closure address, integer arguments, and float arguments *)
49 | | CallCls of Id.t * Id.t list * Id.t list
50 | | CallDir of Id.l * Id.t list * Id.t list
51 | | Save of Id.t * Id.t (* レジスタ変数の値をスタック変数へ保存 (caml2html: sparcasm_save) *)
52 | | Restore of Id.t (* スタック変数から値を復元 (caml2html: sparcasm_restore) *)
53 |
54 | type fundef =
55 | { name : Id.l
56 | ; args : Id.t list
57 | ; fargs : Id.t list
58 | ; body : t
59 | ; ret : Type.t
60 | ; mutable annot : [ `TJ | `MJ ] option
61 | }
62 |
63 | type prog = Prog of (Id.l * float) list * fundef list * t
64 |
65 | val show : t -> string
66 | val show_exp : exp -> string
67 | val show_fundef : fundef -> string
68 | val show_prog : prog -> string
69 | val fletd : Id.t * exp * t -> t (* shorthand of Let for float *)
70 |
71 | val seq : exp * t -> t (* shorthand of Let for unit *)
72 |
73 | module X86 : sig
74 | val regs : Id.t array
75 | val fregs : Id.t array
76 | val allregs : Id.t list
77 | val allfregs : Id.t list
78 | val reg_cl : Id.t
79 | (* val reg_sw : Id.t
80 | val reg_fsw : Id.t
81 | val reg_ra : Id.t *)
82 | val reg_hp : Id.t
83 | val reg_sp : Id.t
84 | val is_reg : Id.t -> bool
85 | end
86 |
87 | module X64 : sig
88 | val regs : Id.t array
89 | val fregs : Id.t array
90 | val allregs : Id.t list
91 | val allfregs : Id.t list
92 | val reg_cl : Id.t
93 | val reg_hp : Id.t
94 | val reg_sp : Id.t
95 | val is_reg : Id.t -> bool
96 | end
97 |
98 | module ARM64 : sig
99 | val regs : Id.t array
100 | val fregs : Id.t array
101 | val allregs : Id.t list
102 | val allfregs : Id.t list
103 | val reg_cl : Id.t
104 | val reg_sw : Id.t
105 | val reg_fsw : Id.t
106 | val reg_sp : Id.t
107 | val reg_hp : Id.t
108 | val reg_tmp : Id.t
109 | val is_reg : Id.t -> bool
110 | end
111 |
112 | val fv : t -> Id.t list
113 | val concat : t -> Id.t * Type.t -> t -> t
114 | val align : int -> int
115 | val localvs : t -> (Id.t * Type.t) list
116 |
--------------------------------------------------------------------------------
/src/joe/assoc.ml:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/groupoid/joe/4bbf1a33ef17e076df3bac47fe32e5604243b2d5/src/joe/assoc.ml
--------------------------------------------------------------------------------
/src/joe/assoc.mli:
--------------------------------------------------------------------------------
1 | val f : KNormal.t -> KNormal.t
2 |
--------------------------------------------------------------------------------
/src/joe/beta.ml:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/groupoid/joe/4bbf1a33ef17e076df3bac47fe32e5604243b2d5/src/joe/beta.ml
--------------------------------------------------------------------------------
/src/joe/beta.mli:
--------------------------------------------------------------------------------
1 | val f : KNormal.t -> KNormal.t
2 |
--------------------------------------------------------------------------------
/src/joe/closure.ml:
--------------------------------------------------------------------------------
1 | type closure =
2 | { entry : Id.l
3 | ; actual_fv : Id.t list
4 | }
5 |
6 | type t = (* クロージャ変換後の式 (caml2html: closure_t) *)
7 | | Unit
8 | | Int of int
9 | | Float of float
10 | | Neg of Id.t
11 | | Add of Id.t * Id.t
12 | | Sub of Id.t * Id.t
13 | | Mul of Id.t * Id.t
14 | | Div of Id.t * Id.t
15 | | Mod of Id.t * Id.t
16 | | FNeg of Id.t
17 | | FAdd of Id.t * Id.t
18 | | FSub of Id.t * Id.t
19 | | FMul of Id.t * Id.t
20 | | FDiv of Id.t * Id.t
21 | | IfEq of Id.t * Id.t * t * t
22 | | IfLE of Id.t * Id.t * t * t
23 | | Let of (Id.t * Type.t) * t * t
24 | | Var of Id.t
25 | | MakeCls of (Id.t * Type.t) * closure * t
26 | | AppCls of Id.t * Id.t list
27 | | AppDir of Id.l * Id.t list
28 | | Tuple of Id.t list
29 | | LetTuple of (Id.t * Type.t) list * Id.t * t
30 | | Get of Id.t * Id.t
31 | | Put of Id.t * Id.t * Id.t
32 | | ExtArray of Id.l
33 |
34 | type fundef =
35 | { name : Id.l * Type.t
36 | ; args : (Id.t * Type.t) list
37 | ; formal_fv : (Id.t * Type.t) list
38 | ; body : t
39 | ; mutable annot : [ `TJ | `MJ ] option
40 | }
41 |
42 | type prog = Prog of fundef list * t
43 |
44 | let rec fv = function
45 | | Unit | Int _ | Float _ | ExtArray _ -> S.empty
46 | | Neg x | FNeg x -> S.singleton x
47 | | Add (x, y)
48 | | Sub (x, y)
49 | | Mul (x, y)
50 | | Div (x, y)
51 | | Mod (x, y)
52 | | FAdd (x, y)
53 | | FSub (x, y)
54 | | FMul (x, y)
55 | | FDiv (x, y)
56 | | Get (x, y) -> S.of_list [ x; y ]
57 | | IfEq (x, y, e1, e2) | IfLE (x, y, e1, e2) -> S.add x (S.add y (S.union (fv e1) (fv e2)))
58 | | Let ((x, t), e1, e2) -> S.union (fv e1) (S.remove x (fv e2))
59 | | Var x -> S.singleton x
60 | | MakeCls ((x, t), { entry = l; actual_fv = ys }, e) -> S.remove x (S.union (S.of_list ys) (fv e))
61 | | AppCls (x, ys) -> S.of_list (x :: ys)
62 | | AppDir (_, xs) | Tuple xs -> S.of_list xs
63 | | LetTuple (xts, y, e) -> S.add y (S.diff (fv e) (S.of_list (List.map fst xts)))
64 | | Put (x, y, z) -> S.of_list [ x; y; z ]
65 |
66 | let toplevel : fundef list ref = ref []
67 |
68 | let rec g env known = function (* クロージャ変換ルーチン本体 (caml2html: closure_g) *)
69 | | KNormal.Unit -> Unit
70 | | KNormal.Int i -> Int i
71 | | KNormal.Float d -> Float d
72 | | KNormal.Neg x -> Neg x
73 | | KNormal.Add (x, y) -> Add (x, y)
74 | | KNormal.Sub (x, y) -> Sub (x, y)
75 | | KNormal.Mul (x, y) -> Mul (x, y)
76 | | KNormal.Div (x, y) -> Div (x, y)
77 | | KNormal.Mod (x, y) -> Mod (x, y)
78 | | KNormal.FNeg x -> FNeg x
79 | | KNormal.FAdd (x, y) -> FAdd (x, y)
80 | | KNormal.FSub (x, y) -> FSub (x, y)
81 | | KNormal.FMul (x, y) -> FMul (x, y)
82 | | KNormal.FDiv (x, y) -> FDiv (x, y)
83 | | KNormal.IfEq (x, y, e1, e2) -> IfEq (x, y, g env known e1, g env known e2)
84 | | KNormal.IfLE (x, y, e1, e2) -> IfLE (x, y, g env known e1, g env known e2)
85 | | KNormal.Let ((x, t), e1, e2) -> Let ((x, t), g env known e1, g (M.add x t env) known e2)
86 | | KNormal.Var x -> Var x
87 | | KNormal.LetRec ({ KNormal.name = x, t; KNormal.args = yts; KNormal.body = e1; annot }, e2) ->
88 | (* 関数定義の場合 (caml2html: closure_letrec) *)
89 | (* 関数定義let rec x y1 ... yn = e1 in e2の場合は、
90 | xに自由変数がない(closureを介さずdirectに呼び出せる)
91 | と仮定し、knownに追加してe1をクロージャ変換してみる *)
92 | let toplevel_backup = !toplevel in
93 | let env' = M.add x t env in
94 | let known' = S.add x known in
95 | let e1' = g (M.add_list yts env') known' e1 in
96 | (* 本当に自由変数がなかったか、変換結果e1'を確認する *)
97 | (* 注意: e1'にx自身が変数として出現する場合はclosureが必要!
98 | (thanks to nuevo-namasute and azounoman; test/cls-bug2.ml参照) *)
99 | let zs = S.diff (fv e1') (S.of_list (List.map fst yts)) in
100 | let known', e1' = if S.is_empty zs then known', e1' else
101 | (* 駄目だったら状態(toplevelの値)を戻して、クロージャ変換をやり直す *)
102 | ( Format.eprintf "free variable(s) %s found in function %s@." (Id.pp_list (S.elements zs)) x;
103 | Format.eprintf "function %s cannot be directly applied in fact@." x;
104 | toplevel := toplevel_backup; let e1' = g (M.add_list yts env') known e1 in known, e1' ) in
105 | let zs = S.elements (S.diff (fv e1') (S.add x (S.of_list (List.map fst yts)))) in (* 自由変数のリスト *)
106 | let zts = List.map (fun z -> z, M.find z env') zs in (* ここで自由変数zの型を引くために引数envが必要 *)
107 | toplevel := { name = Id.L x, t; args = yts; formal_fv = zts; body = e1'; annot } :: !toplevel; (* トップレベル関数を追加 *)
108 | let e2' = g env' known' e2 in
109 | if S.mem x (fv e2') then (* xが変数としてe2'に出現するか *)
110 | MakeCls ((x, t), { entry = Id.L x; actual_fv = zs }, e2') (* 出現していたら削除しない *)
111 | else (Format.eprintf "eliminating closure(s) %s@." x; e2') (* 出現しなければMakeClsを削除 *)
112 | | KNormal.App (x, ys) when S.mem x known -> (* 関数適用の場合 (caml2html: closure_app) *)
113 | Format.eprintf "directly applying %s@." x; AppDir (Id.L x, ys)
114 | | KNormal.App (f, xs) -> AppCls (f, xs)
115 | | KNormal.Tuple xs -> Tuple xs
116 | | KNormal.LetTuple (xts, y, e) -> LetTuple (xts, y, g (M.add_list xts env) known e)
117 | | KNormal.Get (x, y) -> Get (x, y)
118 | | KNormal.Put (x, y, z) -> Put (x, y, z)
119 | | KNormal.ExtArray x -> ExtArray (Id.L x)
120 | | KNormal.ExtFunApp (x, ys) -> AppDir (Id.L ("min_caml_" ^ x), ys)
121 |
122 | let f e =
123 | toplevel := [];
124 | let e' = g M.empty S.empty e in
125 | Prog (List.rev !toplevel, e')
126 |
--------------------------------------------------------------------------------
/src/joe/closure.mli:
--------------------------------------------------------------------------------
1 | type closure =
2 | { entry : Id.l
3 | ; actual_fv : Id.t list
4 | }
5 |
6 | type t =
7 | | Unit
8 | | Int of int
9 | | Float of float
10 | | Neg of Id.t
11 | | Add of Id.t * Id.t
12 | | Sub of Id.t * Id.t
13 | | Mul of Id.t * Id.t
14 | | Div of Id.t * Id.t
15 | | Mod of Id.t * Id.t
16 | | FNeg of Id.t
17 | | FAdd of Id.t * Id.t
18 | | FSub of Id.t * Id.t
19 | | FMul of Id.t * Id.t
20 | | FDiv of Id.t * Id.t
21 | | IfEq of Id.t * Id.t * t * t
22 | | IfLE of Id.t * Id.t * t * t
23 | | Let of (Id.t * Type.t) * t * t
24 | | Var of Id.t
25 | | MakeCls of (Id.t * Type.t) * closure * t
26 | | AppCls of Id.t * Id.t list
27 | | AppDir of Id.l * Id.t list
28 | | Tuple of Id.t list
29 | | LetTuple of (Id.t * Type.t) list * Id.t * t
30 | | Get of Id.t * Id.t
31 | | Put of Id.t * Id.t * Id.t
32 | | ExtArray of Id.l
33 |
34 | type fundef =
35 | { name : Id.l * Type.t
36 | ; args : (Id.t * Type.t) list
37 | ; formal_fv : (Id.t * Type.t) list
38 | ; body : t
39 | ; mutable annot : [ `TJ | `MJ ] option
40 | }
41 |
42 | type prog = Prog of fundef list * t
43 |
44 | val fv : t -> S.t
45 | val f : KNormal.t -> prog
46 |
--------------------------------------------------------------------------------
/src/joe/constFold.ml:
--------------------------------------------------------------------------------
1 | open KNormal
2 |
3 | let memi x env = try match M.find x env with Int _ -> true | _ -> false with | Not_found -> false
4 | let memf x env = try match M.find x env with Float _ -> true | _ -> false with | Not_found -> false
5 | let memt x env = try match M.find x env with Tuple _ -> true | _ -> false with | Not_found -> false
6 |
7 | let findi x env = match M.find x env with Int i -> i | _ -> raise Not_found
8 | let findf x env = match M.find x env with Float d -> d | _ -> raise Not_found
9 | let findt x env = match M.find x env with Tuple ys -> ys | _ -> raise Not_found
10 |
11 | let rec g env = function (* 定数畳み込みルーチン本体 (caml2html: constfold_g) *)
12 | | Var x when memi x env -> Int (findi x env)
13 | | Var(x) when memf x env -> Float(findf x env)
14 | | Var(x) when memt x env -> Tuple(findt x env)
15 | | Neg x when memi x env -> Int (-findi x env)
16 | | Add (x, y) when memi x env && memi y env -> Int (findi x env + findi y env) (* 足し算のケース (caml2html: constfold_add) *)
17 | | Sub (x, y) when memi x env && memi y env -> Int (findi x env - findi y env)
18 | | Mul (x, y) when memi x env && memi y env -> Int (findi x env * findi y env)
19 | | Mod (x, y) when memi x env && memi y env -> Int (findi x env mod findi y env)
20 | | FNeg x when memf x env -> Float (-.findf x env)
21 | | FAdd (x, y) when memf x env && memf y env -> Float (findf x env +. findf y env)
22 | | FSub (x, y) when memf x env && memf y env -> Float (findf x env -. findf y env)
23 | | FMul (x, y) when memf x env && memf y env -> Float (findf x env *. findf y env)
24 | | FDiv (x, y) when memf x env && memf y env -> Float (findf x env /. findf y env)
25 | | IfEq (x, y, e1, e2) when memi x env && memi y env -> if findi x env = findi y env then g env e1 else g env e2
26 | | IfEq (x, y, e1, e2) when memf x env && memf y env -> if findf x env = findf y env then g env e1 else g env e2
27 | | IfEq (x, y, e1, e2) -> IfEq (x, y, g env e1, g env e2)
28 | | IfLE (x, y, e1, e2) when memi x env && memi y env -> if findi x env <= findi y env then g env e1 else g env e2
29 | | IfLE (x, y, e1, e2) when memf x env && memf y env -> if findf x env <= findf y env then g env e1 else g env e2
30 | | IfLE (x, y, e1, e2) -> IfLE (x, y, g env e1, g env e2)
31 | | Let ((x, t), e1, e2) -> let e1' = g env e1 in let e2' = g (M.add x e1' env) e2 in Let ((x, t), e1', e2') (* letのケース (caml2html: constfold_let) *)
32 | | LetRec ({ name = x; args = ys; body = e1; annot }, e2) -> LetRec ({ name = x; args = ys; body = g env e1; annot }, g env e2)
33 | | LetTuple (xts, y, e) when memt y env -> List.fold_left2 (fun e' xt z -> Let (xt, Var z, e')) (g env e) xts (findt y env)
34 | | LetTuple (xts, y, e) -> LetTuple (xts, y, g env e)
35 | | e -> e
36 |
37 | let f = g M.empty
38 |
--------------------------------------------------------------------------------
/src/joe/constFold.mli:
--------------------------------------------------------------------------------
1 | val f : KNormal.t -> KNormal.t
2 |
--------------------------------------------------------------------------------
/src/joe/dune:
--------------------------------------------------------------------------------
1 | (ocamllex (modules lexer))
2 | (ocamlyacc (modules parser))
3 |
4 | (library
5 | (name MinCaml)
6 | (public_name joe.lib)
7 | (modules (:standard \ main))
8 | (flags (-w -4-33-40-41))
9 | (libraries str)
10 | (preprocess (pps ppx_deriving.show)))
11 |
12 | (executable
13 | (name main)
14 | (public_name joe)
15 | (flags (-w -4-33-40-41))
16 | (modules Main)
17 | (package joe)
18 | (libraries MinCaml BacCaml x64 arm64))
19 |
--------------------------------------------------------------------------------
/src/joe/elim.ml:
--------------------------------------------------------------------------------
1 | open KNormal
2 |
3 | let rec effect = function (* 副作用の有無 (caml2html: elim_effect) *)
4 | | Let(_, e1, e2) | IfEq(_, _, e1, e2) | IfLE(_, _, e1, e2) -> effect e1 || effect e2
5 | | LetRec(_, e) | LetTuple(_, _, e) -> effect e
6 | | App _ | Put _ | ExtFunApp _ -> true
7 | | _ -> false
8 |
9 | let rec f = function (* 不要定義削除ルーチン本体 (caml2html: elim_f) *)
10 | | IfEq (x, y, e1, e2) -> IfEq (x, y, f e1, f e2)
11 | | IfLE (x, y, e1, e2) -> IfLE (x, y, f e1, f e2)
12 | | Let ((x, t), e1, e2) -> (* letの場合 (caml2html: elim_let) *)
13 | let e1' = f e1 in
14 | let e2' = f e2 in
15 | if effect e1' || S.mem x (fv e2')
16 | then Let ((x, t), e1', e2')
17 | else ( Format.eprintf "eliminating variable %s@." x; e2')
18 | | LetRec ({ name = x, t; args = yts; body = e1; annot }, e2) -> (* let recの場合 (caml2html: elim_letrec) *)
19 | let e2' = f e2 in
20 | if S.mem x (fv e2')
21 | then LetRec ({ name = x, t; args = yts; body = f e1; annot }, e2')
22 | else (Format.eprintf "eliminating function %s@." x; e2')
23 | | LetTuple (xts, y, e) ->
24 | let xs = List.map fst xts in
25 | let e' = f e in
26 | let live = fv e' in
27 | if List.exists (fun x -> S.mem x live) xs
28 | then LetTuple (xts, y, e')
29 | else ( Format.eprintf "eliminating variables %s@." (Id.pp_list xs); e')
30 | | e -> e
31 |
--------------------------------------------------------------------------------
/src/joe/elim.mli:
--------------------------------------------------------------------------------
1 | val f : KNormal.t -> KNormal.t
2 |
--------------------------------------------------------------------------------
/src/joe/id.ml:
--------------------------------------------------------------------------------
1 | type t = string (* 変数の名前 (caml2html: id_t) *) [@@deriving show]
2 | type l = L of string (* トップレベル関数やグローバル配列のラベル (caml2html: id_l) *) [@@deriving show]
3 |
4 | let rec pp_list = function
5 | | [] -> ""
6 | | [x] -> x
7 | | x :: xs -> x ^ " " ^ pp_list xs
8 |
9 | let counter = ref 0
10 | let genid s = incr counter; Printf.sprintf "%s.%d" s !counter
11 |
12 | let rec id_of_typ = function
13 | | Type.Unit -> "u"
14 | | Type.Bool -> "b"
15 | | Type.Int -> "i"
16 | | Type.Float -> "d"
17 | | Type.Fun _ -> "f"
18 | | Type.Tuple _ -> "t"
19 | | Type.Array _ -> "a"
20 | | Type.Var _ -> assert false
21 |
22 | let gentmp typ = incr counter; Printf.sprintf "T%s%d" (id_of_typ typ) !counter
23 |
24 |
--------------------------------------------------------------------------------
/src/joe/inline.ml:
--------------------------------------------------------------------------------
1 | open KNormal
2 |
3 | (* インライン展開する関数の最大サイズ (caml2html: inline_threshold) *)
4 | let threshold = ref 0 (* Mainで-inlineオプションによりセットされる *)
5 |
6 | let rec size = function
7 | | IfEq(_, _, e1, e2) | IfLE(_, _, e1, e2)
8 | | Let(_, e1, e2) | LetRec({ body = e1 }, e2) -> 1 + size e1 + size e2
9 | | LetTuple(_, _, e) -> 1 + size e
10 | | _ -> 1
11 |
12 | let rec g env = function (* インライン展開ルーチン本体 (caml2html: inline_g) *)
13 | | IfEq(x, y, e1, e2) -> IfEq(x, y, g env e1, g env e2)
14 | | IfLE(x, y, e1, e2) -> IfLE(x, y, g env e1, g env e2)
15 | | Let(xt, e1, e2) -> Let(xt, g env e1, g env e2)
16 | | LetRec({ name = (x, t); args = yts; body = e1 ; annot }, e2) -> (* 関数定義の場合 (caml2html: inline_letrec) *)
17 | let env = if size e1 > !threshold then env else M.add x (yts, e1) env in
18 | LetRec({ name = (x, t); args = yts; body = g env e1 ; annot }, g env e2)
19 | | App(x, ys) when M.mem x env -> (* 関数適用の場合 (caml2html: inline_app) *)
20 | let (zs, e) = M.find x env in Format.eprintf "inlining %s@." x;
21 | let env' = List.fold_left2 (fun env' (z, t) y -> M.add z y env') M.empty zs ys in Alpha.g env' e
22 | | LetTuple(xts, y, e) -> LetTuple(xts, y, g env e)
23 | | e -> e
24 |
25 | let f e = g M.empty e
26 |
27 |
--------------------------------------------------------------------------------
/src/joe/inline.mli:
--------------------------------------------------------------------------------
1 | val threshold : int ref
2 | val f : KNormal.t -> KNormal.t
3 |
--------------------------------------------------------------------------------
/src/joe/kNormal.ml:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/groupoid/joe/4bbf1a33ef17e076df3bac47fe32e5604243b2d5/src/joe/kNormal.ml
--------------------------------------------------------------------------------
/src/joe/kNormal.mli:
--------------------------------------------------------------------------------
1 | type t =
2 | | Unit
3 | | Int of int
4 | | Float of float
5 | | Neg of Id.t
6 | | Add of Id.t * Id.t
7 | | Sub of Id.t * Id.t
8 | | Mul of Id.t * Id.t
9 | | Div of Id.t * Id.t
10 | | Mod of Id.t * Id.t
11 | | FNeg of Id.t
12 | | FAdd of Id.t * Id.t
13 | | FSub of Id.t * Id.t
14 | | FMul of Id.t * Id.t
15 | | FDiv of Id.t * Id.t
16 | | IfEq of Id.t * Id.t * t * t
17 | | IfLE of Id.t * Id.t * t * t
18 | | Let of (Id.t * Type.t) * t * t
19 | | Var of Id.t
20 | | LetRec of fundef * t
21 | | App of Id.t * Id.t list
22 | | Tuple of Id.t list
23 | | LetTuple of (Id.t * Type.t) list * Id.t * t
24 | | Get of Id.t * Id.t
25 | | Put of Id.t * Id.t * Id.t
26 | | ExtArray of Id.t
27 | | ExtFunApp of Id.t * Id.t list
28 |
29 | and fundef =
30 | { name : Id.t * Type.t
31 | ; args : (Id.t * Type.t) list
32 | ; body : t
33 | ; mutable annot : [ `TJ | `MJ ] option
34 | }
35 |
36 | val show : t -> string
37 | val show_fundef : fundef -> string
38 | val fv : t -> S.t
39 | val f : Syntax.t -> t
40 |
--------------------------------------------------------------------------------
/src/joe/lexer.mll:
--------------------------------------------------------------------------------
1 | { (* lexerが利用する変数、関数、型などの定義 *)
2 | open Parser
3 | open Type
4 | }
5 |
6 | (* 正規表現の略記 *)
7 | let space = [' ' '\t' '\n' '\r']
8 | let digit = ['0'-'9']
9 | let lower = ['a'-'z']
10 | let upper = ['A'-'Z']
11 |
12 | rule token = parse
13 | | space+ { token lexbuf }
14 | | "(*" { comment lexbuf; (* ネストしたコメントのためのトリック *) token lexbuf }
15 | | '(' { LPAREN }
16 | | ')' { RPAREN }
17 | | "true" { BOOL(true) }
18 | | "false" { BOOL(false) }
19 | | "not" { NOT }
20 | | digit+ (* 整数を字句解析するルール (caml2html: lexer_int) *) { INT(int_of_string (Lexing.lexeme lexbuf)) }
21 | | digit+ ('.' digit*)? (['e' 'E'] ['+' '-']? digit+)? { FLOAT(float_of_string (Lexing.lexeme lexbuf)) }
22 | | '-' (* -.より後回しにしなくても良い? 最長一致? *) { MINUS }
23 | | '+' (* +.より後回しにしなくても良い? 最長一致? *) { PLUS }
24 | | '*' { AST }
25 | | '/' { SLASH }
26 | | "-." { MINUS_DOT }
27 | | "+." { PLUS_DOT }
28 | | "*." { AST_DOT }
29 | | "/." { SLASH_DOT }
30 | | '=' { EQUAL }
31 | | '%' { PERCENT }
32 | | "<>" { LESS_GREATER }
33 | | "<=" { LESS_EQUAL }
34 | | ">=" { GREATER_EQUAL }
35 | | '<' { LESS }
36 | | '>' { GREATER }
37 | | "if" { IF }
38 | | "then" { THEN }
39 | | "else" { ELSE }
40 | | "let" { LET }
41 | | "mod" { MOD }
42 | | "in" { IN }
43 | | "rec" { REC }
44 | | ',' { COMMA }
45 | | '_' { IDENT(Id.gentmp Type.Unit) }
46 | | "Array.create" | "Array.make" (* [XX] ad hoc *) { ARRAY_CREATE }
47 | | '.' { DOT }
48 | | "<-" { LESS_MINUS }
49 | | ';' { SEMICOLON }
50 | | ";;" { SEMISEMI }
51 | | '[' { LBRAC }
52 | | ']' { RBRAC }
53 | | '|' { VBAR }
54 | | eof { EOF }
55 | | lower (digit|lower|upper|'_')* (* 他の「予約語」より後でないといけない *) { IDENT(Lexing.lexeme lexbuf) }
56 | | _ { failwith (Printf.sprintf "unknown token %s near characters %d-%d"
57 | (Lexing.lexeme lexbuf) (Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf)) }
58 |
59 | and comment = parse
60 | | "*)" { () }
61 | | "(*" { comment lexbuf; comment lexbuf }
62 | | eof { Format.eprintf "warning: unterminated comment@." }
63 | | _ { comment lexbuf }
64 |
65 |
--------------------------------------------------------------------------------
/src/joe/m.ml:
--------------------------------------------------------------------------------
1 | (* customized version of Map *)
2 |
3 | module M = Map.Make (struct
4 | type t = Id.t
5 |
6 | let compare = compare
7 | end)
8 |
9 | include M
10 |
11 | let add_list xys env = List.fold_left (fun env (x, y) -> add x y env) env xys
12 | let add_list2 xs ys env = List.fold_left2 (fun env x y -> add x y env) env xs ys
13 |
--------------------------------------------------------------------------------
/src/joe/main.ml:
--------------------------------------------------------------------------------
1 | open MinCaml
2 | open BacCaml
3 | open Stdlib
4 |
5 | type backend =
6 | | Intel
7 | | ARM
8 | | Virtual
9 |
10 | let backend_type = ref ARM
11 | let debug = ref false
12 | let ast_dump = ref false
13 | let with_flag flag ~tru:f ~fls:g = if !flag then f () else g ()
14 |
15 | let ast oc l =
16 | Id.counter := 0;
17 | Parser.exp Lexer.token l |> Syntax.show |> print_endline
18 | ;;
19 |
20 | let lexbuf oc l =
21 | Id.counter := 0;
22 | Typing.extenv := M.empty;
23 | Parser.exp Lexer.token l
24 | |> Typing.f
25 | |> KNormal.f
26 | |> Alpha.f
27 | |> Util.(iter !limit)
28 | |> Closure.f
29 | |> Virtual.f
30 | |> Simm.f
31 | |> fun p ->
32 | match !backend_type with
33 | | Intel -> X64.RegAlloc.f p |> X64.Emit.f oc
34 | | ARM -> Arm64.RegAlloc.f p |> Arm64.Emit.f oc
35 | | Virtual -> Stdlib.output_bytes oc (Marshal.to_bytes (Emit.f p) [Marshal.No_sharing])
36 |
37 | let string s = lexbuf stdout (Lexing.from_string s)
38 |
39 | let open_rewrite f = open_out_gen [Open_binary;Open_wronly;Open_creat] 0o644 f
40 |
41 |
42 | let backend_type_to_arch = function
43 | | Intel -> "x64"
44 | | ARM -> "arm64"
45 | | Virtual -> failwith "Virtual machine does not have an architecture"
46 |
47 | let backend_type_to_suffix = function
48 | | Intel -> ".intel.s"
49 | | ARM -> ".arm.s"
50 | | Virtual -> ".joe"
51 |
52 |
53 | let write_file f f_without_filename sufix =
54 | let inchan = open_in f in
55 | let outchan = open_rewrite (f_without_filename ^ sufix) in
56 | try
57 | let input = Lexing.from_channel inchan in
58 | with_flag ast_dump
59 | ~tru:(fun _ -> ast outchan input)
60 | ~fls:(fun _ -> lexbuf outchan input; close_in inchan; close_out outchan);
61 | with
62 | | e ->
63 | close_in inchan;
64 | close_out outchan;
65 | raise e
66 |
67 | let main f =
68 | let f_without_filename = Filename.remove_extension f in
69 | let sufix = backend_type_to_suffix !backend_type in
70 | write_file f f_without_filename sufix;
71 | match !backend_type with
72 | | Intel | ARM ->
73 | ( let arch = backend_type_to_arch !backend_type in
74 | String.concat " " [ "gcc"; f_without_filename^sufix;
75 | "src/"^arch^"/libmincaml.c src/"^arch^"/stub.c -o ";
76 | f_without_filename ^ ".exe"] |> Sys.command |> ignore )
77 | | _ -> ()
78 |
79 | let () =
80 | let files = ref [] in
81 | Arg.parse
82 | [ ( "-inline", Arg.Int (fun i -> Inline.threshold := i) , "maximum size of functions inlined" ) ;
83 | ( "-iter", Arg.Int (fun i -> Util.limit := i), "maximum number of optimizations iterated" ) ;
84 | ( "-ast", Arg.Unit (fun _ -> ast_dump := true), "emit abstract syntax tree" ) ;
85 | ( "-x86", Arg.Unit (fun _ -> backend_type := Intel) , "emit IA32 machine code" ) ;
86 | ( "-x64", Arg.Unit (fun _ -> backend_type := Intel) , "emit EM64T machine code" ) ;
87 | ( "-arm" , Arg.Unit (fun _ -> backend_type := ARM) , "emit AArch64 machine code" ) ;
88 | ( "-vm" , Arg.Unit (fun _ -> backend_type := Virtual) , "emit MinCaml IR virtual machine" ) ;
89 | ( "-debug", Arg.Unit (fun _ -> debug := true), "enable debug mode" )
90 | ]
91 | (fun s -> files := !files @ [ s ])
92 | ("MinCaml EM64T/AArch64/IR Compiler (c) 2024 Namdak Tonpa\n"
93 | ^ "usage: joe [-inline m] [-iter n] ... filenames" );
94 | List.iter (fun f -> main f) !files
95 |
96 |
--------------------------------------------------------------------------------
/src/joe/main.mli:
--------------------------------------------------------------------------------
1 | val main : string -> unit
2 |
--------------------------------------------------------------------------------
/src/joe/parser.mly:
--------------------------------------------------------------------------------
1 | %{
2 | (* parserが利用する変数、関数、型などの定義 *)
3 | open Syntax
4 | let addtyp x = (x, Type.gentyp ())
5 | let annot_of_var var = if var = "mj" then Some `MJ else if var = "tj" then Some `TJ else None
6 | %}
7 |
8 | /* (* 字句を表すデータ型の定義 (caml2html: parser_token) *) */
9 | %token BOOL
10 | %token INT
11 | %token FLOAT
12 | %token NOT
13 | %token MINUS
14 | %token PLUS
15 | %token AST
16 | %token SLASH
17 | %token MINUS_DOT
18 | %token PLUS_DOT
19 | %token AST_DOT
20 | %token SLASH_DOT
21 | %token EQUAL
22 | %token LESS_GREATER
23 | %token LESS_EQUAL
24 | %token GREATER_EQUAL
25 | %token LESS
26 | %token GREATER
27 | %token IF
28 | %token THEN
29 | %token ELSE
30 | %token MOD
31 | %token IDENT
32 | %token LET
33 | %token IN
34 | %token REC
35 | %token COMMA
36 | %token ARRAY_CREATE
37 | %token DOT
38 | %token LESS_MINUS
39 | %token SEMICOLON
40 | %token SEMISEMI
41 | %token LPAREN
42 | %token RPAREN
43 | %token LBRAC
44 | %token RBRAC
45 | %token VBAR
46 | %token PERCENT
47 | %token EOF
48 |
49 | /* (* 優先順位とassociativityの定義（低い方から高い方へ） (caml2html: parser_prior) *) */
50 | %nonassoc IN
51 | %right prec_let
52 | %right SEMICOLON
53 | %right prec_if
54 | %right LESS_MINUS
55 | %nonassoc prec_tuple
56 | %left COMMA
57 | %left EQUAL LESS_GREATER LESS GREATER LESS_EQUAL GREATER_EQUAL
58 | %left PLUS MINUS PLUS_DOT MINUS_DOT MOD
59 | %left AST_DOT SLASH_DOT
60 | %right prec_unary_minus
61 | %left prec_app
62 | %left DOT
63 |
64 | /* (* 開始記号の定義 *) */
65 | %type exp
66 | %start exp
67 |
68 | %%
69 |
70 | simple_exp: /* (* 括弧をつけなくても関数の引数になれる式 (caml2html: parser_simple) *) */
71 | | LPAREN exp RPAREN { $2 }
72 | | LPAREN RPAREN { Unit }
73 | | BOOL { Bool($1) }
74 | | INT { Int($1) }
75 | | FLOAT { Float($1) }
76 | | IDENT { Var($1) }
77 | | simple_exp DOT LPAREN exp RPAREN { Get($1, $4) }
78 |
79 | exp: /* (* 一般の式 (caml2html: parser_exp) *) */
80 | | simple_exp { $1 }
81 | | NOT exp %prec prec_app { Not($2) } /* (* -1.23などは型エラーではないので別扱い *) */
82 | | MINUS exp %prec prec_unary_minus { match $2 with | Float(f) -> Float(-.f) | e -> Neg(e) }
83 | | exp PLUS exp { Add($1, $3) }
84 | | exp MINUS exp { Sub($1, $3) }
85 | | exp EQUAL exp { Eq($1, $3) }
86 | | exp LESS_GREATER exp { Not(Eq($1, $3)) }
87 | | exp AST exp { Mul($1, $3)}
88 | | exp MOD exp { Mod ($1, $3) }
89 | | exp SLASH exp { Div($1, $3) }
90 | | exp LESS exp { Not(LE($3, $1)) }
91 | | exp GREATER exp { Not(LE($1, $3)) }
92 | | exp LESS_EQUAL exp { LE($1, $3) }
93 | | exp GREATER_EQUAL exp { LE($3, $1) }
94 | | IF exp THEN exp ELSE exp %prec prec_if { If($2, $4, $6) }
95 | | MINUS_DOT exp %prec prec_unary_minus { FNeg($2) }
96 | | exp PLUS_DOT exp { FAdd($1, $3) }
97 | | exp MINUS_DOT exp { FSub($1, $3) }
98 | | exp AST_DOT exp { FMul($1, $3) }
99 | | exp SLASH_DOT exp { FDiv($1, $3) }
100 | | LET IDENT EQUAL exp IN exp %prec prec_let { Let(addtyp $2, $4, $6) }
101 | | LET REC fundef SEMISEMI exp %prec prec_let { LetRec($3, $5) }
102 | | LET REC fundef IN exp %prec prec_let { LetRec($3, $5) }
103 | | LET PERCENT IDENT REC fundef IN exp %prec prec_let { let fundef = $5 in fundef.annot <- annot_of_var $3; LetRec(fundef, $7) }
104 | | simple_exp actual_args %prec prec_app { App($1, $2) }
105 | | elems %prec prec_tuple { Tuple($1) }
106 | | LET LPAREN pat RPAREN EQUAL exp IN exp { LetTuple($3, $6, $8) }
107 | | simple_exp DOT LPAREN exp RPAREN LESS_MINUS exp { Put($1, $4, $7) }
108 | | exp SEMICOLON exp { Let((Id.gentmp Type.Unit, Type.Unit), $1, $3) }
109 | | ARRAY_CREATE simple_exp simple_exp %prec prec_app { Array($2, $3) }
110 | | LET IDENT EQUAL lst IN exp
111 | {
112 | match $4 with
113 | | List (x) -> let create_array lst = let rec loop i = function
114 | | [] -> $6
115 | | hd :: tl -> Let((Id.gentmp Type.Unit, Type.Unit), Put (Var $2, Int i, hd), loop (i + 1) tl)
116 | in loop 0 lst in Let (addtyp $2, Array (Int (List.length x), Int (0)), create_array x)
117 | | _ -> failwith "list should be come here."
118 | }
119 | | error { failwith (Printf.sprintf "parse error near characters %d-%d"
120 | (Parsing.symbol_start ()) (Parsing.symbol_end ())) }
121 |
122 | fundef:
123 | | IDENT formal_args EQUAL exp { { name = addtyp $1; args = $2; body = $4; annot = None } }
124 |
125 | formal_args:
126 | | IDENT formal_args { addtyp $1 :: $2 }
127 | | IDENT { [addtyp $1] }
128 |
129 | actual_args:
130 | | actual_args simple_exp %prec prec_app { $1 @ [$2] }
131 | | simple_exp %prec prec_app { [$1] }
132 |
133 | elems:
134 | | elems COMMA exp { $1 @ [$3] }
135 | | exp COMMA exp { [$1; $3] }
136 |
137 | pat:
138 | | pat COMMA IDENT { $1 @ [addtyp $3] }
139 | | IDENT COMMA IDENT { [addtyp $1; addtyp $3] }
140 |
141 | lstcont:
142 | | { [] }
143 | | simple_exp { [$1] }
144 | | simple_exp SEMICOLON lstcont { $1 :: $3 }
145 |
146 | lst:
147 | | LBRAC VBAR lstcont VBAR RBRAC { List $3 }
148 |
--------------------------------------------------------------------------------
/src/joe/s.ml:
--------------------------------------------------------------------------------
1 | (* customized version of Set *)
2 |
3 | module S = Set.Make (struct
4 | type t = Id.t
5 | let compare = compare
6 | end)
7 |
8 | include S
9 |
10 | let of_list l = List.fold_left (fun s e -> add e s) empty l
11 |
--------------------------------------------------------------------------------
/src/joe/simm.ml:
--------------------------------------------------------------------------------
1 | open Asm
2 |
3 | let rec g env = function (* 命令列の16bit即値最適化 (caml2html: simm13_g) *)
4 | | Ans(exp) -> Ans(g' env exp)
5 | | Let((x, t), Li(i), e) when -32768 <= i && i < 32768 ->
6 | (* Format.eprintf "found simm16 %s = %d@." x i; *)
7 | let e' = g (M.add x i env) e in if List.mem x (fv e') then Let((x, t), Li(i), e') else
8 | ((* Format.eprintf "erased redundant Set to %s@." x; *) e')
9 | | Let(xt, Slw(y, C(i)), e) when M.mem y env -> (* for array access *)
10 | (* Format.eprintf "erased redundant Slw on %s@." x; *) g env (Let(xt, Li((M.find y env) lsl i), e))
11 | | Let(xt, exp, e) -> Let(xt, g' env exp, g env e)
12 |
13 | and g' env = function (* 各命令の16bit即値最適化 (caml2html: simm13_gprime) *)
14 | | Add (x, V y) when M.mem y env -> Add (x, C (M.find y env))
15 | | Add (x, V y) when M.mem x env -> Add (y, C (M.find x env))
16 | | Sub (x, V y) when M.mem y env -> Sub (x, C (M.find y env))
17 | | Sub (x, V y) when M.mem x env -> Sub (y, C (M.find x env))
18 | | Mul (x, V y) when M.mem y env -> Mul (x, C (M.find y env))
19 | | Mul (x, V y) when M.mem x env -> Mul (y, C (M.find x env))
20 | | Div (x, V y) when M.mem y env -> Div (x, C (M.find y env))
21 | | Div (x, V y) when M.mem x env -> Div (y, C (M.find x env))
22 | | Mod (x, V y) when M.mem y env -> Mod (x, C (M.find y env))
23 | | Mod (x, V y) when M.mem x env -> Mod (y, C (M.find x env))
24 | | Ld (x, V y, i) when M.mem y env -> Ld (x, C (M.find y env), i)
25 | | St (x, y, V z, i) when M.mem z env -> St (x, y, C (M.find z env), i)
26 | | LdDF (x, V y, i) when M.mem y env -> LdDF (x, C (M.find y env), i)
27 | | StDF (x, y, V z, i) when M.mem z env -> StDF (x, y, C (M.find z env), i)
28 | | IfEq (x, V y, e1, e2) when M.mem y env -> IfEq (x, C (M.find y env), g env e1, g env e2)
29 | | IfLE (x, V y, e1, e2) when M.mem y env -> IfLE (x, C (M.find y env), g env e1, g env e2)
30 | | IfGE (x, V y, e1, e2) when M.mem y env -> IfGE (x, C (M.find y env), g env e1, g env e2)
31 | | IfEq (x, V y, e1, e2) when M.mem x env -> IfEq (y, C (M.find x env), g env e1, g env e2)
32 | | IfLE (x, V y, e1, e2) when M.mem x env -> IfGE (y, C (M.find x env), g env e1, g env e2)
33 | | IfGE (x, V y, e1, e2) when M.mem x env -> IfLE (y, C (M.find x env), g env e1, g env e2)
34 | | IfEq (x, y', e1, e2) -> IfEq (x, y', g env e1, g env e2)
35 | | IfLE (x, y', e1, e2) -> IfLE (x, y', g env e1, g env e2)
36 | | IfGE (x, y', e1, e2) -> IfGE (x, y', g env e1, g env e2)
37 | | IfFEq (x, y, e1, e2) -> IfFEq (x, y, g env e1, g env e2)
38 | | IfFLE (x, y, e1, e2) -> IfFLE (x, y, g env e1, g env e2)
39 | | e -> e
40 |
41 | let h { name = l; args = xs; fargs = ys; body = e; ret = t; annot } = (* トップレベル関数の16bit即値最適化 *)
42 | { name = l; args = xs; fargs = ys; body = g M.empty e; ret = t; annot }
43 |
44 | let f (Prog (data, fundefs, e)) = (* プログラム全体の16bit即値最適化 *)
45 | Prog (data, List.map h fundefs, g M.empty e)
46 |
--------------------------------------------------------------------------------
/src/joe/simm.mli:
--------------------------------------------------------------------------------
1 | val f : Asm.prog -> Asm.prog
2 |
--------------------------------------------------------------------------------
/src/joe/syntax.ml:
--------------------------------------------------------------------------------
1 | type t = (* MinCamlの構文を表現するデータ型 (caml2html: syntax_t) *)
2 | | Unit
3 | | Bool of bool
4 | | Int of int
5 | | Float of float
6 | | Not of t
7 | | Neg of t
8 | | Add of t * t
9 | | Mul of t * t
10 | | Div of t * t
11 | | Sub of t * t
12 | | Mod of t * t
13 | | FNeg of t
14 | | FAdd of t * t
15 | | FSub of t * t
16 | | FMul of t * t
17 | | FDiv of t * t
18 | | Eq of t * t
19 | | LE of t * t
20 | | If of t * t * t
21 | | Let of (Id.t * Type.t) * t * t
22 | | Var of Id.t
23 | | LetRec of fundef * t
24 | | App of t * t list
25 | | Tuple of t list
26 | | LetTuple of (Id.t * Type.t) list * t * t
27 | | Array of t * t
28 | | Get of t * t
29 | | Put of t * t * t
30 | | List of t list [@@deriving show]
31 |
32 | and fundef =
33 | { name : Id.t * Type.t
34 | ; args : (Id.t * Type.t) list
35 | ; body : t
36 | ; mutable annot : [ `TJ | `MJ ] option
37 | } [@@deriving show]
38 |
39 | let rec print_t = function
40 | | Unit -> print_string "Unit"
41 | | Bool v -> Printf.printf "Bool(%s)" (string_of_bool v)
42 | | Int v -> Printf.printf "Int(%s)" (string_of_int v)
43 | | Float v -> Printf.printf "Float(%s)" (string_of_float v)
44 | | Not t -> print_string "Not("; print_t t; print_string ")"
45 | | Neg t -> print_string "Neg("; print_t t; print_string ")"
46 | | Add (t1, t2) -> print_string "Add("; print_t t1; print_string ", "; print_t t2; print_string ")"; print_string ")"
47 | | Sub (t1, t2) -> print_string "Sub("; print_t t1; print_string ", "; print_t t2; print_string ")"
48 | | FNeg t -> print_string "FNeg("; print_t t; print_string ")"
49 | | FAdd (t1, t2) -> print_string "FAdd("; print_t t1; print_string ", "; print_t t2; print_string ")"
50 | | FSub (t1, t2) -> print_string "FSub("; print_t t1; print_t t2; print_string ")"
51 | | FMul (t1, t2) -> print_string "FMul("; print_t t1; print_string ", "; print_t t2; print_string ")"
52 | | FDiv (t1, t2) -> print_string "FDiv("; print_t t1; print_string ", "; print_t t2; print_string ")"
53 | | Eq (t1, t2) -> print_string "Eq("; print_t t1; print_string ", "; print_t t2; print_string ")"
54 | | LE (t1, t2) ->
55 | print_string "LE(";
56 | print_t t1;
57 | print_string ", ";
58 | print_t t2;
59 | print_string ")"
60 | | If (t1, t2, t3) ->
61 | print_string "If(";
62 | print_t t1;
63 | print_string ", ";
64 | print_newline ();
65 | print_t t2;
66 | print_string ", ";
67 | print_newline ();
68 | print_t t3;
69 | print_string ")"
70 | | Let ((id, typ), t1, t2) ->
71 | print_string "Let(";
72 | print_string "(";
73 | print_string id;
74 | print_string ",";
75 | Type.print_t typ;
76 | print_string "), ";
77 | print_t t1;
78 | print_string ", ";
79 | print_newline ();
80 | print_t t2;
81 | print_string ")"
82 | | Var id ->
83 | print_string "Var(";
84 | print_string id;
85 | print_string ")"
86 | | LetRec (fundef, t) ->
87 | print_string "LetRec(";
88 | print_fundef fundef;
89 | print_string ", ";
90 | print_t t;
91 | print_string ")"
92 | | App (t, ts) ->
93 | print_string "App(";
94 | print_t t;
95 | print_string ", ";
96 | print_t_list ts;
97 | print_string ")"
98 | | Tuple ts ->
99 | print_string "Tuple(";
100 | print_t_list ts;
101 | print_string ")"
102 | | LetTuple (args, t1, t2) ->
103 | let rec print_args args =
104 | match args with
105 | | [] -> ()
106 | | [ (id, typ) ] ->
107 | print_string id;
108 | print_string ", ";
109 | Type.print_t typ
110 | | (id, typ) :: tl ->
111 | print_string id;
112 | print_string ", ";
113 | Type.print_t typ;
114 | print_args tl
115 | in
116 | print_string "LetTuple(";
117 | print_string "(";
118 | print_args args;
119 | print_string ")";
120 | print_t t1;
121 | print_string ", ";
122 | print_t t2;
123 | print_string ")"
124 | | Array (t1, t2) ->
125 | print_string "Array(";
126 | print_t t1;
127 | print_string ", ";
128 | print_t t2;
129 | print_string ")"
130 | | Get (t1, t2) ->
131 | print_string "Get(";
132 | print_t t1;
133 | print_string ", ";
134 | print_t t2;
135 | print_string ")"
136 | | Put (t1, t2, t3) ->
137 | print_t t1;
138 | print_string ", ";
139 | print_t t2;
140 | print_string ", ";
141 | print_t t3;
142 | print_string ")"
143 | | _ -> assert false
144 |
145 | and print_fundef { name; args; body } =
146 | let id, typ = name in
147 | print_string "{";
148 | print_string "(";
149 | print_string id;
150 | Type.print_t typ;
151 | print_string "); ";
152 | print_string "[";
153 | List.iter
154 | (fun arg ->
155 | let id, typ = arg in
156 | print_string id;
157 | print_string ", ";
158 | Type.print_t typ)
159 | args;
160 | print_t body;
161 | print_string "}"
162 |
163 | and print_t_list ts =
164 | print_string "[";
165 | let rec loop ts =
166 | match ts with
167 | | [] -> ()
168 | | [ hd ] -> print_t hd
169 | | hd :: tl ->
170 | print_t hd;
171 | print_string "; ";
172 | loop tl
173 | in
174 | loop ts;
175 | print_string "]"
176 | ;;
177 |
--------------------------------------------------------------------------------
/src/joe/type.ml:
--------------------------------------------------------------------------------
1 | type t = (* MinCamlの型を表現するデータ型 (caml2html: type_t) *)
2 | | Unit
3 | | Bool
4 | | Int
5 | | Float
6 | | Fun of t list * t (* arguments are uncurried *)
7 | | Tuple of t list
8 | | Array of t
9 | | Var of t option ref [@@deriving show]
10 |
11 | let gentyp () = Var (ref None) (* 新しい型変数を作る *)
12 |
13 | let rec print_t = function
14 | | Unit -> print_string "Unit"
15 | | Bool -> print_string "Bool"
16 | | Int -> print_string "Int"
17 | | Float -> print_string "Float"
18 | | Fun (ts, t) -> print_string "Fun("; List.iter (fun t -> print_t t; print_string ", ") ts; print_t t; print_string ")"
19 | | Tuple ts -> let count = ref 0 in print_string "Tuple("; List.iter (fun t -> if !count = List.length ts then print_t t else print_t t; print_string ", "; incr count) ts; print_string ")"
20 | | Array t -> print_string "Array("; print_t t; print_string ")"
21 | | Var opt_t_ref -> print_string "Var("; (match !opt_t_ref with Some v -> print_t v | None -> print_string "None"); print_string ")"
22 |
23 |
--------------------------------------------------------------------------------
/src/joe/typing.ml:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/groupoid/joe/4bbf1a33ef17e076df3bac47fe32e5604243b2d5/src/joe/typing.ml
--------------------------------------------------------------------------------
/src/joe/typing.mli:
--------------------------------------------------------------------------------
1 | exception Error of Syntax.t * Type.t * Type.t
2 |
3 | val extenv : Type.t M.t ref
4 | val f : Syntax.t -> Syntax.t
5 |
--------------------------------------------------------------------------------
/src/joe/unparser.ml:
--------------------------------------------------------------------------------
1 | open Syntax
2 |
3 | let rec string_of_ast (t : Syntax.t) : string = match t with
4 | | Unit -> "()"
5 | | Int n -> string_of_int n
6 | | Bool b -> string_of_bool b
7 | | Float f -> string_of_float f
8 | | Not t -> Printf.sprintf "(not (%s))" (string_of_ast t)
9 | | Neg t -> Printf.sprintf "(- %s)" (string_of_ast t)
10 | | FNeg t -> Printf.sprintf "(-. %s)" (string_of_ast t)
11 | | Var x -> x
12 | | Add (t1, t2) -> Printf.sprintf "%s + %s" (string_of_ast t1) (string_of_ast t2)
13 | | Sub (t1, t2) -> Printf.sprintf "%s - %s" (string_of_ast t1) (string_of_ast t2)
14 | | FAdd (t1, t2) -> Printf.sprintf "%s +. %s" (string_of_ast t1) (string_of_ast t2)
15 | | FSub (t1, t2) -> Printf.sprintf "%s -. %s" (string_of_ast t1) (string_of_ast t2)
16 | | FMul (t1, t2) -> Printf.sprintf "%s *. %s" (string_of_ast t1) (string_of_ast t2)
17 | | FDiv (t1, t2) -> Printf.sprintf "%s /. %s" (string_of_ast t1) (string_of_ast t2)
18 | | Eq (t1, t2) -> Printf.sprintf "%s = %s" (string_of_ast t1) (string_of_ast t2)
19 | | LE (t1, t2) -> Printf.sprintf "%s <= %s" (string_of_ast t1) (string_of_ast t2)
20 | | If (t1, t2, t3) -> Printf.sprintf "if %s then %s\nelse %s" (string_of_ast t1) (string_of_ast t2) (string_of_ast t3)
21 | | Let ((id, typ), t1, t2) ->
22 | if String.contains id 'T' then Printf.sprintf "let _ = %s in %s" (string_of_ast t1) (string_of_ast t2)
23 | else Printf.sprintf "let %s = %s in %s" id (string_of_ast t1) (string_of_ast t2)
24 | | LetRec (fundef, t) -> let { name; args; body } = fundef in
25 | let id, _ = name in let args' = List.fold_left (fun acc (id, _) ->
26 | if String.contains id 'T' && String.contains id 'u'
27 | then acc ^ "_" ^ " " else acc ^ id ^ " ") "" args
28 | in Printf.sprintf "let rec %s %s= %s\nin %s" id args' (string_of_ast body) (string_of_ast t)
29 | | App (t, ts) -> let rec loop = function
30 | | [] -> ""
31 | | [ hd ] -> string_of_ast hd
32 | | hd :: tl -> string_of_ast hd ^ " " ^ loop tl
33 | in Printf.sprintf "%s (%s)" (string_of_ast t) (loop ts)
34 | | Tuple ts -> Printf.sprintf "(%s)" (string_of_ast_ts ts)
35 | | LetTuple (xs, t1, t2) -> let rec loop = function
36 | | [] -> ""
37 | | [ (id, _) ] -> id
38 | | (id, _) :: tl -> id ^ " " ^ loop tl
39 | in Printf.sprintf "let %s = %s in %s" (loop xs) (string_of_ast t1) (string_of_ast t2)
40 | | Array (t1, t2) -> Printf.sprintf "Array.create %s %s" (string_of_ast t1) (string_of_ast t2)
41 | | Get (t1, t2) -> Printf.sprintf "%s.(%s)" (string_of_ast t1) (string_of_ast t2)
42 | | Put (t1, t2, t3) -> Printf.sprintf "%s.(%s) <- %s" (string_of_ast t1) (string_of_ast t2) (string_of_ast t3)
43 |
44 | and string_of_ast_ts = function
45 | | [] -> ""
46 | | [ hd ] -> string_of_ast hd
47 | | hd :: tl -> string_of_ast hd ^ ", " ^ string_of_ast_ts tl
48 |
49 | let unparse (t : Syntax.t) = string_of_ast t |> print_endline
50 | let parse_from_string s = Lexing.from_string s |> Parser.exp Lexer.token
51 |
--------------------------------------------------------------------------------
/src/joe/unparser.mli:
--------------------------------------------------------------------------------
1 | val string_of_ast : Syntax.t -> string
2 | val unparse : Syntax.t -> unit
3 | val parse_from_string : string -> Syntax.t
4 |
--------------------------------------------------------------------------------
/src/joe/util.ml:
--------------------------------------------------------------------------------
1 | let limit = ref 1000
2 |
3 | let rec iter n e =
4 | Format.eprintf "iteration %d@." n;
5 | if n = 0 then e
6 | else (let e' = Elim.f (ConstFold.f (Inline.f (Assoc.f (Beta.f e)))) in if e = e' then e else iter (n - 1) e')
7 |
8 |
--------------------------------------------------------------------------------
/src/joe/virtual.ml:
--------------------------------------------------------------------------------
1 | (* translation into assembly with infinite number of virtual registers *)
2 |
3 | open Asm
4 | open X64
5 |
6 | let data = ref [] (* 浮動小数点数の定数テーブル (caml2html: virtual_data) *)
7 |
8 | let classify xts ini addf addi = List.fold_left (fun acc (x, t) ->
9 | match t with
10 | | Type.Unit -> acc
11 | | Type.Float -> addf acc x
12 | | _ -> addi acc x t) ini xts
13 |
14 | let separate xts =
15 | classify xts ([], []) (fun (int, float) x -> int, float @ [ x ])
16 | (fun (int, float) x _ -> int @ [ x ], float)
17 |
18 | let expand xts ini addf addi =
19 | classify xts ini (fun (offset, acc) x -> let offset = align offset in offset + 8, addf x offset acc)
20 | (fun (offset, acc) x t -> (* NOTE: 64ビットなので4バイトから8バイトにする *) offset + 8, addi x t offset acc)
21 |
22 | let rec g env = function (* 式の仮想マシンコード生成 (caml2html: virtual_g) *)
23 | | Closure.Unit -> Ans Nop
24 | | Closure.Int i -> Ans (Li i)
25 | | Closure.Float d -> let l = try
26 | (* すでに定数テーブルにあったら再利用 Cf. https://github.com/esumii/min-caml/issues/13 *)
27 | let l, _ = List.find (fun (_, d') -> d = d') !data in l
28 | with | Not_found -> let l = Id.L (Id.genid "l") in data := (l, d) :: !data; l
29 | in let x = Id.genid "l" in Let ((x, Type.Int), SetL l, Ans (LdDF (x, C 0, 1)))
30 | | Closure.Neg x -> Ans (Neg x)
31 | | Closure.Add (x, y) -> Ans (Add (x, V y))
32 | | Closure.Sub (x, y) -> Ans (Sub (x, V y))
33 | | Closure.Mul (x, y) -> Ans (Mul (x, V y))
34 | | Closure.Div (x, y) -> Ans (Div (x, V y))
35 | | Closure.Mod (x, y) -> Ans (Mod (x, V y))
36 | | Closure.FNeg x -> Ans (FNeg x)
37 | | Closure.FAdd (x, y) -> Ans (FAdd (x, y))
38 | | Closure.FSub (x, y) -> Ans (FSub (x, y))
39 | | Closure.FMul (x, y) -> Ans (FMul (x, y))
40 | | Closure.FDiv (x, y) -> Ans (FDiv (x, y))
41 | | Closure.IfEq (x, y, e1, e2) ->
42 | (match M.find x env with
43 | | Type.Bool | Type.Int -> Ans (IfEq (x, V y, g env e1, g env e2))
44 | | Type.Float -> Ans (IfFEq (x, y, g env e1, g env e2))
45 | | _ -> failwith "equality supported only for bool, int, and float")
46 | | Closure.IfLE (x, y, e1, e2) ->
47 | (match M.find x env with
48 | | Type.Bool | Type.Int -> Ans (IfLE (x, V y, g env e1, g env e2))
49 | | Type.Float -> Ans (IfFLE (x, y, g env e1, g env e2))
50 | | _ -> failwith "inequality supported only for bool, int, and float")
51 | | Closure.Let ((x, t1), e1, e2) ->
52 | let e1' = g env e1 in
53 | let e2' = g (M.add x t1 env) e2 in
54 | concat e1' (x, t1) e2'
55 | | Closure.Var x ->
56 | (match M.find x env with
57 | | Type.Unit -> Ans Nop
58 | | Type.Float -> Ans (FMov x)
59 | | _ -> Ans (Mov x))
60 | | Closure.MakeCls ((x, t), { Closure.entry = l; Closure.actual_fv = ys }, e2) -> (* クロージャの生成 (caml2html: virtual_makecls) *)
61 | (* Closureのアドレスをセットしてから、自由変数の値をストア *)
62 | let e2' = g (M.add x t env) e2 in
63 | let offset, store_fv =
64 | expand
65 | (List.map (fun y -> y, M.find y env) ys)
66 | (* NOTE: 64ビットなので4バイトから8バイトにする *)
67 | (8, e2')
68 | (fun y offset store_fv -> seq (StDF (y, x, C offset, 1), store_fv))
69 | (fun y _ offset store_fv -> seq (St (y, x, C offset, 1), store_fv))
70 | in
71 | Let
72 | ( (x, t)
73 | , Mov reg_hp
74 | , Let
75 | ( (reg_hp, Type.Int)
76 | , Add (reg_hp, C (align offset))
77 | , let z = Id.genid "l" in
78 | Let ((z, Type.Int), SetL l, seq (St (z, x, C 0, 1), store_fv)) ) )
79 | | Closure.AppCls (x, ys) ->
80 | let int, float = separate (List.map (fun y -> y, M.find y env) ys) in
81 | Ans (CallCls (x, int, float))
82 | | Closure.AppDir (Id.L x, ys) ->
83 | let int, float = separate (List.map (fun y -> y, M.find y env) ys) in
84 | Ans (CallDir (Id.L x, int, float))
85 | | Closure.Tuple xs -> (* 組の生成 (caml2html: virtual_tuple) *)
86 | let y = Id.genid "t" in
87 | let offset, store =
88 | expand
89 | (List.map (fun x -> x, M.find x env) xs)
90 | (0, Ans (Mov y))
91 | (fun x offset store -> seq (StDF (x, y, C offset, 1), store))
92 | (fun x _ offset store -> seq (St (x, y, C offset, 1), store))
93 | in
94 | Let
95 | ( (y, Type.Tuple (List.map (fun x -> M.find x env) xs))
96 | , Mov reg_hp
97 | , Let ((reg_hp, Type.Int), Add (reg_hp, C (align offset)), store) )
98 | | Closure.LetTuple (xts, y, e2) ->
99 | let s = Closure.fv e2 in
100 | let offset, load =
101 | expand
102 | xts
103 | (0, g (M.add_list xts env) e2)
104 | (fun x offset load ->
105 | if not (S.mem x s)
106 | then load else (* [XX] a little ad hoc optimization *)
107 | fletd (x, LdDF (y, C offset, 1), load))
108 | (fun x t offset load ->
109 | if not (S.mem x s)
110 | then load else (* [XX] a little ad hoc optimization *)
111 | Let ((x, t), Ld (y, C offset, 1), load))
112 | in
113 | load
114 | | Closure.Get (x, y) -> (* 配列の読み出し (caml2html: virtual_get) *)
115 | (match M.find x env with
116 | | Type.Array Type.Unit -> Ans Nop
117 | | Type.Array Type.Float -> Ans (LdDF (x, V y, 8))
118 | | Type.Array _ -> Ans (Ld (x, V y, 8))
119 | | _ -> assert false)
120 | | Closure.Put (x, y, z) ->
121 | (match M.find x env with
122 | | Type.Array Type.Unit -> Ans Nop
123 | | Type.Array Type.Float -> Ans (StDF (z, x, V y, 8))
124 | | Type.Array _ -> Ans (St (z, x, V y, 8))
125 | | _ -> assert false)
126 | | Closure.ExtArray (Id.L x) -> Ans (SetL (Id.L ("min_caml_" ^ x)))
127 |
128 | (* 関数の仮想マシンコード生成 (caml2html: virtual_h) *)
129 | let h
130 | { Closure.name = Id.L x, t
131 | ; Closure.args = yts
132 | ; Closure.formal_fv = zts
133 | ; Closure.body = e
134 | ; annot
135 | }
136 | = let int, float = separate yts in
137 | let offset, load = expand zts
138 | (* NOTE: 64ビットなので4バイトから8バイトにする *)
139 | (8, g (M.add x t (M.add_list yts (M.add_list zts M.empty))) e)
140 | (fun z offset load -> fletd (z, LdDF (x, C offset, 1), load))
141 | (fun z t offset load -> Let ((z, t), Ld (x, C offset, 1), load))
142 | in match t with
143 | | Type.Fun (_, t2) -> { name = Id.L x; args = int; fargs = float; body = load; ret = t2; annot }
144 | | _ -> assert false
145 |
146 | (* プログラム全体の仮想マシンコード生成 (caml2html: virtual_f) *)
147 | let f (Closure.Prog (fundefs, e)) =
148 | data := [];
149 | let fundefs = List.map h fundefs in
150 | let e = g M.empty e in Prog (!data, fundefs, e)
151 |
--------------------------------------------------------------------------------
/src/joe/virtual.mli:
--------------------------------------------------------------------------------
1 | val f : Closure.prog -> Asm.prog
2 |
--------------------------------------------------------------------------------
/src/sparc/emit.ml:
--------------------------------------------------------------------------------
1 | open Asm
2 |
3 | external gethi : float -> int32 = "gethi"
4 | external getlo : float -> int32 = "getlo"
5 |
6 | let stackset = ref S.empty (* すでにSaveされた変数の集合 *)
7 | let stackmap = ref [] (* Saveされた変数の、スタックにおける位置 *)
8 | let save x =
9 | stackset := S.add x !stackset;
10 | if not (List.mem x !stackmap) then
11 | stackmap := !stackmap @ [x]
12 | let savef x =
13 | stackset := S.add x !stackset;
14 | if not (List.mem x !stackmap) then
15 | (let pad =
16 | if List.length !stackmap mod 2 = 0 then [] else [Id.gentmp Type.Int] in
17 | stackmap := !stackmap @ pad @ [x; x])
18 | let locate x =
19 | let rec loc = function
20 | | [] -> []
21 | | y :: zs when x = y -> 0 :: List.map succ (loc zs)
22 | | y :: zs -> List.map succ (loc zs) in
23 | loc !stackmap
24 | let offset x = 4 * List.hd (locate x)
25 | let stacksize () = align ((List.length !stackmap + 1) * 4)
26 |
27 | let pp_id_or_imm = function
28 | | V(x) -> x
29 | | C(i) -> string_of_int i
30 |
31 | (* 関数呼び出しのために引数を並べ替える(register shuffling) *)
32 | let rec shuffle sw xys =
33 | (* remove identical moves *)
34 | let _, xys = List.partition (fun (x, y) -> x = y) xys in
35 | (* find acyclic moves *)
36 | match List.partition (fun (_, y) -> List.mem_assoc y xys) xys with
37 | | [], [] -> []
38 | | (x, y) :: xys, [] -> (* no acyclic moves; resolve a cyclic move *)
39 | (y, sw) :: (x, y) :: shuffle sw (List.map
40 | (function
41 | | (y', z) when y = y' -> (sw, z)
42 | | yz -> yz)
43 | xys)
44 | | xys, acyc -> acyc @ shuffle sw xys
45 |
46 | type dest = Tail | NonTail of Id.t (* 末尾かどうかを表すデータ型 *)
47 | let rec g oc = function (* 命令列のアセンブリ生成 *)
48 | | dest, Ans(exp) -> g' oc (dest, exp)
49 | | dest, Let((x, t), exp, e) ->
50 | g' oc (NonTail(x), exp);
51 | g oc (dest, e)
52 | and g' oc = function (* 各命令のアセンブリ生成 *)
53 | (* 末尾でなかったら計算結果をdestにセット *)
54 | | NonTail(_), Nop -> ()
55 | | NonTail(x), Set(i) -> Printf.fprintf oc "\tset\t%d, %s\n" i x
56 | | NonTail(x), SetL(Id.L(y)) -> Printf.fprintf oc "\tset\t%s, %s\n" y x
57 | | NonTail(x), Mov(y) when x = y -> ()
58 | | NonTail(x), Mov(y) -> Printf.fprintf oc "\tmov\t%s, %s\n" y x
59 | | NonTail(x), Neg(y) -> Printf.fprintf oc "\tneg\t%s, %s\n" y x
60 | | NonTail(x), Add(y, z') -> Printf.fprintf oc "\tadd\t%s, %s, %s\n" y (pp_id_or_imm z') x
61 | | NonTail(x), Sub(y, z') -> Printf.fprintf oc "\tsub\t%s, %s, %s\n" y (pp_id_or_imm z') x
62 | | NonTail(x), SLL(y, z') -> Printf.fprintf oc "\tsll\t%s, %s, %s\n" y (pp_id_or_imm z') x
63 | | NonTail(x), Ld(y, z') -> Printf.fprintf oc "\tld\t[%s + %s], %s\n" y (pp_id_or_imm z') x
64 | | NonTail(_), St(x, y, z') -> Printf.fprintf oc "\tst\t%s, [%s + %s]\n" x y (pp_id_or_imm z')
65 | | NonTail(x), FMovD(y) when x = y -> ()
66 | | NonTail(x), FMovD(y) ->
67 | Printf.fprintf oc "\tfmovs\t%s, %s\n" y x;
68 | Printf.fprintf oc "\tfmovs\t%s, %s\n" (co_freg y) (co_freg x)
69 | | NonTail(x), FNegD(y) ->
70 | Printf.fprintf oc "\tfnegs\t%s, %s\n" y x;
71 | if x <> y then Printf.fprintf oc "\tfmovs\t%s, %s\n" (co_freg y) (co_freg x)
72 | | NonTail(x), FAddD(y, z) -> Printf.fprintf oc "\tfaddd\t%s, %s, %s\n" y z x
73 | | NonTail(x), FSubD(y, z) -> Printf.fprintf oc "\tfsubd\t%s, %s, %s\n" y z x
74 | | NonTail(x), FMulD(y, z) -> Printf.fprintf oc "\tfmuld\t%s, %s, %s\n" y z x
75 | | NonTail(x), FDivD(y, z) -> Printf.fprintf oc "\tfdivd\t%s, %s, %s\n" y z x
76 | | NonTail(x), LdDF(y, z') -> Printf.fprintf oc "\tldd\t[%s + %s], %s\n" y (pp_id_or_imm z') x
77 | | NonTail(_), StDF(x, y, z') -> Printf.fprintf oc "\tstd\t%s, [%s + %s]\n" x y (pp_id_or_imm z')
78 | | NonTail(_), Comment(s) -> Printf.fprintf oc "\t! %s\n" s
79 | (* 退避の仮想命令の実装 *)
80 | | NonTail(_), Save(x, y) when List.mem x allregs && not (S.mem y !stackset) ->
81 | save y;
82 | Printf.fprintf oc "\tst\t%s, [%s + %d]\n" x reg_sp (offset y)
83 | | NonTail(_), Save(x, y) when List.mem x allfregs && not (S.mem y !stackset) ->
84 | savef y;
85 | Printf.fprintf oc "\tstd\t%s, [%s + %d]\n" x reg_sp (offset y)
86 | | NonTail(_), Save(x, y) -> assert (S.mem y !stackset); ()
87 | (* 復帰の仮想命令の実装 *)
88 | | NonTail(x), Restore(y) when List.mem x allregs ->
89 | Printf.fprintf oc "\tld\t[%s + %d], %s\n" reg_sp (offset y) x
90 | | NonTail(x), Restore(y) ->
91 | assert (List.mem x allfregs);
92 | Printf.fprintf oc "\tldd\t[%s + %d], %s\n" reg_sp (offset y) x
93 | (* 末尾だったら計算結果を第一レジスタにセットしてret *)
94 | | Tail, (Nop | St _ | StDF _ | Comment _ | Save _ as exp) ->
95 | g' oc (NonTail(Id.gentmp Type.Unit), exp);
96 | Printf.fprintf oc "\tretl\n";
97 | Printf.fprintf oc "\tnop\n"
98 | | Tail, (Set _ | SetL _ | Mov _ | Neg _ | Add _ | Sub _ | SLL _ | Ld _ as exp) ->
99 | g' oc (NonTail(regs.(0)), exp);
100 | Printf.fprintf oc "\tretl\n";
101 | Printf.fprintf oc "\tnop\n"
102 | | Tail, (FMovD _ | FNegD _ | FAddD _ | FSubD _ | FMulD _ | FDivD _ | LdDF _ as exp) ->
103 | g' oc (NonTail(fregs.(0)), exp);
104 | Printf.fprintf oc "\tretl\n";
105 | Printf.fprintf oc "\tnop\n"
106 | | Tail, (Restore(x) as exp) ->
107 | (match locate x with
108 | | [i] -> g' oc (NonTail(regs.(0)), exp)
109 | | [i; j] when i + 1 = j -> g' oc (NonTail(fregs.(0)), exp)
110 | | _ -> assert false);
111 | Printf.fprintf oc "\tretl\n";
112 | Printf.fprintf oc "\tnop\n"
113 | | Tail, IfEq(x, y', e1, e2) ->
114 | Printf.fprintf oc "\tcmp\t%s, %s\n" x (pp_id_or_imm y');
115 | g'_tail_if oc e1 e2 "be" "bne"
116 | | Tail, IfLE(x, y', e1, e2) ->
117 | Printf.fprintf oc "\tcmp\t%s, %s\n" x (pp_id_or_imm y');
118 | g'_tail_if oc e1 e2 "ble" "bg"
119 | | Tail, IfGE(x, y', e1, e2) ->
120 | Printf.fprintf oc "\tcmp\t%s, %s\n" x (pp_id_or_imm y');
121 | g'_tail_if oc e1 e2 "bge" "bl"
122 | | Tail, IfFEq(x, y, e1, e2) ->
123 | Printf.fprintf oc "\tfcmpd\t%s, %s\n" x y;
124 | Printf.fprintf oc "\tnop\n";
125 | g'_tail_if oc e1 e2 "fbe" "fbne"
126 | | Tail, IfFLE(x, y, e1, e2) ->
127 | Printf.fprintf oc "\tfcmpd\t%s, %s\n" x y;
128 | Printf.fprintf oc "\tnop\n";
129 | g'_tail_if oc e1 e2 "fble" "fbg"
130 | | NonTail(z), IfEq(x, y', e1, e2) ->
131 | Printf.fprintf oc "\tcmp\t%s, %s\n" x (pp_id_or_imm y');
132 | g'_non_tail_if oc (NonTail(z)) e1 e2 "be" "bne"
133 | | NonTail(z), IfLE(x, y', e1, e2) ->
134 | Printf.fprintf oc "\tcmp\t%s, %s\n" x (pp_id_or_imm y');
135 | g'_non_tail_if oc (NonTail(z)) e1 e2 "ble" "bg"
136 | | NonTail(z), IfGE(x, y', e1, e2) ->
137 | Printf.fprintf oc "\tcmp\t%s, %s\n" x (pp_id_or_imm y');
138 | g'_non_tail_if oc (NonTail(z)) e1 e2 "bge" "bl"
139 | | NonTail(z), IfFEq(x, y, e1, e2) ->
140 | Printf.fprintf oc "\tfcmpd\t%s, %s\n" x y;
141 | Printf.fprintf oc "\tnop\n";
142 | g'_non_tail_if oc (NonTail(z)) e1 e2 "fbe" "fbne"
143 | | NonTail(z), IfFLE(x, y, e1, e2) ->
144 | Printf.fprintf oc "\tfcmpd\t%s, %s\n" x y;
145 | Printf.fprintf oc "\tnop\n";
146 | g'_non_tail_if oc (NonTail(z)) e1 e2 "fble" "fbg"
147 | (* 関数呼び出しの仮想命令の実装 *)
148 | | Tail, CallCls(x, ys, zs) -> (* 末尾呼び出し *)
149 | g'_args oc [(x, reg_cl)] ys zs;
150 | Printf.fprintf oc "\tld\t[%s + 0], %s\n" reg_cl reg_sw;
151 | Printf.fprintf oc "\tjmp\t%s\n" reg_sw;
152 | Printf.fprintf oc "\tnop\n"
153 | | Tail, CallDir(Id.L(x), ys, zs) -> (* 末尾呼び出し *)
154 | g'_args oc [] ys zs;
155 | Printf.fprintf oc "\tb\t%s\n" x;
156 | Printf.fprintf oc "\tnop\n"
157 | | NonTail(a), CallCls(x, ys, zs) ->
158 | g'_args oc [(x, reg_cl)] ys zs;
159 | let ss = stacksize () in
160 | Printf.fprintf oc "\tst\t%s, [%s + %d]\n" reg_ra reg_sp (ss - 4);
161 | Printf.fprintf oc "\tld\t[%s + 0], %s\n" reg_cl reg_sw;
162 | Printf.fprintf oc "\tcall\t%s\n" reg_sw;
163 | Printf.fprintf oc "\tadd\t%s, %d, %s\t! delay slot\n" reg_sp ss reg_sp;
164 | Printf.fprintf oc "\tsub\t%s, %d, %s\n" reg_sp ss reg_sp;
165 | Printf.fprintf oc "\tld\t[%s + %d], %s\n" reg_sp (ss - 4) reg_ra;
166 | if List.mem a allregs && a <> regs.(0) then
167 | Printf.fprintf oc "\tmov\t%s, %s\n" regs.(0) a
168 | else if List.mem a allfregs && a <> fregs.(0) then
169 | (Printf.fprintf oc "\tfmovs\t%s, %s\n" fregs.(0) a;
170 | Printf.fprintf oc "\tfmovs\t%s, %s\n" (co_freg fregs.(0)) (co_freg a))
171 | | NonTail(a), CallDir(Id.L(x), ys, zs) ->
172 | g'_args oc [] ys zs;
173 | let ss = stacksize () in
174 | Printf.fprintf oc "\tst\t%s, [%s + %d]\n" reg_ra reg_sp (ss - 4);
175 | Printf.fprintf oc "\tcall\t%s\n" x;
176 | Printf.fprintf oc "\tadd\t%s, %d, %s\t! delay slot\n" reg_sp ss reg_sp;
177 | Printf.fprintf oc "\tsub\t%s, %d, %s\n" reg_sp ss reg_sp;
178 | Printf.fprintf oc "\tld\t[%s + %d], %s\n" reg_sp (ss - 4) reg_ra;
179 | if List.mem a allregs && a <> regs.(0) then
180 | Printf.fprintf oc "\tmov\t%s, %s\n" regs.(0) a
181 | else if List.mem a allfregs && a <> fregs.(0) then
182 | (Printf.fprintf oc "\tfmovs\t%s, %s\n" fregs.(0) a;
183 | Printf.fprintf oc "\tfmovs\t%s, %s\n" (co_freg fregs.(0)) (co_freg a))
184 | and g'_tail_if oc e1 e2 b bn =
185 | let b_else = Id.genid (b ^ "_else") in
186 | Printf.fprintf oc "\t%s\t%s\n" bn b_else;
187 | Printf.fprintf oc "\tnop\n";
188 | let stackset_back = !stackset in
189 | g oc (Tail, e1);
190 | Printf.fprintf oc "%s:\n" b_else;
191 | stackset := stackset_back;
192 | g oc (Tail, e2)
193 | and g'_non_tail_if oc dest e1 e2 b bn =
194 | let b_else = Id.genid (b ^ "_else") in
195 | let b_cont = Id.genid (b ^ "_cont") in
196 | Printf.fprintf oc "\t%s\t%s\n" bn b_else;
197 | Printf.fprintf oc "\tnop\n";
198 | let stackset_back = !stackset in
199 | g oc (dest, e1);
200 | let stackset1 = !stackset in
201 | Printf.fprintf oc "\tb\t%s\n" b_cont;
202 | Printf.fprintf oc "\tnop\n";
203 | Printf.fprintf oc "%s:\n" b_else;
204 | stackset := stackset_back;
205 | g oc (dest, e2);
206 | Printf.fprintf oc "%s:\n" b_cont;
207 | let stackset2 = !stackset in
208 | stackset := S.inter stackset1 stackset2
209 | and g'_args oc x_reg_cl ys zs =
210 | let (i, yrs) =
211 | List.fold_left
212 | (fun (i, yrs) y -> (i + 1, (y, regs.(i)) :: yrs))
213 | (0, x_reg_cl)
214 | ys in
215 | List.iter
216 | (fun (y, r) -> Printf.fprintf oc "\tmov\t%s, %s\n" y r)
217 | (shuffle reg_sw yrs);
218 | let (d, zfrs) =
219 | List.fold_left
220 | (fun (d, zfrs) z -> (d + 1, (z, fregs.(d)) :: zfrs))
221 | (0, [])
222 | zs in
223 | List.iter
224 | (fun (z, fr) ->
225 | Printf.fprintf oc "\tfmovs\t%s, %s\n" z fr;
226 | Printf.fprintf oc "\tfmovs\t%s, %s\n" (co_freg z) (co_freg fr))
227 | (shuffle reg_fsw zfrs)
228 |
229 | let h oc { name = Id.L(x); args = _; fargs = _; body = e; ret = _ } =
230 | Printf.fprintf oc "%s:\n" x;
231 | stackset := S.empty;
232 | stackmap := [];
233 | g oc (Tail, e)
234 |
235 | let f oc (Prog(data, fundefs, e)) =
236 | Format.eprintf "generating assembly...@.";
237 | Printf.fprintf oc ".section\t\".rodata\"\n";
238 | Printf.fprintf oc ".align\t8\n";
239 | List.iter
240 | (fun (Id.L(x), d) ->
241 | Printf.fprintf oc "%s:\t! %f\n" x d;
242 | Printf.fprintf oc "\t.long\t0x%lx\n" (gethi d);
243 | Printf.fprintf oc "\t.long\t0x%lx\n" (getlo d))
244 | data;
245 | Printf.fprintf oc ".section\t\".text\"\n";
246 | List.iter (fun fundef -> h oc fundef) fundefs;
247 | Printf.fprintf oc ".global\tmin_caml_start\n";
248 | Printf.fprintf oc "min_caml_start:\n";
249 | Printf.fprintf oc "\tsave\t%%sp, -112, %%sp\n"; (* from gcc; why 112? *)
250 | stackset := S.empty;
251 | stackmap := [];
252 | g oc (NonTail("%g0"), e);
253 | Printf.fprintf oc "\tret\n";
254 | Printf.fprintf oc "\trestore\n"
255 |
--------------------------------------------------------------------------------
/src/ulc/ulc.ml:
--------------------------------------------------------------------------------
1 | type term =
2 | | Var of string
3 | | Lam of string * term
4 | | App of term * term
5 | | Pair of term * term
6 | | Fst of term
7 | | Snd of term
8 | | Unit
9 |
10 | let rec string_of_term = function
11 | | Var x -> x
12 | | Lam (x, t) -> "λ" ^ x ^ ". " ^ string_of_term t
13 | | App (t1, t2) -> "(" ^ string_of_term t1 ^ " " ^ string_of_term t2 ^ ")"
14 | | Pair (t1, t2) -> "<" ^ string_of_term t1 ^ ", " ^ string_of_term t2 ^ ">"
15 | | Fst t -> "fst " ^ string_of_term t
16 | | Snd t -> "snd " ^ string_of_term t
17 | | Unit -> "unit"
18 |
19 | let rec subst x s = function
20 | | Var y -> if x = y then s else Var y
21 | | Lam (y, t) when x <> y -> Lam (y, subst x s t)
22 | | App (f, a) -> App (subst x s f, subst x s a)
23 | | Pair (t1, t2) -> Pair (subst x s t1, subst x s t2)
24 | | Fst t -> Fst (subst x s t)
25 | | Snd t -> Snd (subst x s t)
26 | | Unit -> Unit
27 | | t -> t
28 |
29 | let rec equal t1 t2 =
30 | match t1, t2 with
31 | | Var x, Var y -> x = y
32 | | Lam (x, b), Lam (y, b') -> equal b (subst y (Var x) b')
33 | | Lam (x, b), t -> equal b (App (t, Var x))
34 | | t, Lam (x, b) -> equal (App (t, Var x)) b
35 | | App (f1, a1), App (f2, a2) -> equal f1 f2 && equal a1 a2
36 | | Pair (t1, t2), Pair (t1', t2') -> equal t1 t1' && equal t2 t2'
37 | | Fst t, Fst t' -> equal t t'
38 | | Snd t, Snd t' -> equal t t'
39 | | Unit, Unit -> true
40 | | _ -> false
41 |
42 | let rec reduce = function
43 | | App (Lam (x, b), a) -> subst x a b
44 | | App (f, a) -> App (reduce f, reduce a)
45 | | Pair (t1, t2) -> Pair (reduce t1, reduce t2)
46 | | Fst (Pair (t1, t2)) -> t1
47 | | Fst t -> Fst (reduce t)
48 | | Snd (Pair (t1, t2)) -> t2
49 | | Snd t -> Snd (reduce t)
50 | | Unit -> Unit
51 | | t -> t
52 |
53 | let rec normalize t =
54 | let t' = reduce t in
55 | if equal t t' then t else normalize t'
56 |
57 | let id = Lam ("x", Var "x")
58 | let const = Lam ("x", Lam ("y", Var "x"))
59 | let one = Lam ("f", Lam ("x", App (Var "f", Var "x")))
60 | let two = Lam ("f", Lam ("x", App (Var "f", App (Var "f", Var "x"))))
61 |
62 | let beta = (App (Lam ("x", Var "x"), Var "y"), Var "y")
63 | let eta = (Lam ("x", App (Var "f", Var "x")), Var "f")
64 | let eta_domain = (Lam ("x", App (Var "f", Var "x")), Var "f")
65 | let invalid_eta = (Lam ("x", Var "z"), Var "z")
66 | let invalid_eta_v = (Lam ("x", Var "u"), Var "u")
67 | let pair_test = (Fst (Pair (Var "x", Var "y")), Var "x")
68 | let snd_test = (Snd (Pair (Var "x", Var "y")), Var "y")
69 | let unit_test = (App (Lam ("x", Unit), Var "z"), Unit)
70 |
71 | let test_equal name (t1, t2) =
72 | let t1' = normalize t1 in
73 | let t2' = normalize t2 in
74 | let result = equal t1' t2' in
75 | Printf.printf "Test %s:\n- Term1: %s\n- Term2: %s\n- Result: %s\n\n"
76 | name
77 | (string_of_term t1)
78 | (string_of_term t2)
79 | (if result then "PASS" else "FAIL")
80 |
81 | let () =
82 | test_equal "Beta" beta;
83 | test_equal "Eta" eta;
84 | test_equal "Eta Domain" eta_domain;
85 | test_equal "Invalid Eta" invalid_eta;
86 | test_equal "Invalid Eta Var" invalid_eta_v;
87 | test_equal "Pair Fst" pair_test;
88 | test_equal "Pair Snd" snd_test;
89 | test_equal "Unit" unit_test;
90 |
--------------------------------------------------------------------------------
/src/vm/config.ml:
--------------------------------------------------------------------------------
1 | let sh_flg = ref false
2 | let vm_debug_flg = ref false
3 | let tail_opt_flg = ref true
4 | let frame_reset_flg = ref true
5 | let stack_mode_flg : [ `User_stack | `Host_stack ] ref = ref `User_stack
6 |
--------------------------------------------------------------------------------
/src/vm/dune:
--------------------------------------------------------------------------------
1 | (library
2 | (name BacCaml)
3 | (public_name vm.lib)
4 | (modules (:standard \ main))
5 | (flags (-w -4-33-40-41))
6 | (libraries str MinCaml)
7 | (foreign_stubs (language c) (names libmincaml))
8 | (foreign_stubs (language c) (names float))
9 | (preprocess (pps ppx_deriving.show ppx_deriving.enum)))
10 |
11 | (executable
12 | (name main)
13 | (public_name vm)
14 | (flags (-w -4-33-40-41))
15 | (modules Main)
16 | (package vm)
17 | (libraries MinCaml BacCaml))
18 |
--------------------------------------------------------------------------------
/src/vm/emit.ml:
--------------------------------------------------------------------------------
1 | open MinCaml
2 | open Asm
3 | open Config
4 | open Insts
5 | module List = ListLabels
6 |
7 | exception Error of string
8 |
9 | (* generate a unique label id *)
10 | let gen_label, reset =
11 | let counter = ref 0 in
12 | ( (fun () ->
13 | let l = !counter in
14 | counter := !counter + 1;
15 | "$" ^ string_of_int l)
16 | , fun () -> counter := 0 )
17 |
18 | (* compilation environment maps local variable names to local variable
19 | numbers *)
20 | let lookup env var =
21 | match
22 | List.find_opt ~f:(fun (_, v) -> var = v) (List.mapi ~f:(fun idx v -> idx, v) env)
23 | with
24 | | Some v -> fst v
25 | | None -> failwith (Printf.sprintf "%s not found" var)
26 |
27 | let extend_env env var = var :: env
28 | let shift_env env = extend_env env "*dummy*"
29 | let downshift_env env = List.tl env
30 | let return_address_marker = "$ret_addr"
31 | let jit_flg_marker = "$jit_flg"
32 |
33 | let build_arg_env args =
34 | match !sh_flg with
35 | | true -> return_address_marker :: jit_flg_marker :: List.rev args
36 | | false -> return_address_marker :: List.rev args
37 |
38 | (* computes the number of arguments to this frame. The stack has a shape like
39 | [...local vars...][ret addr][..args...], the return address position from the
40 | top indicates the number of local variables on top of the return address. *)
41 | let arity_of_env env =
42 | let num_local_vars = lookup env return_address_marker in
43 | List.length env - num_local_vars - 1, num_local_vars
44 |
45 | let arity_of_env_sh env =
46 | let num_local_vars = lookup env return_address_marker in
47 | let flg_offset = lookup env return_address_marker in
48 | List.length env - num_local_vars - 1, num_local_vars, flg_offset
49 |
50 | let label_counter = ref 0
51 |
52 | let gen_label _ =
53 | let l = !label_counter in
54 | label_counter := l + 1;
55 | "$" ^ string_of_int l
56 |
57 | let reset _ = label_counter := 0
58 |
59 | let compile_id_or_imm env = function
60 | | Asm.C n -> if n = 0 then [ CONST0 ] else [ CONST; Literal n ]
61 | | Asm.V x -> let y = lookup env x in if y = 0 then [ DUP0 ] else [ DUP; Literal y ]
62 |
63 | let rec compile_t fname env =
64 | let open Asm in
65 | function
66 | | Ans (CallDir (Id.L fname', args, fargs) as e) ->
67 | if not @@ !Config.tail_opt_flg
68 | then compile_exp fname env e
69 | else if fname' = fname
70 | then (
71 | let old_arity, local_size = arity_of_env env in
72 | let new_arity = List.length args in
73 | (List.fold_left
74 | ~f:(fun (rev_code_list, env) v ->
75 | compile_id_or_imm env (V v) :: rev_code_list, shift_env env)
76 | ~init:([], env)
77 | args
78 | |> fst
79 | |> List.rev
80 | |> List.flatten)
81 | @ (if !Config.frame_reset_flg
82 | then
83 | [ FRAME_RESET
84 | ; Literal old_arity
85 | ; Literal local_size
86 | ; Literal new_arity
87 | ]
88 | else [])
89 | @ [ JUMP; Lref fname ])
90 | else compile_exp fname env e
91 | | Ans e -> compile_exp fname env e
92 | | Let ((x, _), exp, t) ->
93 | let ex_env = extend_env env x in
94 | compile_exp fname env exp @ compile_t fname ex_env t @ [ POP1 ]
95 |
96 | and compile_exp fname env exp =
97 | let open Asm in
98 | match exp with
99 | | Nop -> []
100 | | Li i -> compile_id_or_imm env (C i)
101 | | Mov var -> compile_id_or_imm env (V var)
102 | | Neg var -> compile_id_or_imm env (V var) @ [ NEG ]
103 | | Add (x, y) -> compile_id_or_imm env (V x) @ compile_id_or_imm (shift_env env) y @ [ ADD ]
104 | | Sub (x, y) -> compile_id_or_imm env (V x) @ compile_id_or_imm (shift_env env) y @ [ SUB ]
105 | | Mul (x, y) -> compile_id_or_imm env (V x) @ compile_id_or_imm (shift_env env) y @ [ MUL ]
106 | | Div (x, y) -> compile_id_or_imm env (V x) @ compile_id_or_imm (shift_env env) y @ [ DIV ]
107 | | Mod (x, y) -> compile_id_or_imm env (V x) @ compile_id_or_imm (shift_env env) y @ [ MOD ]
108 | | IfEq (x, y, then_exp, else_exp) ->
109 | let l2, l1 = gen_label (), gen_label () in compile_id_or_imm env (V x)
110 | @ compile_id_or_imm (shift_env env) y @ [ EQ ] @ [ JUMP_IF_ZERO; Lref l1 ]
111 | @ compile_t fname env then_exp @ [ JUMP; Lref l2 ] @ [ Ldef l1 ]
112 | @ compile_t fname env else_exp @ [ Ldef l2 ]
113 | | IfLE (x, y, then_exp, else_exp) ->
114 | let l2, l1 = gen_label (), gen_label () in compile_id_or_imm env (V x)
115 | @ compile_id_or_imm (shift_env env) y @ [ LT ] @ [ JUMP_IF_ZERO; Lref l1 ]
116 | @ compile_t fname env then_exp @ [ JUMP; Lref l2 ] @ [ Ldef l1 ]
117 | @ compile_t fname env else_exp @ [ Ldef l2 ]
118 | | IfGE (x, y, then_exp, else_exp) ->
119 | let l2, l1 = gen_label (), gen_label () in compile_id_or_imm env (V x)
120 | @ compile_id_or_imm (shift_env env) y @ [ GT ] @ [ JUMP_IF_ZERO; Lref l1 ]
121 | @ compile_t fname env then_exp @ [ JUMP; Lref l2 ] @ [ Ldef l1 ]
122 | @ compile_t fname env else_exp @ [ Ldef l2 ]
123 | | CallDir (Id.L "min_caml_mul", [ x; y ], _) -> compile_id_or_imm env (V x) @ compile_id_or_imm (shift_env env) (V y) @ [ MUL ]
124 | | CallDir (Id.L "min_caml_div", [ x; y ], _) -> compile_id_or_imm env (V x) @ compile_id_or_imm (shift_env env) (V y) @ [ DIV ]
125 | | CallDir (Id.L "min_caml_rem", [ x; y ], _) -> compile_id_or_imm env (V x) @ compile_id_or_imm (shift_env env) (V y) @ [ MOD ]
126 | | CallDir (Id.L "min_caml_read_int", _, _) -> [ READ_INT ]
127 | | CallDir (Id.L "min_caml_print_int", [ x ], _) -> compile_id_or_imm env (V x) @ [ PRINT_INT ]
128 | | CallDir (Id.L "min_caml_read_string", _, _) -> [ READ_STRING ]
129 | | CallDir (Id.L "min_caml_print_string", [x], _) -> compile_id_or_imm env (V x) @ [ PRINT_STRING ]
130 | | CallDir (Id.L "min_caml_print_newline", _, _) -> [ PRINT_NEWLINE ]
131 | | CallDir (Id.L "min_caml_rand_int", [ x ], _) -> compile_id_or_imm env (V x) @ [ RAND_INT ]
132 | | CallDir (Id.L "min_caml_create_array", [ x; y ], _) -> compile_id_or_imm env (V x) @ compile_id_or_imm (shift_env env) (V y) @ [ ARRAY_MAKE ]
133 | | CallDir (Id.L var, rands, _) ->
134 | ( List.fold_left ~f:(fun (rev_code_list, env) v -> compile_id_or_imm env (V v) ::
135 | rev_code_list, shift_env env) ~init:([], env) rands |> fst |> List.rev |> List.flatten)
136 | @ (if fname = "main" then [ JIT_SETUP ] else []) @ [ CALL; Lref var; Literal (List.length rands) ]
137 | | Ld (x, y, _) -> compile_id_or_imm env (V x) @ compile_id_or_imm (shift_env env) y @ [ GET ]
138 | | St (x, y, z, _) -> compile_id_or_imm env (V x) @ compile_id_or_imm (shift_env env) (V y) @ compile_id_or_imm (shift_env (shift_env env)) z @ [ PUT ]
139 | | Stw (x, y, z) -> compile_id_or_imm env (V x) @ compile_id_or_imm (shift_env env) (V y) @ compile_id_or_imm (shift_env (shift_env env)) z @ [ PUT ]
140 | | exp -> failwith (Printf.sprintf "un matched pattern: %s" (Asm.show_exp exp))
141 | ;;
142 |
143 | let rec assoc_tail_rec fname = function
144 | | Ans (CallDir (Id.L fname', args, fargs)) -> fname = fname'
145 | | Ans e -> assoc_tail_rec' fname e
146 | | Let (_, _, t) -> assoc_tail_rec fname t
147 |
148 | and assoc_tail_rec' fname = function
149 | | IfEq (_, _, e1, e2)
150 | | IfLE (_, _, e1, e2)
151 | | IfGE (_, _, e1, e2)
152 | | IfFEq (_, _, e1, e2)
153 | | IfFLE (_, _, e1, e2) ->
154 | assoc_tail_rec fname e1 || assoc_tail_rec fname e2
155 | | e -> false
156 | ;;
157 |
158 | (* resolving labels *)
159 | let assoc_if subst elm = try List.assoc elm subst with Not_found -> elm
160 |
161 | (* [...;Ldef a;...] -> [...;a,i;...] where i is the index of the next
162 | instruction of Ldef a in the list all Ldefs are removed e.g., [_;Ldef
163 | 8;_;Ldef 7;_] ==> [8,1; 7,2] *)
164 | let make_label_env instrs =
165 | snd
166 | (List.fold_left
167 | ~f:
168 | (fun (addr, env) -> function
169 | | Ldef n -> addr, (Lref n, Literal addr) :: env
170 | | _ -> addr + 1, env)
171 | ~init:(0, [])
172 | instrs)
173 | ;;
174 |
175 | (* remove all Ldefs and replace Lrefs with Literals *)
176 | let resolve_labels instrs =
177 | let lenv = make_label_env instrs in
178 | instrs
179 | |> List.map ~f:(assoc_if lenv)
180 | |> List.filter ~f:(function Ldef _ -> false | _ -> true)
181 | ;;
182 |
183 | let compile_fun_body fenv name arity annot exp env =
184 | (match annot with
185 | (* | Some `TJ -> [ TRACING_COMP ]
186 | | Some `MJ -> [ METHOD_COMP ] *)
187 | | Some _ -> []
188 | | None -> []) @ [ Ldef name ] @ compile_t name env exp @ if name = "main" then [ HALT ] else [ RET; Literal arity ]
189 |
190 | let compile_fun
191 | (fenv : Id.l -> Asm.fundef)
192 | Asm.{ name = Id.L name; args; body; annot }
193 | =
194 | compile_fun_body fenv name (List.length args) annot body (build_arg_env args)
195 | ;;
196 |
197 | let compile_funs fundefs =
198 | (* let fenv name = fst(List.find (fun (_,{name=n}) -> name=n)
199 | * (List.mapi (fun idx fdef -> (idx,fdef))
200 | * fundefs)) in *)
201 | let fenv name = List.find ~f:(fun Asm.{ name = n } -> n = name) fundefs in
202 | Array.of_list
203 | (resolve_labels (List.flatten (List.map ~f:(compile_fun fenv) fundefs)))
204 | ;;
205 |
206 | let resolve_labels' instrs =
207 | List.fold_left ~init:(0, []) ~f:(fun (addr, env) -> function
208 | | Ldef n -> addr, (Lref n, Literal addr) :: env | _ -> addr + 1, env)
209 | ;;
210 |
211 | let f (Asm.Prog (_, fundefs, main)) =
212 | let open Asm in
213 | let main =
214 | { name = Id.L "main"
215 | ; args = []
216 | ; fargs = []
217 | ; ret = Type.Int
218 | ; body = main
219 | ; annot = None
220 | }
221 | in
222 | compile_funs (main :: fundefs)
223 | ;;
224 |
--------------------------------------------------------------------------------
/src/vm/emit.mli:
--------------------------------------------------------------------------------
1 | open MinCaml
2 | open Insts
3 |
4 | val f : Asm.prog -> inst array
5 |
--------------------------------------------------------------------------------
/src/vm/float.c:
--------------------------------------------------------------------------------
1 | #include
2 | #include
3 | #include
4 | #include
5 |
6 | typedef union {
7 | int32_t i[2];
8 | double d;
9 | } dbl;
10 |
11 | value gethi(value v) {
12 | dbl d;
13 | d.d = Double_val(v);
14 | return caml_copy_int32(d.i[0]);
15 | }
16 |
17 | value getlo(value v) {
18 | dbl d;
19 | d.d = Double_val(v);
20 | return caml_copy_int32(d.i[1]);
21 | }
22 |
--------------------------------------------------------------------------------
/src/vm/insts.ml:
--------------------------------------------------------------------------------
1 |
2 | type inst =
3 | | UNIT (* terminator *)
4 | | ADD | SUB | MUL | DIV | MOD | NOT | NEG (* binary and ALU ops *)
5 | | LT | GT | EQ (* equality *)
6 | | JUMP_IF_ZERO | JUMP | CALL | RET | HALT (* control flow *)
7 | | DUP | DUP0 | POP0 | POP1 (* stack ops *)
8 | | CONST0 | CONST (* constants *)
9 | | GET | PUT | ARRAY_MAKE (* vectors *)
10 | | FRAME_RESET | JIT_SETUP (* o l n *)
11 | | RAND_INT | READ_INT | READ_STRING (* io read *)
12 | | PRINT_INT | PRINT_NEWLINE | PRINT_STRING (* io write *)
13 | | Literal of int
14 | | Lref of string
15 | | Ldef of string [@@deriving show]
16 |
17 | let index_of instr = match instr with
18 | | UNIT -> 0 | ADD -> 1 | SUB -> 2 | MUL -> 3
19 | | DIV -> 4 | MOD -> 5 | NOT -> 6 | NEG -> 7
20 | | LT -> 8 | GT -> 9 | EQ -> 10 | HALT -> 11
21 | | JUMP_IF_ZERO -> 12 | JUMP -> 13 | CALL -> 14 | RET -> 15
22 | | DUP -> 16 | DUP0 -> 17 | POP0 -> 18 | POP1 -> 19 | CONST0 -> 20
23 | | CONST -> 21 | GET -> 22 | PUT -> 23 | ARRAY_MAKE -> 24
24 | | FRAME_RESET -> 25 | JIT_SETUP -> 26
25 | | RAND_INT -> 27 | READ_INT -> 28 | READ_STRING -> 29
26 | | PRINT_INT -> 30 | PRINT_NEWLINE -> 31 | PRINT_STRING -> 32
27 | | _ -> 33
28 |
29 | let instsmap =
30 | [| UNIT ; ADD ; SUB ; MUL ; DIV ; MOD ; NOT ; NEG
31 | ; LT ; GT ; EQ ; JUMP_IF_ZERO ; JUMP ; CALL ; RET ; HALT
32 | ; DUP ; DUP0 ; POP0 ; POP1 ; CONST0 ; CONST
33 | ; GET ; PUT ; ARRAY_MAKE ; FRAME_RESET ; JIT_SETUP
34 | ; RAND_INT ; READ_INT ; READ_STRING
35 | ; PRINT_INT ; PRINT_NEWLINE ; PRINT_STRING
36 | |]
37 |
38 | module Printer = struct
39 | let pp_inst_map () =
40 | ignore
41 | (Array.fold_left
42 | (fun i instr ->
43 | Printf.printf "%s => %d\n" (show_inst instr) i;
44 | i + 1)
45 | 0
46 | instsmap)
47 | ;;
48 |
49 | let pp_insts_counter = ref 0
50 |
51 | let pp_pc () =
52 | print_int !pp_insts_counter;
53 | print_string "\t";
54 | incr pp_insts_counter
55 | ;;
56 |
57 | let rec pp_insts ?(i = 0) insts =
58 | match insts with
59 | | [] -> ()
60 | | hd :: tl ->
61 | (match hd with
62 | | CONST | DUP | JUMP | JUMP_IF_ZERO | RET ->
63 | pp_pc ();
64 | print_string (show_inst hd);
65 | print_string " ";
66 | pp_insts ~i:0 tl
67 | | CALL ->
68 | pp_pc ();
69 | print_string (show_inst hd);
70 | print_string " ";
71 | pp_insts ~i:1 tl
72 | | Literal n ->
73 | print_string "\t";
74 | print_string (show_inst hd);
75 | if i = 0 then print_newline () else print_string "\t";
76 | incr pp_insts_counter;
77 | pp_insts ~i:(i - 1) tl
78 | | _ ->
79 | pp_pc ();
80 | print_string (show_inst hd);
81 | print_newline ();
82 | pp_insts ~i:0 tl)
83 | ;;
84 |
85 | let rec pp_bytecode oc insts =
86 | insts
87 | |> Array.mapi (fun i x -> i, x)
88 | |> Array.map (fun (i, instr) ->
89 | match instr with
90 | | CONST | DUP | JUMP | JUMP_IF_ZERO | CALL | RET ->
91 | Printf.fprintf oc "code.(%d) <- %d; " i (index_of instr)
92 | | Literal j -> Printf.fprintf oc "code.(%d) <- %d;\n" i j
93 | | _ -> Printf.fprintf oc "code.(%d) <- %d;\n" i (index_of instr))
94 | |> ignore
95 | ;;
96 |
97 | let write_bytecode oc insts =
98 | Printf.fprintf oc "%d\n" (Array.length insts);
99 | insts
100 | |> Array.map (fun instr ->
101 | match instr with
102 | | Literal j -> Printf.fprintf oc "%d\n" j
103 | | _ -> Printf.fprintf oc "%d\n" (index_of instr))
104 | |> ignore
105 | ;;
106 | end
107 |
--------------------------------------------------------------------------------
/src/vm/insts.mli:
--------------------------------------------------------------------------------
1 | type inst =
2 | | UNIT (* terminator *)
3 | | ADD | SUB | MUL | DIV | MOD | NOT | NEG (* binary and ALU ops *)
4 | | LT | GT | EQ (* equality *)
5 | | JUMP_IF_ZERO | JUMP | CALL | RET | HALT (* control flow *)
6 | | DUP | DUP0 | POP0 | POP1 (* stack ops *)
7 | | CONST0 | CONST (* constants *)
8 | | GET | PUT | ARRAY_MAKE (* vectors *)
9 | | FRAME_RESET | JIT_SETUP (* o l n *)
10 | | RAND_INT | READ_INT | READ_STRING (* io read *)
11 | | PRINT_INT | PRINT_NEWLINE | PRINT_STRING (* io write *)
12 | | Literal of int
13 | | Lref of string
14 | | Ldef of string
15 |
16 | val index_of : inst -> int
17 | val show_inst : inst -> string
18 | val instsmap : inst array
19 |
20 | module Printer : sig
21 | val pp_inst_map : unit -> unit
22 | val pp_insts : ?i:int -> inst list -> unit
23 | val pp_bytecode : out_channel -> inst array -> unit
24 | val write_bytecode : out_channel -> inst array -> unit
25 | end
26 |
--------------------------------------------------------------------------------
/src/vm/libmincaml.c:
--------------------------------------------------------------------------------
1 | #include
2 | #include
3 |
4 | // NOTE: コンパイル後のシンボルのプリフィックスに _ がつくのを避ける
5 | void min_caml_print_int(long n) asm("min_caml_print_int");
6 | void min_caml_print_newline() asm("min_caml_print_newline");
7 | long* min_caml_create_array(long number_of_element, long init_value) asm("min_caml_create_array");
8 | double* min_caml_create_float_array(long number_of_element, double float_value) asm("min_caml_create_float_array");
9 | long min_caml_truncate(double d) asm("min_caml_truncate");
10 | void min_caml_print_float(double d) asm("min_caml_print_float");
11 | void min_caml_print_byte(long n) asm("min_caml_print_byte");
12 | long min_caml_read_int() asm("min_caml_read_int");
13 | long min_caml_mul(long x, long y) asm("min_caml_mul");
14 | long min_caml_div(long x, long y) asm("min_caml_div");
15 | long min_caml_rem(long x, long y) asm("min_caml_rem");
16 | double min_caml_read_float() asm("min_caml_read_float");
17 | double min_caml_atan(double x) asm("min_caml_atan");
18 | double min_caml_cos(double x) asm("min_caml_cos");
19 | double min_caml_floor(double x) asm("min_caml_floor");
20 | double min_caml_sin(double x) asm("min_caml_sin");
21 | double min_caml_abs_float(double x) asm("min_caml_abs_float");
22 | double min_caml_float_of_int(long n) asm("min_caml_float_of_int");
23 | long min_caml_int_of_float(double d) asm("min_caml_int_of_float");
24 | double min_caml_sqrt(double d) asm("min_caml_sqrt");
25 |
26 | void min_caml_print_int(long n) {
27 | printf("%ld", n);
28 | }
29 |
30 | void min_caml_print_newline() {
31 | printf("\n");
32 | }
33 |
34 | long* min_caml_create_array(long number_of_element, long init_value) {
35 | long *heap_ptr;
36 |
37 | // x27 に格納されたヒープのアドレスを heap_ptr へ書き出す
38 | asm volatile ("mov %0, x27" : "=r"(heap_ptr));
39 |
40 | // Array の先頭アドレスを取得
41 | long *array_ptr = heap_ptr;
42 |
43 | for (long i = 0l; i < number_of_element; i++) {
44 | // Array へ書き込んだ後、ヒープの先頭アドレスを8バイト進める
45 | *heap_ptr = init_value;
46 | heap_ptr += 1;
47 | }
48 |
49 | // ヒープの先頭アドレスを x27 に書き戻す
50 | asm volatile ("mov x27, %0" : : "r"(heap_ptr));
51 |
52 | return array_ptr;
53 | }
54 |
55 | double* min_caml_create_float_array(long number_of_element, double float_value) {
56 | double *heap_ptr;
57 |
58 | // x27 に格納されたヒープのアドレスを heap_ptr へ書き出す
59 | asm volatile ("mov %0, x27" : "=r"(heap_ptr));
60 |
61 | // Array の先頭アドレスを取得
62 | double *array_ptr = heap_ptr;
63 |
64 | for (long i = 0l; i < number_of_element; i++) {
65 | // Array へ書き込んだ後、ヒープの先頭アドレスを8バイト進める
66 | *heap_ptr = float_value;
67 | heap_ptr += 1;
68 | }
69 |
70 | // ヒープの先頭アドレスを x27 に書き戻す
71 | asm volatile ("mov x27, %0" : : "r"(heap_ptr));
72 |
73 | return array_ptr;
74 | }
75 |
76 | // truncate
77 | long min_caml_truncate(double d) {
78 | return (long)d;
79 | }
80 |
81 | void min_caml_print_float(double d) {
82 | printf("%lf", d);
83 | }
84 |
85 | void min_caml_print_byte(long n) {
86 | putchar(n);
87 | }
88 |
89 | long min_caml_read_int() {
90 | long l;
91 | // fscanf(fp, "%ld", &l);
92 | scanf("%ld", &l);
93 | return l;
94 | }
95 |
96 | double min_caml_read_float() {
97 | double d;
98 | // fscanf(fp, "%lf", &d);
99 | scanf("%lf", &d);
100 | return d;
101 | }
102 |
103 | // atan
104 | double min_caml_atan(double x) {
105 | return atan(x);
106 | }
107 |
108 | // cos
109 | double min_caml_cos(double x) {
110 | return cos(x);
111 | }
112 |
113 | // floor
114 | double min_caml_floor(double x) {
115 | return floor(x);
116 | }
117 |
118 | // sin
119 | double min_caml_sin(double x) {
120 | return sin(x);
121 | }
122 |
123 | // abs_float
124 | double min_caml_abs_float(double x) {
125 | return fabs(x);
126 | }
127 |
128 | // float_of_int
129 | double min_caml_float_of_int(long n) {
130 | return (double)n;
131 | }
132 |
133 | // int_of_float
134 | long min_caml_int_of_float(double d) {
135 | return (long)d;
136 | }
137 |
138 | long min_caml_div(long x, long y) {
139 | return (long)(x/y);
140 | }
141 |
142 | long min_caml_rem(long x, long y) {
143 | return x % y;
144 | }
145 |
146 | long min_caml_mul(long x, long y) {
147 | return x * y;
148 | }
149 |
150 | // sqrt
151 | double min_caml_sqrt(double d) {
152 | return sqrt(d);
153 | }
154 |
--------------------------------------------------------------------------------
/src/vm/main.ml:
--------------------------------------------------------------------------------
1 | open MinCaml
2 | open Stdlib
3 | open Printf
4 |
5 | type backend = Compile | Interpret | Nothing
6 |
7 | let backend_type = ref Compile
8 | let show_insts_map_type = ref false
9 | let debug_flg = ref false
10 |
11 | let with_debug f =
12 | match !debug_flg with
13 | | true -> BacCaml.Config.vm_debug_flg := true; f ()
14 | | false -> f ()
15 |
16 | let with_show_insts f =
17 | match !show_insts_map_type with
18 | | true -> BacCaml.Insts.Printer.pp_inst_map ()
19 | | false -> f ()
20 |
21 | let rec normalForm l =
22 | let open BacCaml in
23 | let expression = Parser.exp Lexer.token l in
24 | expression |> Typing.f
25 | |> KNormal.f
26 | |> Alpha.f
27 | |> Util.(iter !limit)
28 | |> Closure.f
29 | |> Virtual.f
30 | |> Simm.f
31 |
32 | let compileSource ml =
33 | let input = Lexing.from_channel ml in
34 | let res = normalForm input in
35 | let _ = close_in ml in res
36 |
37 | let main f =
38 | let r x = match x with
39 | | BacCaml.Insts.Literal i -> Printf.printf "%d;" i
40 | | _ -> Printf.printf "%d;" (BacCaml.Insts.index_of x) in
41 | Id.counter := 0;
42 | Typing.extenv := M.empty;
43 | try match !backend_type with
44 | | Interpret ->
45 | let joe = open_in_bin ((Filename.remove_extension f) ^ ".joe") in
46 | let insts = (Marshal.from_channel joe) in BacCaml.VM.run_asm insts ; close_in joe
47 | | Compile ->
48 | let ml = open_in ((Filename.remove_extension f) ^ ".ml") in
49 | let vm = open_out_gen [Open_binary;Open_wronly;Open_creat] 0o644 ((Filename.remove_extension f) ^ ".joe") in
50 | let insts = (BacCaml.Emit.f (compileSource ml)) in
51 | Stdlib.output_bytes vm (Marshal.to_bytes insts [Marshal.No_sharing]) ; close_out vm
52 | | Nothing -> ()
53 | with | Invalid_argument _ -> ()
54 | | e -> raise e
55 |
56 | let () =
57 | let files = ref [] in
58 | BacCaml.(
59 | Arg.parse
60 | [ ( "-debug", Arg.Unit (fun _ -> debug_flg := true), "run as debug mode" ) ;
61 | ( "-compile", Arg.Unit (fun _ -> backend_type := Compile), "emit MinCaml IR" ) ;
62 | ( "-exec", Arg.Unit (fun _ -> backend_type := Interpret), "run IR in VM interpreter" ) ;
63 | ( "-no-tail", Arg.Unit (fun _ -> Config.tail_opt_flg := false), "disable optimization for tail-recursive call") ;
64 | ( "-no-fr", Arg.Unit (fun _ -> Config.frame_reset_flg := true), "disable to emit frame_reset" )
65 | ])
66 | (fun s -> files := !files @ [ s ])
67 | ( "MinCaml IR Virtual Machine (c) 2024 Namdak Tonpa\n"
68 | ^ "usage: vm [-options] filenames");
69 | with_show_insts (fun _ -> with_debug (fun _ -> List.iter main !files))
70 |
71 |
--------------------------------------------------------------------------------
/src/vm/vM.ml:
--------------------------------------------------------------------------------
1 | open Printf
2 | open MinCaml
3 | open Config
4 | open Insts
5 | open Stdlib
6 |
7 | let max_stack_depth = 100000
8 |
9 | type fundef_bin_t = int array (* run the given program by calling the function id 0 *)
10 | type fundef_asm_t = inst array (* convert the given program into binary, and then run *)
11 |
12 | let with_debug f = match !vm_debug_flg with true -> f () | false -> ()
13 |
14 | let index_of element array =
15 | fst (List.find
16 | (fun (_, v) -> v = element)
17 | (List.mapi (fun idx v -> idx, v) (Array.to_list array)))
18 |
19 | let int_of_inst = function
20 | | Literal n -> n
21 | | Ldef lbl | Lref lbl -> failwith ("unresolved " ^ lbl)
22 | | inst -> index_of inst instsmap
23 |
24 | let string_of = function
25 | | Literal n -> Printf.sprintf "Literal %d" n
26 | | Ldef n -> Printf.sprintf "Ldef %s" n
27 | | Lref n -> Printf.sprintf "Lref %s" n
28 | | i -> string_of_int (int_of_inst i)
29 |
30 | (* operand stack
31 |
32 | We pair the stack pointer and the array of values. Though the reference to
33 | the arry is not changed over the push/pop operations, those operations return
34 | a new pair just for convenience. If we switch to the MinCaml implementation,
35 | we should decouple the pair. *)
36 |
37 | type value =
38 | | Int' of int
39 | | String' of string
40 | | Array' of value array [@@deriving show]
41 |
42 | type stack = int * value array
43 | let push : stack -> value -> stack = fun (sp, stack) v -> stack.(sp) <- v ; sp + 1, stack
44 | let pop : stack -> value * stack = fun (sp, stack) -> stack.(sp - 1), (sp - 1, stack)
45 | let take : stack -> int -> value = fun (sp, stack) n -> stack.(sp - n - 1)
46 | let drop : stack -> int -> stack = fun (sp, stack) n -> sp - n, stack
47 |
48 | module Value = struct
49 | let ( |+| ) v1 v2 = match v1, v2 with | Int' i, Int' j -> Int' (i + j) | _ -> failwith "invalid value"
50 | let ( |-| ) v1 v2 = match v1, v2 with | Int' i, Int' j -> Int' (i - j) | _ -> failwith "invalid value"
51 | let ( |*| ) v1 v2 = match v1, v2 with | Int' i, Int' j -> Int' (i * j) | _ -> failwith "invalid value"
52 | let ( |/| ) v1 v2 = match v1, v2 with | Int' i, Int' j -> Int' (i / j) | _ -> failwith "invalid value"
53 | let ( |%| ) v1 v2 = match v1, v2 with | Int' i, Int' j -> Int' (i mod j) | _ -> failwith "invalid_value"
54 | let ( |<| ) v1 v2 = match v1, v2 with | Int' i, Int' j -> i < j | _ -> failwith "invalid value"
55 | let ( |=| ) v1 v2 = match v1, v2 with | Int' i, Int' j -> i = j | _ -> failwith "invalid value"
56 |
57 | let int_of_value = function
58 | | Int' i -> i
59 | | String' _ -> failwith "string is not int"
60 | | Array' _ -> failwith "array is not int"
61 |
62 | let string_of_value = function
63 | | Int' i -> failwith (sprintf "int %d is not string" i)
64 | | String' s -> s
65 | | Array' arr -> failwith (sprintf "array is not string")
66 |
67 | let array_of_value = function
68 | | Int' i -> failwith (sprintf "int %d is not array" i)
69 | | String' s -> failwith (sprintf "string %s is not array" s)
70 | | Array' arr -> arr
71 |
72 | let value_of_int i = Int' i
73 | let value_of_array arr = Array' arr
74 | let value_of_string s = String' s
75 | end
76 |
77 |
78 | let frame_reset : stack -> int -> int -> int -> stack =
79 | fun (sp, stack) o l n ->
80 | let ret = stack.(sp - n - l - 1) in
81 | (* save return address *)
82 | let jit_flg = stack.(sp - n - l - 2) in
83 | let old_base = sp - n - l - o - 1 in
84 | let new_base = sp - n in
85 | let _ =
86 | with_debug (fun () ->
87 | eprintf
88 | "offset: %d ret: %d, sp: %d, old_base: %d, new_base: %d\n"
89 | (sp - n - l - 1)
90 | (Value.int_of_value ret)
91 | sp
92 | old_base
93 | new_base)
94 | in
95 | let rec loop i =
96 | if n = i
97 | then (
98 | match !sh_flg with
99 | | true ->
100 | stack.(old_base + n) <- jit_flg;
101 | stack.(old_base + (n + 1)) <- ret;
102 | old_base + n + 2, stack
103 | | false ->
104 | stack.(old_base + n) <- ret;
105 | old_base + n + 1, stack)
106 | else (
107 | stack.(old_base + i) <- stack.(new_base + i);
108 | loop (i + 1))
109 | in
110 | loop 0
111 |
112 | let make_stack () = 0, Array.make max_stack_depth (Int' 0)
113 |
114 | (* let test_stack =(9, [|1;2;3;4;5;6;7;8;9|])
115 | * let reset_result = frame_reset test_stack 2 2 3
116 | * let _ = Printf.printf "reset -> [%s]\n"
117 | * (String.concat ";"
118 | * (List.map string_of_int (Array.to_list (snd reset_result))))
119 | * let _ = assert ((5, [|1;7;8;9;4;6;7;8;9|]) = reset_result) *)
120 |
121 | (* fetch one integer from the code, and advance the program counter *)
122 | let fetch code pc = code.(pc), pc + 1
123 |
124 | let code_at_pc code pc =
125 | if 0 <= pc && pc < Array.length code
126 | then Printf.sprintf "code[%d..]=%d %d" pc code.(pc)
127 | ( if pc + 1 < Array.length code then code.(pc + 1) else -1 )
128 | else Printf.sprintf "pc=%d" pc
129 |
130 | let dump_stack (sp, stack) =
131 | let rec loop i = if i = sp then "" else
132 | ( match stack.(i) with Int' i -> string_of_int i | Array' _ -> "array" | String' _ -> "string" )
133 | ^ ";" ^ loop (i + 1) in "[" ^ loop 0 ^ "]"
134 |
135 | (* when the VM won't stop, you may turn on the following function to forcingly
136 | terminate after executing a certain amount of instructions *)
137 | let checkpoint =
138 | if false then (let counter = ref 5000 in fun () ->
139 | if !counter = 0 then failwith "expired!" else counter := !counter - 1)
140 | else fun () -> ()
141 |
142 | let debug pc inst stack = with_debug (fun () -> Printf.printf "%d %s %s\n" (pc - 1) (show_inst inst) (dump_stack stack))
143 |
144 | let rec interp code pc stack =
145 | checkpoint ();
146 | let open Value in
147 | if pc < 0
148 | then
149 | fst (pop stack)
150 | else try
151 | let i, pc = fetch code pc in
152 | let _ = Printf.printf "%d:%d\n" pc i in
153 | let inst = instsmap.(i) in
154 | debug pc inst stack;
155 | match inst with
156 | | UNIT ->
157 | interp code (pc + 1) stack
158 | | NOT ->
159 | let v, stack = pop stack in
160 | let stack = if int_of_value v = 0 then push stack (Int' 1) else push stack (Int' 0) in
161 | interp code pc stack
162 | | NEG ->
163 | let v, stack = pop stack in
164 | let stack = push stack (v |*| Int' (-1)) in
165 | interp code pc stack
166 | | ADD ->
167 | let v2, stack = pop stack in
168 | let v1, stack = pop stack in
169 | let stack = push stack (v1 |+| v2) in
170 | interp code pc stack
171 | | SUB ->
172 | let v2, stack = pop stack in
173 | let v1, stack = pop stack in
174 | let stack = push stack (v1 |-| v2) in
175 | interp code pc stack
176 | | MUL ->
177 | let v2, stack = pop stack in
178 | let v1, stack = pop stack in
179 | let stack = push stack (v1 |*| v2) in
180 | interp code pc stack
181 | | MOD ->
182 | let v2, stack = pop stack in
183 | let v1, stack = pop stack in
184 | let stack = push stack (v1 |%| v2) in
185 | interp code pc stack
186 | | DIV ->
187 | let v2, stack = pop stack in
188 | let v1, stack = pop stack in
189 | let stack = push stack (v1 |/| v2) in
190 | interp code pc stack
191 | | LT ->
192 | let v2, stack = pop stack in
193 | let v1, stack = pop stack in
194 | let stack = push stack (if v1 |<| v2 then Int' 1 else Int' 0) in
195 | interp code pc stack
196 | | EQ ->
197 | let v2, stack = pop stack in
198 | let v1, stack = pop stack in
199 | let stack = push stack (if v1 |=| v2 then Int' 1 else Int' 0) in
200 | interp code pc stack
201 | | CONST ->
202 | let c, pc = fetch code pc in
203 | let stack = push stack (value_of_int c) in
204 | interp code pc stack
205 | | CONST0 ->
206 | let stack = push stack (value_of_int 0) in
207 | interp code pc stack
208 | | JUMP_IF_ZERO (* addr *) ->
209 | let addr, pc = fetch code pc in
210 | let v, stack = pop stack in
211 | (* interp code (if v=0 then addr else pc) stack *)
212 | if int_of_value v = 0
213 | then interp code addr stack
214 | else interp code pc stack
215 | | CALL (* addr argnum *) ->
216 | (* calling a function will create a new operand stack and lvars *)
217 | let addr, pc = fetch code pc in
218 | let _, pc = fetch code pc in
219 | (match !stack_mode_flg with
220 | | `User_stack ->
221 | let stack = Emit.(if !sh_flg then push stack (Int' 200) else stack) in
222 | let stack = push stack (value_of_int pc) in
223 | (* save return address *)
224 | (* (let (sp,s)=stack in
225 | * if 2
232 | let stack = Emit.(if !sh_flg then push stack (Int' 100) else stack) in
233 | let v = interp code addr stack in
234 | let stack = push stack v in
235 | interp code pc stack)
236 | | RET (* n *) ->
237 | (* let pc0 = pc-1 in *)
238 | let n, pc = fetch code pc in
239 | let v, stack = pop stack in
240 | let _, stack = Emit.(if !sh_flg then pop stack else Int' 0, stack) in
241 | (match !stack_mode_flg with
242 | | `User_stack ->
243 | (* return value *)
244 | let pc, stack = pop stack in
245 | (* return address *)
246 | let stack = drop stack n in
247 | (* delete arguments *)
248 | let stack = push stack v in
249 | (* restore return value *)
250 | (* Printf.printf "%d RET with %d to %d\n" pc0 v pc; *)
251 | interp code (int_of_value pc) stack
252 | | `Host_stack -> v)
253 | | DUP ->
254 | let n, pc = fetch code pc in
255 | let stack = push stack (take stack n) in
256 | interp code pc stack
257 | | DUP0 ->
258 | let stack = push stack (take stack 0) in
259 | interp code pc stack
260 | | HALT -> fst (pop stack) (* just return the top value *)
261 | | FRAME_RESET (* o l n *) ->
262 | let o, pc = fetch code pc in
263 | let l, pc = fetch code pc in
264 | let n, pc = fetch code pc in
265 | let _ = Printf.printf "Frame Reset size: %d %d %d\n", o, l, n in
266 | let _ = with_debug (fun _ -> eprintf "o: %d, l %d, n: %d\n" o l n) in
267 | let stack = frame_reset stack o l n in
268 | interp code pc stack
269 | | POP1 ->
270 | let v, stack = pop stack in
271 | let _, stack = pop stack in
272 | let stack = push stack v in
273 | interp code pc stack
274 | | JUMP (* addr *) ->
275 | let n, _ = fetch code pc in
276 | interp code n stack
277 | | ARRAY_MAKE ->
278 | let init, stack = pop stack in
279 | let size, stack = pop stack in
280 | let stack = push stack (value_of_array (Array.make (int_of_value size) init)) in
281 | Printf.printf "ARRAY_MAKE size: 1\n" ; interp code pc stack
282 | | GET ->
283 | let n, stack = pop stack in
284 | let arr, stack = pop stack in
285 | let _ = Printf.printf "GET n: 1\n" in
286 | let stack = push stack (array_of_value arr).(int_of_value n) in
287 | interp code pc stack
288 | | PUT ->
289 | let i, stack = pop stack in
290 | let arr, stack = pop stack in
291 | let n, stack = pop stack in
292 | (array_of_value arr).(int_of_value i) <- n;
293 | let stack = push stack arr in
294 | interp code pc stack
295 | | PRINT_NEWLINE ->
296 | print_newline ();
297 | interp code pc stack
298 | | RAND_INT ->
299 | let n, stack = pop stack in
300 | let v = Random.int (int_of_value n) in
301 | let stack = push stack (value_of_int v) in
302 | interp code pc stack
303 | | READ_INT ->
304 | let v = read_int () in
305 | let stack = push stack (value_of_int v) in
306 | interp code pc stack
307 | | JIT_SETUP -> interp code pc stack
308 | | READ_STRING ->
309 | let v = read_line () in
310 | let stack = push stack (value_of_string v) in
311 | interp code pc stack
312 | | PRINT_INT ->
313 | let n, stack = pop stack in
314 | print_int (int_of_value n);
315 | let stack = push stack n in
316 | interp code pc stack
317 | | PRINT_STRING ->
318 | let s, stack = pop stack in
319 | let v = string_of_value s in print_string v;
320 | let stack = v |> String.length |> value_of_int |> push stack in
321 | interp code pc stack
322 | | _ -> failwith (sprintf "un matched pattern: %s" (show_inst inst))
323 | with | e -> raise e
324 |
325 | let run_bin : fundef_bin_t -> int = fun fundefs ->
326 | let open Value in
327 | let stack = push (make_stack ()) (value_of_int (-987)) in
328 | int_of_value @@ interp fundefs 0 stack
329 |
330 | let run_asm : fundef_asm_t -> int = fun fundefs -> run_bin (Array.map int_of_inst fundefs)
331 |
--------------------------------------------------------------------------------
/src/x64/dune:
--------------------------------------------------------------------------------
1 | (library
2 | (name x64)
3 | (public_name joe.x64)
4 | (flags (-w -4-33-40-41))
5 | (libraries str MinCaml)
6 | (foreign_stubs (language c) (names libmincaml))
7 | (preprocess (pps ppx_deriving.show)))
8 |
--------------------------------------------------------------------------------
/src/x64/emit.ml:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/groupoid/joe/4bbf1a33ef17e076df3bac47fe32e5604243b2d5/src/x64/emit.ml
--------------------------------------------------------------------------------
/src/x64/emit.mli:
--------------------------------------------------------------------------------
1 | open MinCaml
2 |
3 | val f : out_channel -> Asm.prog -> unit
4 |
--------------------------------------------------------------------------------
/src/x64/lib.c:
--------------------------------------------------------------------------------
1 | #include
2 | #include
3 |
4 | // NOTE: コンパイル後のシンボルのプリフィックスに _ がつくのを避ける
5 | void min_caml_print_int(long n) asm("min_caml_print_int");
6 | void min_caml_print_newline() asm("min_caml_print_newline");
7 | long* min_caml_create_array(long number_of_element, long init_value) asm("min_caml_create_array");
8 | double* min_caml_create_float_array(long number_of_element, double float_value) asm("min_caml_create_float_array");
9 | long min_caml_truncate() asm("min_caml_truncate");
10 | void min_caml_print_float(double d) asm("min_caml_print_float");
11 | void min_caml_print_byte(long n) asm("min_caml_print_byte");
12 | long min_caml_read_int() asm("min_caml_read_int");
13 | double min_caml_read_float() asm("min_caml_read_float");
14 | double min_caml_atan(double x) asm("min_caml_atan");
15 | double min_caml_cos(double x) asm("min_caml_cos");
16 | double min_caml_floor(double x) asm("min_caml_floor");
17 | double min_caml_sin(double x) asm("min_caml_sin");
18 | double min_caml_abs_float(double x) asm("min_caml_abs_float");
19 | double min_caml_float_of_int(long n) asm("min_caml_float_of_int");
20 | long min_caml_int_of_float(double d) asm("min_caml_int_of_float");
21 | double min_caml_sqrt(double d) asm("min_caml_sqrt");
22 |
23 | void min_caml_print_int(long n) {
24 | printf("%ld", n);
25 | }
26 |
27 | void min_caml_print_newline() {
28 | printf("\n");
29 | }
30 |
31 | long* min_caml_create_array(long number_of_element, long init_value) {
32 | long *heap_ptr;
33 |
34 | // x27 に格納されたヒープのアドレスを heap_ptr へ書き出す
35 | asm volatile ("mov %0, x27" : "=r"(heap_ptr));
36 |
37 | // Array の先頭アドレスを取得
38 | long *array_ptr = heap_ptr;
39 |
40 | for (long i = 0l; i < number_of_element; i++) {
41 | // Array へ書き込んだ後、ヒープの先頭アドレスを8バイト進める
42 | *heap_ptr = init_value;
43 | heap_ptr += 1;
44 | }
45 |
46 | // ヒープの先頭アドレスを x27 に書き戻す
47 | asm volatile ("mov x27, %0" : : "r"(heap_ptr));
48 |
49 | return array_ptr;
50 | }
51 |
52 | double* min_caml_create_float_array(long number_of_element, double float_value) {
53 | double *heap_ptr;
54 |
55 | // x27 に格納されたヒープのアドレスを heap_ptr へ書き出す
56 | asm volatile ("mov %0, x27" : "=r"(heap_ptr));
57 |
58 | // Array の先頭アドレスを取得
59 | double *array_ptr = heap_ptr;
60 |
61 | for (long i = 0l; i < number_of_element; i++) {
62 | // Array へ書き込んだ後、ヒープの先頭アドレスを8バイト進める
63 | *heap_ptr = float_value;
64 | heap_ptr += 1;
65 | }
66 |
67 | // ヒープの先頭アドレスを x27 に書き戻す
68 | asm volatile ("mov x27, %0" : : "r"(heap_ptr));
69 |
70 | return array_ptr;
71 | }
72 |
73 | // truncate
74 | long min_caml_truncate(double d) {
75 | return (long)d;
76 | }
77 |
78 | void min_caml_print_float(double d) {
79 | printf("%lf", d);
80 | }
81 |
82 | void min_caml_print_byte(long n) {
83 | putchar(n);
84 | }
85 |
86 | long min_caml_read_int() {
87 | long l;
88 | // fscanf(fp, "%ld", &l);
89 | scanf("%ld", &l);
90 | return l;
91 | }
92 |
93 | double min_caml_read_float() {
94 | double d;
95 | // fscanf(fp, "%lf", &d);
96 | scanf("%lf", &d);
97 | return d;
98 | }
99 |
100 | // atan
101 | double min_caml_atan(double x) {
102 | return atan(x);
103 | }
104 |
105 | // cos
106 | double min_caml_cos(double x) {
107 | return cos(x);
108 | }
109 |
110 | // floor
111 | double min_caml_floor(double x) {
112 | return floor(x);
113 | }
114 |
115 | // sin
116 | double min_caml_sin(double x) {
117 | return sin(x);
118 | }
119 |
120 | // abs_float
121 | double min_caml_abs_float(double x) {
122 | return fabs(x);
123 | }
124 |
125 | // float_of_int
126 | double min_caml_float_of_int(long n) {
127 | return (double)n;
128 | }
129 |
130 | // int_of_float
131 | long min_caml_int_of_float(double d) {
132 | return (long)d;
133 | }
134 |
135 | // sqrt
136 | double min_caml_sqrt(double d) {
137 | return sqrt(d);
138 | }
139 |
--------------------------------------------------------------------------------
/src/x64/libmincaml.S:
--------------------------------------------------------------------------------
1 | #if defined(__CYGWIN__) || defined(__MACH__)
2 | #define U(x) _##x
3 | #else
4 | #define U(x) x
5 | #endif
6 | #if defined(__MACH__)
7 | #define ALIGNSTACK0 andl $0xfffffff0, %esp
8 | #define ALIGNSTACK1 andl $0xfffffff0, %esp; pushl %eax; pushl %eax; pushl %eax
9 | #define ALIGNSTACK2 andl $0xfffffff0, %esp; pushl %eax; pushl %eax
10 | #define ALIGNSTACK3 andl $0xfffffff0, %esp; pushl %eax
11 | #else
12 | #define ALIGNSTACK0
13 | #define ALIGNSTACK1
14 | #define ALIGNSTACK2
15 | #define ALIGNSTACK3
16 | #endif
17 | .text
18 | .globl min_caml_print_newline
19 | min_caml_print_newline:
20 | pushl %ebp
21 | movl %esp, %ebp
22 | ALIGNSTACK1
23 | pushl $10
24 | call U(putchar)
25 | movl %ebp, %esp
26 | popl %ebp
27 | ret
28 | .globl min_caml_print_int
29 | min_caml_print_int:
30 | pushl %ebp
31 | movl %esp, %ebp
32 | ALIGNSTACK2
33 | pushl %eax
34 | pushl $format_int
35 | call U(printf)
36 | movl %ebp, %esp
37 | popl %ebp
38 | ret
39 | .globl min_caml_print_byte
40 | min_caml_print_byte:
41 | pushl %ebp
42 | movl %esp, %ebp
43 | ALIGNSTACK1
44 | pushl %eax
45 | call U(putchar)
46 | movl %ebp, %esp
47 | popl %ebp
48 | ret
49 | .globl min_caml_prerr_int
50 | min_caml_prerr_int:
51 | pushl %ebp
52 | movl %esp, %ebp
53 | ALIGNSTACK3
54 | pushl %eax
55 | pushl $format_int
56 | pushl U(min_caml_stderr)
57 | call U(fprintf)
58 | movl %ebp, %esp
59 | popl %ebp
60 | ret
61 | .globl min_caml_prerr_byte
62 | min_caml_prerr_byte:
63 | pushl %ebp
64 | movl %esp, %ebp
65 | ALIGNSTACK2
66 | pushl U(min_caml_stderr)
67 | pushl %eax
68 | call U(fputc)
69 | movl %ebp, %esp
70 | popl %ebp
71 | ret
72 | .globl min_caml_prerr_float
73 | min_caml_prerr_float:
74 | pushl %ebp
75 | movl %esp, %ebp
76 | ALIGNSTACK0
77 | subl $8, %esp
78 | movsd %xmm0, (%esp)
79 | pushl $format_float
80 | pushl U(min_caml_stderr)
81 | call U(fprintf)
82 | movl %ebp, %esp
83 | popl %ebp
84 | ret
85 | .globl min_caml_read_int
86 | min_caml_read_int:
87 | pushl %ebp
88 | movl %esp, %ebp
89 | ALIGNSTACK3
90 | subl $4, %esp
91 | leal -4(%ebp), %eax
92 | pushl %eax
93 | pushl $format_int
94 | call U(scanf)
95 | movl -4(%ebp), %eax
96 | movl %ebp, %esp
97 | popl %ebp
98 | ret
99 | .globl min_caml_read_float
100 | min_caml_read_float:
101 | pushl %ebp
102 | movl %esp, %ebp
103 | ALIGNSTACK0
104 | subl $8, %esp
105 | leal -8(%ebp), %eax
106 | pushl %eax
107 | pushl $format_float
108 | call U(scanf)
109 | movsd -8(%ebp), %xmm0
110 | movl %ebp, %esp
111 | popl %ebp
112 | ret
113 | .globl min_caml_create_array
114 | min_caml_create_array:
115 | pushl %ebp
116 | movl %esp, %ebp
117 | pushl %ecx
118 | pushl %edx
119 | movl %eax, %ecx
120 | movl min_caml_hp, %eax
121 | movl %ecx, %edx
122 | shll $2, %edx
123 | addl %edx, min_caml_hp
124 | create_array_loop:
125 | cmpl $0, %ecx
126 | jne create_array_cont
127 | create_array_exit:
128 | popl %edx
129 | popl %ecx
130 | movl %ebp, %esp
131 | popl %ebp
132 | ret
133 | create_array_cont:
134 | decl %ecx
135 | movl %ebx, (%eax,%ecx,4)
136 | jmp create_array_loop
137 | .globl min_caml_create_float_array
138 | min_caml_create_float_array:
139 | pushl %ebp
140 | movl %esp, %ebp
141 | pushl %ecx
142 | pushl %edx
143 | movl %eax, %ecx
144 | movl min_caml_hp, %eax
145 | movl %ecx, %edx
146 | shll $3, %edx
147 | addl %edx, min_caml_hp
148 | create_float_array_loop:
149 | cmpl $0, %ecx
150 | jne create_float_array_cont
151 | create_float_array_exit:
152 | popl %edx
153 | popl %ecx
154 | movl %ebp, %esp
155 | popl %ebp
156 | ret
157 | create_float_array_cont:
158 | decl %ecx
159 | movsd %xmm0, (%eax,%ecx,8)
160 | jmp create_float_array_loop
161 | .globl min_caml_abs_float
162 | min_caml_abs_float:
163 | pushl %ebp
164 | movl %esp, %ebp
165 | ALIGNSTACK2
166 | subl $8, %esp
167 | movsd %xmm0, (%esp)
168 | call U(fabs)
169 | fstpl (%esp)
170 | movsd (%esp), %xmm0
171 | movl %ebp, %esp
172 | popl %ebp
173 | ret
174 | .globl min_caml_sqrt
175 | min_caml_sqrt:
176 | sqrtsd %xmm0, %xmm0
177 | ret
178 | .globl min_caml_floor
179 | min_caml_floor:
180 | pushl %ebp
181 | movl %esp, %ebp
182 | ALIGNSTACK2
183 | subl $8, %esp
184 | movsd %xmm0, (%esp)
185 | call U(floor)
186 | fstpl (%esp)
187 | movsd (%esp), %xmm0
188 | movl %ebp, %esp
189 | popl %ebp
190 | ret
191 | .globl min_caml_int_of_float
192 | min_caml_int_of_float:
193 | .globl min_caml_truncate
194 | min_caml_truncate:
195 | cvttsd2si %xmm0, %eax
196 | ret
197 | .globl min_caml_float_of_int
198 | min_caml_float_of_int:
199 | cvtsi2sd %eax, %xmm0
200 | ret
201 | .globl min_caml_cos
202 | min_caml_cos:
203 | pushl %ebp
204 | movl %esp, %ebp
205 | ALIGNSTACK2
206 | subl $8, %esp
207 | movsd %xmm0, (%esp)
208 | call U(cos)
209 | fstpl (%esp)
210 | movsd (%esp), %xmm0
211 | movl %ebp, %esp
212 | popl %ebp
213 | ret
214 | .globl min_caml_sin
215 | min_caml_sin:
216 | pushl %ebp
217 | movl %esp, %ebp
218 | ALIGNSTACK2
219 | subl $8, %esp
220 | movsd %xmm0, (%esp)
221 | call U(sin)
222 | fstpl (%esp)
223 | movsd (%esp), %xmm0
224 | movl %ebp, %esp
225 | popl %ebp
226 | ret
227 | .globl min_caml_atan
228 | min_caml_atan:
229 | pushl %ebp
230 | movl %esp, %ebp
231 | ALIGNSTACK2
232 | subl $8, %esp
233 | movsd %xmm0, (%esp)
234 | call U(atan)
235 | fstpl (%esp)
236 | movsd (%esp), %xmm0
237 | movl %ebp, %esp
238 | popl %ebp
239 | ret
240 | .globl min_caml_print_debug
241 | min_caml_print_debug:
242 | pushl %ebp
243 | movl %esp, %ebp
244 | ALIGNSTACK3
245 | pushl %ecx
246 | pushl %ebx
247 | pushl %eax
248 | call interp_debug
249 | movl %ebp, %esp
250 | popl %ebp
251 | ret
252 | .globl min_caml_rand_int
253 | min_caml_rand_int:
254 | pushl %ebp
255 | movl %esp, %ebp
256 | ALIGNSTACK1
257 | pushl %eax
258 | call rand_int
259 | movl %ebp, %esp
260 | popl %ebp
261 | ret
262 | .globl min_caml_modulo
263 | min_caml_modulo:
264 | pushl %ebp
265 | movl %esp, %ebp
266 | ALIGNSTACK2
267 | pushl %ebx
268 | pushl %eax
269 | call modulo
270 | movl %ebp, %esp
271 | popl %ebp
272 | ret
273 | .globl min_caml_print_string
274 | min_caml_print_string:
275 | ret
276 | .globl min_caml_read_string
277 | min_caml_read_string:
278 | ret
279 | .globl min_caml_divide
280 | min_caml_divide:
281 | pushl %ebp
282 | movl %esp, %ebp
283 | ALIGNSTACK2
284 | pushl %ebx
285 | pushl %eax
286 | call divide
287 | movl %ebp, %esp
288 | popl %ebp
289 | ret
290 | .data
291 | format_int:
292 | .asciz "%d"
293 | format_float:
294 | .asciz "%lf"
295 | .balign 8
296 | float_0:
297 | .long 0x0
298 | .long 0x0
299 | float_1:
300 | .long 0x0
301 | .long 0x3ff00000
302 | .balign 16
303 | .globl min_caml_fnegd
304 | min_caml_fnegd:
305 | .long 0
306 | .long 0x80000000
307 | .long 0
308 | .long 0
309 | .globl min_caml_hp
310 | min_caml_hp:
311 | .long 0x0
312 |
--------------------------------------------------------------------------------
/src/x64/libmincaml.c:
--------------------------------------------------------------------------------
1 | #include
2 | #include
3 | #include
4 | #include
5 | #include
6 |
7 | extern int get_current_micros(void) asm ("min_caml_get_current_micros");
8 | extern int modulo(int, int);
9 | extern int divide(int, int);
10 | extern int rand_int(int);
11 |
12 | int get_current_micros() {
13 | struct timeval current_time;
14 | gettimeofday(¤t_time, NULL);
15 | return current_time.tv_sec * (int)1e6 + current_time.tv_usec;
16 | }
17 |
18 | int modulo(int lhs, int rhs) { return lhs % rhs; }
19 |
20 | int divide(int lhs, int rhs) { return lhs / rhs; }
21 |
22 | int rand_int(int n) {
23 | srandom(get_current_micros());
24 | return random() % n + 1;
25 | }
26 |
--------------------------------------------------------------------------------
/src/x64/regAlloc.ml:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/groupoid/joe/4bbf1a33ef17e076df3bac47fe32e5604243b2d5/src/x64/regAlloc.ml
--------------------------------------------------------------------------------
/src/x64/regAlloc.mli:
--------------------------------------------------------------------------------
1 | open MinCaml
2 |
3 | val f : Asm.prog -> Asm.prog
4 |
--------------------------------------------------------------------------------
/src/x64/stub.c:
--------------------------------------------------------------------------------
1 | #include
2 | #include
3 |
4 | extern void min_caml_start(char *, char *);
5 |
6 | /* "stderr" is a macro and cannot be referred to in libmincaml.S, so
7 | this "min_caml_stderr" is used (in place of "__iob+32") for better
8 | portability (under SPARC emulators, for example). Thanks to Steven
9 | Shaw for reporting the problem and proposing this solution. */
10 | FILE *min_caml_stderr;
11 |
12 | int main() {
13 | char *hp, *sp;
14 |
15 | min_caml_stderr = stderr;
16 | sp = alloca(1000000); hp = malloc(4000000);
17 | if (hp == NULL || sp == NULL) {
18 | fprintf(stderr, "malloc or alloca failed\n");
19 | return 1;
20 | }
21 | // fprintf(stderr, "sp = %p, hp = %p\n", sp, hp);
22 | min_caml_start(sp, hp);
23 |
24 | return 0;
25 | }
26 |
--------------------------------------------------------------------------------
/src/x86/dune:
--------------------------------------------------------------------------------
1 | (library
2 | (name x86)
3 | (public_name joe.x86)
4 | (flags (-w -4-33-40-41))
5 | (libraries str MinCaml)
6 | (foreign_stubs (language c) (names libmincaml))
7 | (preprocess (pps ppx_deriving.show)))
8 |
--------------------------------------------------------------------------------
/src/x86/emit.ml:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/groupoid/joe/4bbf1a33ef17e076df3bac47fe32e5604243b2d5/src/x86/emit.ml
--------------------------------------------------------------------------------
/src/x86/emit.mli:
--------------------------------------------------------------------------------
1 | open MinCaml
2 |
3 | val f : out_channel -> Asm.prog -> unit
4 |
--------------------------------------------------------------------------------
/src/x86/libmincaml.S:
--------------------------------------------------------------------------------
1 | #if defined(__CYGWIN__) || defined(__MACH__)
2 | #define U(x) _##x
3 | #else
4 | #define U(x) x
5 | #endif
6 | #if defined(__MACH__)
7 | #define ALIGNSTACK0 andl $0xfffffff0, %esp
8 | #define ALIGNSTACK1 andl $0xfffffff0, %esp; pushl %eax; pushl %eax; pushl %eax
9 | #define ALIGNSTACK2 andl $0xfffffff0, %esp; pushl %eax; pushl %eax
10 | #define ALIGNSTACK3 andl $0xfffffff0, %esp; pushl %eax
11 | #else
12 | #define ALIGNSTACK0
13 | #define ALIGNSTACK1
14 | #define ALIGNSTACK2
15 | #define ALIGNSTACK3
16 | #endif
17 | .text
18 | .globl min_caml_print_newline
19 | min_caml_print_newline:
20 | pushl %ebp
21 | movl %esp, %ebp
22 | ALIGNSTACK1
23 | pushl $10
24 | call U(putchar)
25 | movl %ebp, %esp
26 | popl %ebp
27 | ret
28 | .globl min_caml_print_int
29 | min_caml_print_int:
30 | pushl %ebp
31 | movl %esp, %ebp
32 | ALIGNSTACK2
33 | pushl %eax
34 | pushl $format_int
35 | call U(printf)
36 | movl %ebp, %esp
37 | popl %ebp
38 | ret
39 | .globl min_caml_print_byte
40 | min_caml_print_byte:
41 | pushl %ebp
42 | movl %esp, %ebp
43 | ALIGNSTACK1
44 | pushl %eax
45 | call U(putchar)
46 | movl %ebp, %esp
47 | popl %ebp
48 | ret
49 | .globl min_caml_prerr_int
50 | min_caml_prerr_int:
51 | pushl %ebp
52 | movl %esp, %ebp
53 | ALIGNSTACK3
54 | pushl %eax
55 | pushl $format_int
56 | pushl U(min_caml_stderr)
57 | call U(fprintf)
58 | movl %ebp, %esp
59 | popl %ebp
60 | ret
61 | .globl min_caml_prerr_byte
62 | min_caml_prerr_byte:
63 | pushl %ebp
64 | movl %esp, %ebp
65 | ALIGNSTACK2
66 | pushl U(min_caml_stderr)
67 | pushl %eax
68 | call U(fputc)
69 | movl %ebp, %esp
70 | popl %ebp
71 | ret
72 | .globl min_caml_prerr_float
73 | min_caml_prerr_float:
74 | pushl %ebp
75 | movl %esp, %ebp
76 | ALIGNSTACK0
77 | subl $8, %esp
78 | movsd %xmm0, (%esp)
79 | pushl $format_float
80 | pushl U(min_caml_stderr)
81 | call U(fprintf)
82 | movl %ebp, %esp
83 | popl %ebp
84 | ret
85 | .globl min_caml_read_int
86 | min_caml_read_int:
87 | pushl %ebp
88 | movl %esp, %ebp
89 | ALIGNSTACK3
90 | subl $4, %esp
91 | leal -4(%ebp), %eax
92 | pushl %eax
93 | pushl $format_int
94 | call U(scanf)
95 | movl -4(%ebp), %eax
96 | movl %ebp, %esp
97 | popl %ebp
98 | ret
99 | .globl min_caml_read_float
100 | min_caml_read_float:
101 | pushl %ebp
102 | movl %esp, %ebp
103 | ALIGNSTACK0
104 | subl $8, %esp
105 | leal -8(%ebp), %eax
106 | pushl %eax
107 | pushl $format_float
108 | call U(scanf)
109 | movsd -8(%ebp), %xmm0
110 | movl %ebp, %esp
111 | popl %ebp
112 | ret
113 | .globl min_caml_create_array
114 | min_caml_create_array:
115 | pushl %ebp
116 | movl %esp, %ebp
117 | pushl %ecx
118 | pushl %edx
119 | movl %eax, %ecx
120 | movl min_caml_hp, %eax
121 | movl %ecx, %edx
122 | shll $2, %edx
123 | addl %edx, min_caml_hp
124 | create_array_loop:
125 | cmpl $0, %ecx
126 | jne create_array_cont
127 | create_array_exit:
128 | popl %edx
129 | popl %ecx
130 | movl %ebp, %esp
131 | popl %ebp
132 | ret
133 | create_array_cont:
134 | decl %ecx
135 | movl %ebx, (%eax,%ecx,4)
136 | jmp create_array_loop
137 | .globl min_caml_create_float_array
138 | min_caml_create_float_array:
139 | pushl %ebp
140 | movl %esp, %ebp
141 | pushl %ecx
142 | pushl %edx
143 | movl %eax, %ecx
144 | movl min_caml_hp, %eax
145 | movl %ecx, %edx
146 | shll $3, %edx
147 | addl %edx, min_caml_hp
148 | create_float_array_loop:
149 | cmpl $0, %ecx
150 | jne create_float_array_cont
151 | create_float_array_exit:
152 | popl %edx
153 | popl %ecx
154 | movl %ebp, %esp
155 | popl %ebp
156 | ret
157 | create_float_array_cont:
158 | decl %ecx
159 | movsd %xmm0, (%eax,%ecx,8)
160 | jmp create_float_array_loop
161 | .globl min_caml_abs_float
162 | min_caml_abs_float:
163 | pushl %ebp
164 | movl %esp, %ebp
165 | ALIGNSTACK2
166 | subl $8, %esp
167 | movsd %xmm0, (%esp)
168 | call U(fabs)
169 | fstpl (%esp)
170 | movsd (%esp), %xmm0
171 | movl %ebp, %esp
172 | popl %ebp
173 | ret
174 | .globl min_caml_sqrt
175 | min_caml_sqrt:
176 | sqrtsd %xmm0, %xmm0
177 | ret
178 | .globl min_caml_floor
179 | min_caml_floor:
180 | pushl %ebp
181 | movl %esp, %ebp
182 | ALIGNSTACK2
183 | subl $8, %esp
184 | movsd %xmm0, (%esp)
185 | call U(floor)
186 | fstpl (%esp)
187 | movsd (%esp), %xmm0
188 | movl %ebp, %esp
189 | popl %ebp
190 | ret
191 | .globl min_caml_int_of_float
192 | min_caml_int_of_float:
193 | .globl min_caml_truncate
194 | min_caml_truncate:
195 | cvttsd2si %xmm0, %eax
196 | ret
197 | .globl min_caml_float_of_int
198 | min_caml_float_of_int:
199 | cvtsi2sd %eax, %xmm0
200 | ret
201 | .globl min_caml_cos
202 | min_caml_cos:
203 | pushl %ebp
204 | movl %esp, %ebp
205 | ALIGNSTACK2
206 | subl $8, %esp
207 | movsd %xmm0, (%esp)
208 | call U(cos)
209 | fstpl (%esp)
210 | movsd (%esp), %xmm0
211 | movl %ebp, %esp
212 | popl %ebp
213 | ret
214 | .globl min_caml_sin
215 | min_caml_sin:
216 | pushl %ebp
217 | movl %esp, %ebp
218 | ALIGNSTACK2
219 | subl $8, %esp
220 | movsd %xmm0, (%esp)
221 | call U(sin)
222 | fstpl (%esp)
223 | movsd (%esp), %xmm0
224 | movl %ebp, %esp
225 | popl %ebp
226 | ret
227 | .globl min_caml_atan
228 | min_caml_atan:
229 | pushl %ebp
230 | movl %esp, %ebp
231 | ALIGNSTACK2
232 | subl $8, %esp
233 | movsd %xmm0, (%esp)
234 | call U(atan)
235 | fstpl (%esp)
236 | movsd (%esp), %xmm0
237 | movl %ebp, %esp
238 | popl %ebp
239 | ret
240 | .globl min_caml_print_debug
241 | min_caml_print_debug:
242 | pushl %ebp
243 | movl %esp, %ebp
244 | ALIGNSTACK3
245 | pushl %ecx
246 | pushl %ebx
247 | pushl %eax
248 | call interp_debug
249 | movl %ebp, %esp
250 | popl %ebp
251 | ret
252 | .globl min_caml_rand_int
253 | min_caml_rand_int:
254 | pushl %ebp
255 | movl %esp, %ebp
256 | ALIGNSTACK1
257 | pushl %eax
258 | call rand_int
259 | movl %ebp, %esp
260 | popl %ebp
261 | ret
262 | .globl min_caml_modulo
263 | min_caml_modulo:
264 | pushl %ebp
265 | movl %esp, %ebp
266 | ALIGNSTACK2
267 | pushl %ebx
268 | pushl %eax
269 | call modulo
270 | movl %ebp, %esp
271 | popl %ebp
272 | ret
273 | .globl min_caml_divide
274 | min_caml_divide:
275 | pushl %ebp
276 | movl %esp, %ebp
277 | ALIGNSTACK2
278 | pushl %ebx
279 | pushl %eax
280 | call divide
281 | movl %ebp, %esp
282 | popl %ebp
283 | ret
284 | .data
285 | format_int:
286 | .asciz "%d"
287 | format_float:
288 | .asciz "%lf"
289 | .balign 8
290 | float_0:
291 | .long 0x0
292 | .long 0x0
293 | float_1:
294 | .long 0x0
295 | .long 0x3ff00000
296 | .balign 16
297 | .globl min_caml_fnegd
298 | min_caml_fnegd:
299 | .long 0
300 | .long 0x80000000
301 | .long 0
302 | .long 0
303 | .globl min_caml_hp
304 | min_caml_hp:
305 | .long 0x0
306 |
--------------------------------------------------------------------------------
/src/x86/libmincaml.c:
--------------------------------------------------------------------------------
1 | #include
2 | #include
3 | #include
4 | #include
5 | #include
6 |
7 | extern int get_current_micros(void) asm ("min_caml_get_current_micros");
8 | extern int modulo(int, int);
9 | extern int divide(int, int);
10 | extern int rand_int(int);
11 |
12 | int get_current_micros() {
13 | struct timeval current_time;
14 | gettimeofday(¤t_time, NULL);
15 | return current_time.tv_sec * (int)1e6 + current_time.tv_usec;
16 | }
17 |
18 | int modulo(int lhs, int rhs) { return lhs % rhs; }
19 |
20 | int divide(int lhs, int rhs) { return lhs / rhs; }
21 |
22 | int rand_int(int n) {
23 | srandom(get_current_micros());
24 | return random() % n + 1;
25 | }
26 |
--------------------------------------------------------------------------------
/styles/_aside.scss:
--------------------------------------------------------------------------------
1 | aside {
2 | max-width: 650px;
3 | margin: auto;
4 | padding: 8px;
5 | font-size: 20px;
6 | text-align: right;
7 | time, div {
8 | margin-bottom: 20px;
9 | display: block;
10 | }
11 | }
--------------------------------------------------------------------------------
/styles/_canvas.scss:
--------------------------------------------------------------------------------
1 | canvas {
2 | max-width: 100%;
3 | position: absolute;
4 | z-index: -10;
5 | }
--------------------------------------------------------------------------------
/styles/_code.scss:
--------------------------------------------------------------------------------
1 | code {
2 | display: inline-block;
3 | overflow-x: auto;
4 | max-width: 100%;
5 | padding: 12px;
6 | margin: 8px 0;
7 | white-space: pre;
8 | text-align: left;
9 | border-radius: 4px;
10 | font-size: 14px;
11 | color: #00259c;
12 | background: white;
13 | box-shadow: 0 1px 4px #f1f0f0, inset 0 0 0 1px #e7e6e5;
14 | @media (min-width: 768px) {
15 | font-size: 17px;
16 | }
17 | }
18 |
19 | pre {
20 | white-space: normal;
21 | max-width: 100%;
22 | width: 650px;
23 | padding: 12px;
24 | margin: 8px auto;
25 | text-align: left;
26 | border-radius: 4px;
27 | font-size: 14px;
28 | color: #00259c;
29 | background: white;
30 | box-shadow: 0 1px 4px #f1f0f0, inset 0 0 0 1px #e7e6e5;
31 | @media (min-width: 768px) {
32 | font-size: 17px;
33 | }
34 | }
35 |
36 | .h__name {
37 | color: #00259c;
38 | font-weight: bold;
39 | }
40 |
41 | .h__keyword {
42 | color: #ca30d4;
43 | }
44 |
45 | .h__symbol {
46 | color: #9f9fa3;
47 | }
--------------------------------------------------------------------------------
/styles/_exe.scss:
--------------------------------------------------------------------------------
1 | .exe {
2 |
3 | figure {
4 | max-width: inherit;
5 | }
6 |
7 | h1 {
8 | color: #7D8A96;
9 | font-size: 32px;
10 | text-transform: uppercase;
11 | border-bottom: 1px solid rgba(0, 0 , 0,0.3);
12 | display: inline-block;
13 | margin: 42px 0 10px;
14 | @media(min-width: 768px) {
15 | font-size: 40px;
16 | }
17 | }
18 |
19 | h1 + h2 {
20 | margin-top: 0px;
21 | }
22 | }
23 |
24 | .macro {
25 | margin: 0 auto;
26 | display: flex;
27 | justify-content: space-around;
28 | max-width: 600px;
29 | flex-wrap: wrap;
30 | width: 100%;
31 | &__col {
32 | h3 {
33 | padding: 0;
34 | width: initial;
35 | }
36 | padding-left: 24px;
37 | line-height: 1.5;
38 | font-size: 14px;
39 | @media(min-width: 768px) {
40 | font-size: 22px;
41 | }
42 | }
43 | }
44 |
45 | .langf {
46 | @media(min-width: 920px) {
47 | display: flex;
48 | flex-direction: row;
49 | justify-content: center;
50 | }
51 |
52 | ol {
53 | display: inline-block;
54 | max-width: 650px;
55 | margin: auto;
56 | font-size: 20px;
57 | padding-left: 36px;
58 | }
59 |
60 | &__col {
61 | @media(min-width: 920px) {
62 | .langf-col:last-child {
63 | white-space: pre;
64 | margin-left: 20px;
65 | }
66 |
67 | }
68 | }
69 | }
--------------------------------------------------------------------------------
/styles/_footer.scss:
--------------------------------------------------------------------------------
1 | .footer {
2 | width: 100%;
3 | padding: 15px;
4 | background: #7F8C8D;
5 | color: white;
6 | text-align: center;
7 |
8 | &__logo {
9 | width: 50px;
10 | margin: 20px;
11 | }
12 |
13 | &__copy {
14 | font-size: 16px;
15 | white-space: pre;
16 | }
17 | @media(min-width: 768px) {
18 | &__copy {
19 | font-size: 24px;
20 | }
21 | }
22 | }
23 |
--------------------------------------------------------------------------------
/styles/_header.scss:
--------------------------------------------------------------------------------
1 | .header {
2 | background: black;
3 | color: white;
4 | position: relative;
5 | min-height: 450px;
6 | padding: 16px 8px;
7 | display: flex;
8 | text-align: center;
9 | flex-direction: column;
10 | justify-content: center;
11 | align-items: center;
12 | width: 100%;
13 | z-index: 5;
14 |
15 | &__logo {
16 | width: 130px;
17 | position: relative;
18 | }
19 |
20 | &__titles {
21 | position: relative;
22 | max-width: 800px;
23 | margin: 20px;
24 | text-shadow: 1px 1px 7px #56CCF2;
25 | }
26 |
27 | &__title {
28 | font-size: 48px;
29 | line-height: 1.1;
30 | }
31 |
32 | &__subtitle {
33 | font-size: 22px;
34 | }
35 |
36 | @media(min-width: 768px) {
37 | flex-direction: row;
38 |
39 | &__logo {
40 | width: 160px;
41 | margin-right: 10px;
42 | }
43 |
44 | &__title {
45 | font-size: 60px;
46 | }
47 |
48 | &__subtitle {
49 | font-size: 30px;
50 | }
51 | }
52 |
53 | }
54 |
--------------------------------------------------------------------------------
/styles/_index.scss:
--------------------------------------------------------------------------------
1 | .index {
2 | max-width: 900px;
3 | margin: auto;
4 | padding: 20px 0;
5 | display: flex;
6 | flex-wrap: wrap;
7 | justify-content: center;
8 |
9 | &__col {
10 | white-space: nowrap;
11 | padding: 15px 25px;
12 | margin: 15px;
13 | background: #fefefe;
14 | box-shadow: 0 1px 4px rgba(0, 0, 100, 0.1), inset 0 0 0 1px rgba(0, 0, 0, 0.1);
15 | transition: box-shadow 0.5s cubic-bezier(0.23, 1, 0.32, 1);
16 |
17 | &:hover {
18 | box-shadow: 0 8px 40px rgba(0, 0, 100, 0.15), inset 0 0 0 1px rgba(0, 0, 0, 0.1);
19 | }
20 | }
21 |
22 | a {
23 | line-height: 1.5;
24 | color: #888;
25 | font-size: 24px;
26 | }
27 |
28 | a[href^="#"] {
29 | color: #BBBBBB;
30 | }
31 |
32 | a:hover {
33 | color: #3A98C8;
34 | }
35 |
36 | a[href^="#"]:hover {
37 | color: #BBBBBB;
38 | }
39 |
40 | h2 {
41 | font-size: 24px;
42 | text-align: left;
43 | color: #707070;
44 | margin: 0 0 10px;
45 | text-transform: uppercase;
46 | }
47 | }
48 |
--------------------------------------------------------------------------------
/styles/_intro.scss:
--------------------------------------------------------------------------------
1 | .intro {
2 | width: 650px;
3 | max-width: 100%;
4 | margin: auto;
5 | }
--------------------------------------------------------------------------------
/styles/_list.scss:
--------------------------------------------------------------------------------
1 | .list {
2 | h1 {
3 | color: #7D8A96;
4 | font-size: 32px;
5 | text-transform: uppercase;
6 | border-bottom: 1px solid rgba(0, 0 , 0,0.3);
7 | display: inline-block;
8 | margin: 42px 8px 10px;
9 | @media(min-width: 768px) {
10 | font-size: 40px;
11 | }
12 | }
13 | }
--------------------------------------------------------------------------------
/styles/_om.scss:
--------------------------------------------------------------------------------
1 | .om {
2 |
3 | figure {
4 | max-width: inherit;
5 | }
6 |
7 | section {
8 | h1 {
9 | margin-top: 50px;
10 | }
11 | }
12 |
13 | h1 {
14 | color: #7D8A96;
15 | font-size: 32px;
16 | text-transform: uppercase;
17 | border-bottom: 1px solid rgba(0, 0 , 0,0.3);
18 | display: inline-block;
19 | margin-bottom: 32px;
20 | @media(min-width: 768px) {
21 | font-size: 40px;
22 | }
23 | }
24 |
25 | h1 + h2 {
26 | margin-top: 20px;
27 | }
28 |
29 | h3 {
30 | max-width: 100%;
31 | margin: auto;
32 | width: 600px;
33 | padding: 16px 8px 0;
34 | }
35 | }
--------------------------------------------------------------------------------
/styles/_resources.scss:
--------------------------------------------------------------------------------
1 | .resources {
2 |
3 | max-width: 650px;
4 | margin: 32px auto 0;
5 | text-align: left;
6 | padding: 8px;
7 |
8 | &__title {
9 | display: inline-block;
10 | margin-bottom: 10px;
11 | color: #7D8A96;
12 | font-size: 32px;
13 | text-transform: uppercase;
14 | border-bottom: 1px solid rgba(0, 0 , 0,0.3);
15 | @media(min-width: 768px) {
16 | font-size: 40px;
17 | }
18 | }
19 | &__list {
20 | padding-left: 32px;
21 | line-height: 1.5;
22 | font-size: 18px;
23 | @media(min-width: 768px) {
24 | font-size: 22px;
25 | }
26 | }
27 | }
--------------------------------------------------------------------------------
/styles/_semantics.scss:
--------------------------------------------------------------------------------
1 | .semantics {
2 | text-align: center;
3 |
4 | figure {
5 | display: inline-block;
6 | max-width: min-content;
7 | font-size: 13px;
8 | @media(min-width:800px) {
9 | font-size: 16px;
10 | }
11 | }
12 |
13 | h1 {
14 | color: #7D8A96;
15 | font-size: 32px;
16 | text-transform: uppercase;
17 | border-bottom: 1px solid rgba(0, 0 , 0,0.3);
18 | display: inline-block;
19 | margin-bottom: 8px;
20 | }
21 |
22 | section {
23 | margin-top: 40px;
24 | }
25 | }
26 |
--------------------------------------------------------------------------------
/styles/_stack.scss:
--------------------------------------------------------------------------------
1 | .stack {
2 | margin: auto;
3 | max-width: 100%;
4 | border-spacing: 10px;
5 | color: #282828;
6 | font-size: 20px;
7 |
8 | td {
9 | background-color:#fff9a6;
10 | // width: 80px;
11 | padding: 4px;
12 | outline: 1px solid rgba(0, 0, 0, .3);
13 | }
14 |
15 | th {
16 | padding: 4px;
17 | text-align: left;
18 | font-weight: normal;
19 | }
20 |
21 | .empty {
22 | background-color: inherit;
23 | outline: inherit;
24 |
25 | }
26 |
27 | }
28 |
29 |
30 |
31 |
32 | @media(max-width: 600px) {
33 | .stack {
34 | font-size: 16px;
35 | display: inline-block;
36 | border-spacing: 0;
37 | tbody {
38 | display: block;
39 | }
40 |
41 | tr {
42 | display: block;
43 | text-align: left;
44 | vertical-align: top;
45 | position: relative;
46 | }
47 |
48 | td {
49 | margin: 30px 0 10px;
50 | text-align: center;
51 | padding: 4px;
52 | display: inline-block;
53 | width: 90px;
54 | }
55 |
56 | td[colspan="4"] {
57 | width: 360px;
58 | }
59 |
60 | td[colspan="2"] {
61 | width: 180px;
62 | }
63 |
64 | th {
65 | position: absolute;
66 | top: 0;
67 | width: 100%;
68 | }
69 | }
70 | }
71 |
72 |
73 |
74 | @media(max-width: 320px) {
75 | .stack {
76 | font-size: 12px;
77 | td {
78 | margin: 20px 0 5px;
79 | width: 80px;
80 | }
81 |
82 | td[colspan="4"] {
83 | width: 320px;
84 | }
85 |
86 | td[colspan="2"] {
87 | width: 160px;
88 | }
89 | }
90 | }
91 |
92 |
93 |
94 |
--------------------------------------------------------------------------------
/styles/_status.scss:
--------------------------------------------------------------------------------
1 | .status {
2 | text-align: left;
3 | display: inline-block;
4 | padding-left: 32px;
5 |
6 | ol {
7 | line-height: 1.5;
8 | font-size: 18px;
9 | @media(min-width: 768px) {
10 | font-size: 22px;
11 | }
12 | }
13 |
14 | }
--------------------------------------------------------------------------------
/styles/_types.scss:
--------------------------------------------------------------------------------
1 | .types {
2 | display: inline-block;
3 | text-align: left;
4 | max-width: 100%;
5 | padding: 0 8px;
6 | h1 {
7 | color: #7D8A96;
8 | font-size: 32px;
9 | text-transform: uppercase;
10 | border-bottom: 1px solid rgba(0, 0 , 0,0.3);
11 | display: inline-block;
12 | margin: 42px 0 10px;
13 | @media(min-width: 768px) {
14 | font-size: 40px;
15 | }
16 | }
17 |
18 | section {
19 | max-width: 100%;
20 | }
21 |
22 | p {
23 | margin: 0;
24 | padding-left: 0;
25 | }
26 |
27 |
28 |
29 | h1 + h2 {
30 | margin-top: 0px;
31 | }
32 |
33 |
34 | .type {
35 | max-width: 660px;
36 | display: flex;
37 | flex-flow: row wrap;
38 | &__col {
39 | padding-left: 22px;
40 | flex: 1 0 15%;
41 | h3 {
42 | width: initial;
43 | padding: 0;
44 | margin: 0;
45 | }
46 | @media(min-width: 600px) {
47 | padding-right: 22px;
48 | flex: 1 0 15%;
49 | font-size: 20px;
50 | }
51 | }
52 | }
53 |
54 | .legend {
55 | margin: 20px auto 0;
56 | display: inline-block;
57 | padding: 10px 20px;
58 | font-size: 24px;
59 | background: #FDF6E3;
60 | border-radius: 4px;
61 | box-shadow: 0 4px 6px rgba(50,50,93,.11),
62 | 0 1px 3px rgba(0, 0, 0,.08);
63 | }
64 | }
--------------------------------------------------------------------------------
/styles/main.scss:
--------------------------------------------------------------------------------
1 | @font-face {
2 | font-family: 'local';
3 | src: url('https://groupoid.space/Geometria-Light.otf');
4 | font-weight: normal;
5 | font-style: normal;
6 | }
7 |
8 | .MathJax_Display {
9 | overflow-x: auto;
10 | overflow-y: hidden;
11 | }
12 |
13 | nav a {
14 | font-size: 18px;
15 | border: 2px solid #dedede;
16 | background-color: white;
17 | color: lightblue;
18 | text-decoration: none;
19 | margin: 5px 5px;
20 | padding: 7px 12px;
21 | min-width: 150px;
22 | text-align: center;
23 | }
24 |
25 | nav a:visited {
26 | color: lightblue;
27 | }
28 |
29 | nav a:hover {
30 | border-bottom: 2px solid #00b8cf;
31 | }
32 |
33 |
34 | nav {
35 | display: flex;
36 | background-color: #FBFBFB;
37 | flex-direction: row;
38 | justify-content: center;
39 | }
40 |
41 | nav a {
42 | font-size: 18px;
43 | min-width: initial;
44 | }
45 |
46 |
47 | * {
48 | margin: 0;
49 | padding: 0;
50 | box-sizing: border-box;
51 | }
52 |
53 | sub,
54 | sup {
55 | font-size: 80%;
56 | line-height: 0;
57 | position: relative;
58 | vertical-align: baseline;
59 | }
60 |
61 | sub {
62 | bottom: -0.25em;
63 | }
64 |
65 | sup {
66 | top: -0.5em;
67 | }
68 |
69 | html {
70 | height: 100%;
71 | }
72 |
73 | body {
74 | min-height: 100%;
75 | text-rendering: optimizeLegibility;
76 | -webkit-font-smoothing: antialiased;
77 | }
78 |
79 | h1, h2, h3, h4 {
80 | font-weight: normal;
81 | }
82 |
83 | ul {
84 | list-style-type: none;
85 | }
86 |
87 | ol,
88 | ul {
89 | text-align: left;
90 | line-height: 1.5;
91 | }
92 |
93 | img, figure {
94 | vertical-align: middle;
95 | }
96 |
97 | img { margin-left:20px; }
98 |
99 | .content {
100 | min-height: 100%;
101 | font-family: local;
102 | display: flex; // sticky footer
103 | flex-direction: column;
104 | position: relative;
105 | }
106 |
107 | .main {
108 | color: #586E75;
109 | background: #FBFBFB;
110 | padding: 50px 0px;
111 | text-align: center;
112 | box-shadow: 0 3px 10px rgba(0,0,0,0);
113 | // 0 -3px 10px rgba(0,0,0,0.3);
114 | z-index: 5;
115 | flex: 1 1 auto; // sticky footer
116 |
117 | }
118 |
119 | figure {
120 | min-width: 300px;
121 | overflow-x: auto;
122 | padding: 10px 2px;
123 | font-size: 18px;
124 | display: block;
125 | }
126 |
127 | figure::after {
128 | content: "\A";
129 | white-space: pre;
130 | }
131 |
132 | h2 {
133 | font-size: 24px;
134 | color: #268BD2;
135 | @media(min-width: 768px) {
136 | font-size: 32px;
137 | }
138 | margin: 34px 0 8px;
139 | }
140 |
141 | h3 {
142 | max-width: 100%;
143 | margin: 16px auto 0;
144 | // width: 650px;
145 | padding: 0 0 0 8px;
146 | text-transform: uppercase;
147 | text-align: left;
148 | font-size: 22px;
149 | }
150 |
151 | p {
152 | max-width: 100%;
153 | width: 650px;
154 | margin: auto;
155 | padding: 8px;
156 | text-align: left;
157 | font-size: 18px;
158 | line-height: 1.4;
159 | @media(min-width: 768px) {
160 | font-size: 22px;
161 | }
162 | }
163 |
164 | p:hover {
165 | background: white;
166 | }
167 |
168 | mark {
169 | background: #FDF6E3;
170 | padding: 0px 2px;
171 | border-radius: 2px;
172 | color: #586E75;
173 | }
174 |
175 | a {
176 | color: #3A98C8;
177 | text-decoration: none;
178 | &:visited {
179 | color: #3A98C8;
180 | }
181 |
182 | &:hover {
183 | color: #D33682;
184 | }
185 |
186 | &:active {
187 | color: #D33682;
188 | }
189 | }
190 |
191 |
192 | @import '_aside';
193 | @import '_header';
194 | @import '_footer';
195 | @import '_semantics';
196 | @import '_intro';
197 | @import '_status';
198 | @import '_resources';
199 | @import '_index';
200 | @import '_om';
201 | @import '_exe';
202 | @import '_types';
203 | @import '_list';
204 | @import '_code';
205 | @import '_canvas';
206 | @import '_stack';
207 |
208 |
--------------------------------------------------------------------------------
/styles/mathjax.js:
--------------------------------------------------------------------------------
1 | (function () {
2 | var newMathJax = 'https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.1/MathJax.js';
3 | var oldMathJax = 'cdn.mathjax.org/mathjax/latest/MathJax.js';
4 | var replaceScript = function (script, src) {
5 | var newScript = document.createElement('script');
6 | newScript.src = newMathJax + src.replace(/.*?(\?|$)/, '$1');
7 | newScript.onload = script.onload;
8 | newScript.onerror = script.onerror;
9 | script.onload = script.onerror = null;
10 | while (script.firstChild) newScript.appendChild(script.firstChild);
11 | if (script.id != null) newScript.id = script.id;
12 | script.parentNode.replaceChild(newScript, script);
13 | console.info('MathJax: 2.7.1.');
14 | }
15 |
16 | if (document.currentScript) {
17 | var script = document.currentScript;
18 | replaceScript(script, script.src);
19 | } else {
20 | var n = oldMathJax.length;
21 | var scripts = document.getElementsByTagName('script');
22 | for (var i = 0; i < scripts.length; i++) {
23 | var script = scripts[i];
24 | var src = (script.src || '').replace(/.*?:\/\//,'');
25 | if (src.substr(0, n) === oldMathJax) {
26 | replaceScript(script, src);
27 | break;
28 | }
29 | }
30 | }
31 | })();
32 |
--------------------------------------------------------------------------------
/vm.opam:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/groupoid/joe/4bbf1a33ef17e076df3bac47fe32e5604243b2d5/vm.opam
--------------------------------------------------------------------------------