Skip to content

Commit e7db611

Browse files
dvanhorndvanhorn
committed
Add generated Fraud code.
1 parent ea89403 commit e7db611

17 files changed

+713
-0
lines changed

‎langs/fraud/ast.rkt‎

Lines changed: 34 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,34 @@
1+
#lang racket
2+
(provide Lit Prim0 Prim1 Prim2 If Eof Begin
3+
Let Var)
4+
;;
5+
;; type Expr = (Lit Datum)
6+
;; | (Eof)
7+
;; | (Prim0 Op0)
8+
;; | (Prim1 Op1 Expr)
9+
;; | (Prim2 Op2 Expr Expr)
10+
;; | (If Expr Expr Expr)
11+
;; | (Let Id Expr Expr)
12+
;; | (Var Id)
13+
14+
;; type Id = Symbol
15+
;; type Datum = Integer
16+
;; | Boolean
17+
;; | Character
18+
;; type Op0 = 'read-byte | 'peek-byte | 'void
19+
;; type Op1 = 'add1 | 'sub1
20+
;; | 'zero?
21+
;; | 'char? | 'integer->char | 'char->integer
22+
;; | 'write-byte | 'eof-object?
23+
;; type Op2 = '+ | '- | '< | '=
24+
25+
(struct Eof () #:prefab)
26+
(struct Lit (d) #:prefab)
27+
(struct Prim0 (p) #:prefab)
28+
(struct Prim1 (p e) #:prefab)
29+
(struct Prim2 (p e1 e2) #:prefab)
30+
(struct If (e1 e2 e3) #:prefab)
31+
(struct Begin (e1 e2) #:prefab)
32+
(struct Let (x e1 e2) #:prefab)
33+
(struct Var (x) #:prefab)
34+

‎langs/fraud/build-runtime.rkt‎

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,13 @@
1+
#lang racket
2+
(provide runtime-path)
3+
4+
(require racket/runtime-path)
5+
(define-runtime-path here ".")
6+
7+
(system (string-append "make -C '"
8+
(path->string (normalize-path here))
9+
"' runtime.o"))
10+
11+
(define runtime-path
12+
(normalize-path (build-path here "runtime.o")))
13+

‎langs/fraud/compile-ops.rkt‎

Lines changed: 149 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,149 @@
1+
#lang racket
2+
(provide compile-op0 compile-op1 compile-op2 pad-stack)
3+
(require "ast.rkt")
4+
(require "types.rkt")
5+
(require a86/ast)
6+
7+
(define rax 'rax)(define rdi 'rdi) ; arg
8+
(define r8 'r8) ; scratch in op2
9+
(define r9 'r9) ; scratch
10+
11+
(define r15 'r15) ; stack pad (non-volatile)
12+
(define rsp 'rsp) ; stack
13+
14+
;; Op0 -> Asm
15+
(define (compile-op0 p)
16+
(match p
17+
['void (seq (Mov rax (value->bits (void))))]
18+
['read-byte (seq pad-stack (Call 'read_byte) unpad-stack)]
19+
['peek-byte (seq pad-stack (Call 'peek_byte) unpad-stack)]))
20+
21+
;; Op1 -> Asm
22+
(define (compile-op1 p)
23+
(match p
24+
['add1
25+
(seq (assert-integer rax)
26+
(Add rax (value->bits 1)))]
27+
['sub1
28+
(seq (assert-integer rax)
29+
(Sub rax (value->bits 1)))]
30+
['zero?
31+
(seq (assert-integer rax)
32+
(Cmp rax 0)
33+
if-equal)]
34+
['char?
35+
(seq (And rax mask-char)
36+
(Cmp rax type-char)
37+
if-equal)]
38+
['char->integer
39+
(seq (assert-char rax)
40+
(Sar rax char-shift)
41+
(Sal rax int-shift))]
42+
['integer->char
43+
(seq (assert-codepoint)
44+
(Sar rax int-shift)
45+
(Sal rax char-shift)
46+
(Xor rax type-char))]
47+
['eof-object?
48+
(seq (Cmp rax (value->bits eof))
49+
if-equal)]
50+
['write-byte
51+
(seq assert-byte
52+
pad-stack
53+
(Mov rdi rax)
54+
(Call 'write_byte)
55+
unpad-stack)]))
56+
57+
58+
;; Op2 -> Asm
59+
(define (compile-op2 p)
60+
(match p
61+
['+
62+
(seq (Pop r8)
63+
(assert-integer r8)
64+
(assert-integer rax)
65+
(Add rax r8))]
66+
['-
67+
(seq (Pop r8)
68+
(assert-integer r8)
69+
(assert-integer rax)
70+
(Sub r8 rax)
71+
(Mov rax r8))]
72+
['<
73+
(seq (Pop r8)
74+
(assert-integer r8)
75+
(assert-integer rax)
76+
(Cmp r8 rax)
77+
if-lt)]
78+
['=
79+
(seq (Pop r8)
80+
(assert-integer r8)
81+
(assert-integer rax)
82+
(Cmp r8 rax)
83+
if-equal)]))
84+
85+
86+
;; -> Asm
87+
;; set rax to #t or #f if comparison flag is equal
88+
(define if-equal
89+
(seq (Mov rax (value->bits #f))
90+
(Mov r9 (value->bits #t))
91+
(Cmove rax r9)))
92+
93+
;; -> Asm
94+
;; set rax to #t or #f if comparison flag is less than
95+
(define if-lt
96+
(seq (Mov rax (value->bits #f))
97+
(Mov r9 (value->bits #t))
98+
(Cmovl rax r9)))
99+
100+
(define (assert-type mask type)
101+
(λ (arg)
102+
(seq (Mov r9 arg)
103+
(And r9 mask)
104+
(Cmp r9 type)
105+
(Jne 'err))))
106+
107+
(define (type-pred mask type)
108+
(seq (And rax mask)
109+
(Cmp rax type)
110+
if-equal))
111+
112+
(define assert-integer
113+
(assert-type mask-int type-int))
114+
(define assert-char
115+
(assert-type mask-char type-char))
116+
117+
(define (assert-codepoint)
118+
(let ((ok (gensym)))
119+
(seq (assert-integer rax)
120+
(Cmp rax (value->bits 0))
121+
(Jl 'err)
122+
(Cmp rax (value->bits 1114111))
123+
(Jg 'err)
124+
(Cmp rax (value->bits 55295))
125+
(Jl ok)
126+
(Cmp rax (value->bits 57344))
127+
(Jg ok)
128+
(Jmp 'err)
129+
(Label ok))))
130+
131+
(define assert-byte
132+
(seq (assert-integer rax)
133+
(Cmp rax (value->bits 0))
134+
(Jl 'err)
135+
(Cmp rax (value->bits 255))
136+
(Jg 'err)))
137+
138+
;; Asm
139+
;; Dynamically pad the stack to be aligned for a call
140+
(define pad-stack
141+
(seq (Mov r15 rsp)
142+
(And r15 #b1000)
143+
(Sub rsp r15)))
144+
145+
;; Asm
146+
;; Undo the stack alignment after a call
147+
(define unpad-stack
148+
(seq (Add rsp r15)))
149+

‎langs/fraud/compile-stdin.rkt‎

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,13 @@
1+
#lang racket
2+
(provide main)
3+
(require "parse.rkt")
4+
(require "compile.rkt")
5+
(require a86/printer)
6+
7+
;; -> Void
8+
;; Compile contents of stdin,
9+
;; emit asm code on stdout
10+
(define (main)
11+
(read-line) ; ignore #lang racket line
12+
(asm-display (compile (parse (read)))))
13+

‎langs/fraud/compile.rkt‎

Lines changed: 108 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,108 @@
1+
#lang racket
2+
(provide (all-defined-out))
3+
(require "ast.rkt")
4+
(require "compile-ops.rkt")
5+
(require "types.rkt")
6+
(require a86/ast)
7+
8+
(define rax 'rax)(define rsp 'rsp) ; stack
9+
(define r15 'r15) ; stack pad (non-volatile)
10+
11+
;; Expr -> Asm
12+
(define (compile e)
13+
(prog (Global 'entry)
14+
(Extern 'peek_byte)
15+
(Extern 'read_byte)
16+
(Extern 'write_byte)
17+
(Extern 'raise_error)
18+
(Label 'entry)
19+
(Push r15) ; save callee-saved register
20+
(compile-e e '())
21+
(Pop r15) ; restore callee-save register
22+
(Ret)
23+
;; Error handler
24+
(Label 'err)
25+
pad-stack
26+
(Call 'raise_error)))
27+
28+
;; type CEnv = (Listof [Maybe Id])
29+
30+
;; Expr -> Asm
31+
;; Expr CEnv -> Asm
32+
(define (compile-e e c)
33+
(match e
34+
[(Lit d) (compile-value d)]
35+
[(Eof) (compile-value eof)]
36+
[(Var x) (compile-variable x c)]
37+
[(Prim0 p) (compile-prim0 p)]
38+
[(Prim1 p e) (compile-prim1 p e c)]
39+
[(Prim2 p e1 e2) (compile-prim2 p e1 e2 c)]
40+
[(If e1 e2 e3)
41+
(compile-if e1 e2 e3 c)]
42+
[(Begin e1 e2)
43+
(compile-begin e1 e2 c)]
44+
[(Let x e1 e2)
45+
(compile-let x e1 e2 c)]))
46+
47+
;; Value -> Asm
48+
(define (compile-value v)
49+
(seq (Mov rax (value->bits v))))
50+
51+
;; Id CEnv -> Asm
52+
(define (compile-variable x c)
53+
(let ((i (lookup x c)))
54+
(seq (Mov rax (Offset rsp i)))))
55+
56+
;; Op0 -> Asm
57+
(define (compile-prim0 p)
58+
(compile-op0 p))
59+
60+
;; Op1 Expr -> Asm
61+
;; Op1 Expr CEnv -> Asm
62+
(define (compile-prim1 p e c)
63+
(seq (compile-e e c)
64+
(compile-op1 p)))
65+
66+
;; Op2 Expr Expr CEnv -> Asm
67+
(define (compile-prim2 p e1 e2 c)
68+
(seq (compile-e e1 c)
69+
(Push rax)
70+
(compile-e e2 (cons #f c))
71+
(compile-op2 p)))
72+
73+
;; Expr Expr Expr -> Asm
74+
;; Expr Expr Expr CEnv -> Asm
75+
(define (compile-if e1 e2 e3 c)
76+
(let ((l1 (gensym 'if))
77+
(l2 (gensym 'if)))
78+
(seq (compile-e e1 c)
79+
(Cmp rax (value->bits #f))
80+
(Je l1)
81+
(compile-e e2 c)
82+
(Jmp l2)
83+
(Label l1)
84+
(compile-e e3 c)
85+
(Label l2))))
86+
87+
;; Expr Expr -> Asm
88+
;; Expr Expr CEnv -> Asm
89+
(define (compile-begin e1 e2 c)
90+
(seq (compile-e e1 c)
91+
(compile-e e2 c)))
92+
93+
;; Id Expr Expr CEnv -> Asm
94+
(define (compile-let x e1 e2 c)
95+
(seq (compile-e e1 c)
96+
(Push rax)
97+
(compile-e e2 (cons x c))
98+
(Add rsp 8)))
99+
100+
;; Id CEnv -> Integer
101+
(define (lookup x cenv)
102+
(match cenv
103+
['() (error "undefined variable:" x)]
104+
[(cons y rest)
105+
(match (eq? x y)
106+
[#t 0]
107+
[#f (+ 8 (lookup x rest))])]))
108+

‎langs/fraud/interp-io.rkt‎

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,13 @@
1+
#lang racket
2+
(provide interp/io)
3+
(require "interp.rkt")
4+
5+
;; String Expr -> (Cons Value String)
6+
;; Interpret e with given string as input,
7+
;; return value and collected output as string
8+
(define (interp/io e input)
9+
(parameterize ((current-output-port (open-output-string))
10+
(current-input-port (open-input-string input)))
11+
(cons (interp e)
12+
(get-output-string (current-output-port)))))
13+

‎langs/fraud/interp-prim.rkt‎

Lines changed: 38 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,38 @@
1+
#lang racket
2+
(provide interp-prim0 interp-prim1 interp-prim2)
3+
4+
;; Op0 -> Value
5+
(define (interp-prim0 op)
6+
(match op
7+
['read-byte (read-byte)]
8+
['peek-byte (peek-byte)]
9+
['void (void)]))
10+
11+
;; Op1 Value -> Answer
12+
(define (interp-prim1 op v)
13+
(match (list op v)
14+
[(list 'add1 (? integer?)) (add1 v)]
15+
[(list 'sub1 (? integer?)) (sub1 v)]
16+
[(list 'zero? (? integer?)) (zero? v)]
17+
[(list 'char? v) (char? v)]
18+
[(list 'integer->char (? codepoint?)) (integer->char v)]
19+
[(list 'char->integer (? char?)) (char->integer v)]
20+
[(list 'write-byte (? byte?)) (write-byte v)]
21+
[(list 'eof-object? v) (eof-object? v)]
22+
[_ 'err]))
23+
24+
;; Op2 Value Value -> Answer
25+
(define (interp-prim2 op v1 v2)
26+
(match (list op v1 v2)
27+
[(list '+ (? integer?) (? integer?)) (+ v1 v2)]
28+
[(list '- (? integer?) (? integer?)) (- v1 v2)]
29+
[(list '< (? integer?) (? integer?)) (< v1 v2)]
30+
[(list '= (? integer?) (? integer?)) (= v1 v2)]
31+
[_ 'err]))
32+
33+
;; Any -> Boolean
34+
(define (codepoint? v)
35+
(and (integer? v)
36+
(or (<= 0 v 55295)
37+
(<= 57344 v 1114111))))
38+

‎langs/fraud/interp-stdin.rkt‎

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,12 @@
1+
#lang racket
2+
(provide main)
3+
(require "parse.rkt")
4+
(require "interp.rkt")
5+
6+
;; -> Void
7+
;; Parse and interpret contents of stdin,
8+
;; print result on stdout
9+
(define (main)
10+
(read-line) ; ignore #lang racket line
11+
(println (interp (parse (read)))))
12+

0 commit comments

Comments
 (0)