-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathdriver.rkt
140 lines (109 loc) · 4.01 KB
/
driver.rkt
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
#lang racket/base
(require (for-syntax racket/base))
(require
"tiger-parser.rkt"
"semantic-checks.rkt"
"type-checker.rkt"
"environment.rkt"
"fix-loops.rkt"
"fix-assignment.rkt"
"fix-units-anf.rkt"
"ir-anf-printable-ast.rkt"
"types.rkt"
"unique.rkt"
"optimization/inline-one-use.rkt"
"optimization/zero-cfa.rkt"
"optimization/inline-trivial.rkt"
"optimization/remove-empty-bind-rec.rkt"
"optimization/remove-unused-variable-bindings.rkt"
"optimization/known-function-optimization.rkt"
(prefix-in ir: "anf-typechecker.rkt")
(only-in "intermediate-ast.rkt" (type-of inter:type-of))
)
(require "anf-lifter.rkt" "code-gen.rkt")
(require (prefix-in source->inter: "source-intermediate-transform.rkt"))
(require (prefix-in inter->anf: "intermediate-anf-transform.rkt"))
(require racket/file racket/system racket/pretty)
(provide full-compile compile-llvm)
(define-syntax (with-temporary-file stx)
(syntax-case stx ()
((_ id body bodies ...)
#'(let ((id (make-temporary-file)))
(dynamic-wind
(let ((first #t)) (lambda () (if first (set! first #f) (error 'run-program "Re-entering protected region"))))
(lambda () body bodies ...)
(lambda ()
(when (file-exists? id)
(delete-file id))))))))
(define (check-semantics ast)
(let ((ast (rename-variables ast global-environment)))
(let ((ast (type-check ast global-type-environment)))
(unless (break-check ast)
(error 'check-semantics "Break with no enclosing loop"))
ast)))
(define (simplify ast)
(let ((inter
(fix-loops
(remove-assignment
(source->inter:transform
ast
source->inter:global-env
source->inter:global-type-env)))))
(let ((ir (inter->anf:transform inter (inter:type-of inter))))
;(eprintf "Checking CPS types~n")
;(pretty-write inter)
;(pretty-write (anf->printable ir))
(ir:type-check ir)
;(eprintf "CPS types Passed~n")
(let ((ir (remove-units ir)))
;(eprintf "Checking unit removed types~n")
;(pretty-write (anf->printable ir))
(ir:type-check ir)
;(eprintf "Unit removed types passed~n")
ir))))
(define (optimize ir)
(define (simple-optimize ir)
(let ((ir (remove-units ir)))
(let ((ir (inline-once-used ir)))
(let ((ir (inline-trivial ir)))
(let ((ir (remove-empty-bind-rec ir)))
(let ((ir (remove-unused-variable-bindings ir)))
(let ((ir (known-function-optimization ir)))
;(ir:type-check ir)
ir)))))))
(let loop ((ir ir))
(let ((new-ir (simple-optimize ir)))
(if (equal? new-ir ir)
new-ir
(loop new-ir)))))
(define (analyze ir)
(let ((zcfa-results (zero-cfa ir)))
(for (((variable functions) zcfa-results))
(printf "~a: ~a~n" (unique->symbol variable) (hash-map functions (lambda (k t) (unique->symbol k))))))
ir)
(define (source->ir s/p)
(simplify (check-semantics (parse s/p))))
(define (full-compile s/p mode)
(case mode
((llvm-opt) (optimize-llvm (compile-program (lift (optimize (source->ir s/p))))))
((llvm) (compile-program (lift (optimize (source->ir s/p)))))
((lifted) (lift (optimize (source->ir s/p))))
((ir) (optimize (source->ir s/p)))
(else (error 'full-compile "Unknown mode ~a" mode))))
(define (compile-llvm program exe-path-string)
(define exe-path
(cond
((string? exe-path-string) (string->path exe-path-string))
((path? exe-path-string) exe-path-string)))
(with-temporary-file bitcode
(with-temporary-file assembly
(with-temporary-file object
(write-program program bitcode)
(system* "/usr/bin/env" "llc" "-O2" "-disable-cfi" "-march" "x86" "-o" (path->string assembly) (path->string bitcode))
(case (system-type 'os)
((macosx)
(system* "/usr/bin/env" "as" "-arch" "i686" "-o" (path->string object) (path->string assembly)))
((unix)
(system* "/usr/bin/env" "as" "-march" "i686" "-o" (path->string object) (path->string assembly)))
(else (error 'compile-llvm "Unknown System type")))
(system* "/usr/bin/env" "clang" (path->string object) "-Wl,-no_pie" "-l" "m" "-arch" "i386" "-o" (path->string exe-path))))))