-
Notifications
You must be signed in to change notification settings - Fork 9
/
compile.l2
322 lines (273 loc) · 20 KB
/
compile.l2
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
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
(-- Compiles a program into a list of assembly expressions.)
(constrain compile-program
(\ r (?(a b c) (`(function ((list (expr ,:c)) (list initializer) ,:b region region ,:a)
(values (list instr) (list reloc) (list (values string (list instr) (list reloc)))
(hash-table string bndg-aug) (list bndg-aug)))r)r)))
(function compile-program (exprs inits outs buf buf2 handler)
(sub (.. buf handler)
(let (static-bindings (storage _ nil)) (undefined-bindings [ht-create hash-str str= ..])
(global-bindings [global-binding-augs-of exprs ..]) (do
(let (storage-offset
(fold (storage-offset [- #:0 (word-size)]) (expr (%:list-ref-iter exprs)) (do
[visit-expressions vfind-multiple-definitions expr handler]
[visit-expressions veliminate-constrain expr (~)]
[visit-expressions vswap-branches expr (~)]
[visit-expressions vdominate-jumps expr (~)]
[classify-program-bindings $:expr]
[link-symbols $:expr (true) undefined-bindings global-bindings (~) ..]
(-- [infer-types $:expr ..])
[escape-analysis $:expr (true) ..]
[pre-visit-expressions vpropagate-expressions expr (values storage buf2 handler)]
[assign-expr-is-reads $:expr]
[place-perm-bindings $:expr storage-offset])))
(for (expr (%:list-iter exprs)) (~) (do
[assign-depths expr #:0]
[initialize-expressions (storage-cons expr nil) nil [- storage-offset (word-size)]
#:0 #:0 inits (values storage (~)(~)) buf2 handler]
[setup-collect-static-bindings expr]
[collect-static-bindings expr static-bindings ..])))
((values? .:instrs .:relocs .:func-secs) [generate-program exprs bind ..]
(values (use-storage outs) instrs relocs func-secs undefined-bindings $:static-bindings) (~))))))
(-- Loads a program into memory and returns a handle to it. program is a program expression.
expr-buf is the region into which the results of compilation will be put. obj-buf is the
region into which the object code will be put. Return value is an object.)
(constrain load-program (\ r (?(a b) (`(function ((list (expr ,:b)) (list initializer) region region ,:a) obj)r)r)))
(function load-program (exprs inits buf buf2 handler)
(sub (.. buf handler)
(with-region buf2
((values? .:asms .:relocs .:func-secs .:undefined-bindings .:static-bindings) [compile-program exprs inits bind buf2 buf handler]
((values? .:objdest .:objdest-sz) [write-elf asms relocs func-secs undefined-bindings static-bindings bind buf2 buf handler]
(let (obj [load objdest objdest-sz buf handler]) (do
[binding-offsets-to-addresses asms func-secs static-bindings obj buf handler]
obj)) (~)) (~)))))
(constrain read-to-buffer (\ r (?(a b c d) (`(function (string ,:a region ,:b) (values ,:c ,:d))r)r)))
(function read-to-buffer (fn outs buf handler)
(let (fd [open fn handler])
(fallthrough
(do
(let (size-out [size fd close-file])
(let (src-buf [region-alloc size-out buf close-file]) (do
[read fd src-buf size-out close-file]
(storage _ no-error src-buf size-out)))))
(close-file err (do
[close fd handler]
(if [= (@0 err) no-error] (values (use-storage outs) (@1 err) (@2 err)) {handler err}))))))
(-- Reads a list of expressions from a given file. fn is a string containing the filename.
buf is the region into which the constructed expressions will be put. Return value is a
list of expressions.)
(constrain read-expressions (\ r (?(a b) (`(function (string region region ,:a) (list (expr ,:b)))r)r)))
(function read-expressions (fn buf buf2 handler)
(sub (.. buf handler)
(with-region buf2
((values? .:src-buf .:src-sz) [read-to-buffer fn bind buf2 handler]
(let (pos (storage _ #:0))
(let (exprs-start (storage _ nil))
(loop cons-expr (exprs-end exprs-start)
(if [read-whitespace src-buf src-sz pos]
{cons-expr [append [build-expression [read-fragment src-buf src-sz pos ..] null-expr ..] exprs-end ..]}
$:exprs-start)))) (~)))))
(storage unsupported-intrinsics-error (~))
(-- Takes a list of L2 and object file names, loads their contents into memory, and links
them together. The global symbols of the object code are then added to the list of
bindings.)
(constrain evaluate-files
(\ r (?(a b) (`(function ((list string) (list string) (list string) !:Ref:(list (expr ,:b)) (hash-table string (expr ,:b)) (hash-table string bndg-aug) region region ,:a) ())r)r)))
(function evaluate-files (source-fns object-fns intrinsic-fns meta-exprs func-exprs bindings buf buf2 handler)
(sub (.. buf handler)
(let (inits [collect-reverse-list (map (intrinsic-fn (%:list-iter intrinsic-fns))
(switch str= intrinsic-fn
((" arithmetic) [function->initializer initialize-arithmetic-intrinsics])
{handler (storage _ unsupported-intrinsics-error intrinsic-fn)})) nil ..])
(let (objects1 (fold (objects nil) (src (%:list-iter object-fns))
((values? .:obj-buf .:obj-sz) [read-to-buffer src bind ..]
(let (obj [load obj-buf obj-sz ..])
(do [immutable-bindings obj bindings ..] [cons obj objects ..])) (~))))
(let (objects2 (fold (objects objects1) (intrinsic-fn (%:list-iter intrinsic-fns))
(switch str= intrinsic-fn
((" arithmetic)
(let (obj [load-program [wrap-arithmetic-intrinsics ..] inits buf buf2 handler])
(do [immutable-bindings obj bindings ..] [cons obj objects ..])))
{handler (storage _ unsupported-intrinsics-error intrinsic-fn)}))) (do
(for (src (%:list-iter source-fns)) (~)
(for (expr (%:list-iter [read-expressions src buf buf2 handler])) (~)
(match expr
((expr:meta? .:meta) (do [prepend expr meta-exprs ..] (~)))
((expr:function? .:func) (do [ht-put (@ bndg-name (@ expr:function-reference func)) expr func-exprs ..] (~)))
(~)))) (~)))))))
(constrain compile-program-to-elf (\ r (?(a b) (`(function ((list (expr ,:b)) (list initializer) string region region ,:a) ())r)r)))
(function compile-program-to-elf (exprs inits outfn buf buf2 handler)
(with-region buf2
((values? .:asms .:relocs .:func-secs .:undefined-bindings .:static-bindings) [compile-program exprs inits bind buf2 buf handler]
((values? .:objdest .:objdest-sz) [write-elf asms relocs func-secs undefined-bindings static-bindings bind buf2 buf handler]
(let (fd [create outfn handler]) (do
[print fd objdest objdest-sz handler]
[close fd handler])) (~)) (~))))
(-- Takes a list of L2 source files and compiles them into object files. programs is a
list of strings containing paths to L2 source files. bndgs is a list of bindings
pointing to the macros to be used during the meta-expression expansions. buf is the
region into which constructed expressions and object code will be put.)
(constrain compile-files
(\ r (?(a b) (`(function ((list string) (list string) !:Ref:(list (expr ,:b)) (hash-table string (expr ,:b)) (hash-table string bndg-aug) region region ,:a) ())r)r)))
(function compile-files (file-names intrinsic-fns meta-exprs func-exprs bndgs buf buf2 handler)
(sub (.. buf handler)
(with-region buf2
(let (inits [collect-reverse-list (map (intrinsic-fn (%:list-iter intrinsic-fns))
(switch str= intrinsic-fn
((" arithmetic) [function->initializer initialize-arithmetic-intrinsics])
{handler (storage _ unsupported-intrinsics-error intrinsic-fn)})) nil ..]) (do
[set-bindings-resolved bndgs #:1]
(let (file-exprss [collect-list (map (infn (%:list-iter file-names))
[collect-list (map (e (%:list-iter[read-expressions infn buf buf2 handler]))
(let (f (storage _ e))
(do [pre-visit-expressions vgenerate-expr f (values storage inits meta-exprs func-exprs bndgs buf buf2 handler)] $:f))) nil ..]) nil ..]) (do
(let (all-exprs [reverse-flatten file-exprss ..])
(let (undefined-bindings [ht-create hash-str str= ..]) (global-bindings [global-binding-augs-of all-exprs ..]) (do
(for (expr (%:list-iter all-exprs)) (~) [link-symbols expr (true) undefined-bindings global-bindings (~) ..])
[infer-types all-exprs ..]
(for (expr (%:list-iter all-exprs)) (~) [pre-visit-expressions vunlink-symbols (storage _ expr) (values storage global-bindings ..)])
(for (expr (%:list-iter all-exprs)) (~) [pre-visit-expressions vunlink-symbols (storage _ expr) (values storage undefined-bindings ..)]))))
(for (infn (%:list-iter file-names)) (exprs (%:list-iter file-exprss)) (~)
[compile-program-to-elf exprs inits [rstrcat infn (" .o) buf2 handler] buf2 buf handler])
(for (intrinsic-fn (%:list-iter intrinsic-fns)) (~)
(switch str= intrinsic-fn
((" arithmetic) [compile-program-to-elf [wrap-arithmetic-intrinsics ..] inits (" arithmetic.o) buf buf2 handler])
{handler (storage _ unsupported-intrinsics-error intrinsic-fn)})))))))))
(storage arguments-error (~))
(storage no-error (~))
(-- This is where program execution starts. The following code essentially loads up and
executes the code specified in the command line arguments and then compiles the
separately specified code using the already loaded up functions as macros. It also
prints out the error messages if there are any.)
(fallthrough
(let (buf [create-region #:0 exit-cont]) (buf2 [create-region #:0 exit-cont])
(fallthrough
(do
(let (source-fns (storage _ [@cdr[argv buf handler]]))
(let (first-dash-ref (locate (arg source-fns) [str= arg (" -)]))
(if [nil? $:first-dash-ref] {handler (storage _ arguments-error)}
(let (intrinsic-fns (storage _ [@cdr $:first-dash-ref]))
(let (second-dash-ref (locate (arg intrinsic-fns) [str= arg (" -)]))
(if [nil? $:second-dash-ref] {handler (storage _ arguments-error)}
(let (object-fns (storage _ [@cdr $:second-dash-ref])) (do
(-- Cut the source filenames and object filenames list short.)
[set first-dash-ref nil]
[set second-dash-ref nil]
(-- These are all the bindings necessary for metaprogramming. Their
definitions can be found in list.l2 and lexer.l2.)
(let (func-exprs [ht-create hash-str str= buf handler]) (meta-exprs (storage _ nil))
(bndgs (sub (.. buf handler) (ht-putall ([ht-create hash-str str= ..] ..)
((" -!-)[make-binding (" -!-)(tkn-char(char !))..]) ((" -!-)[make-binding (" -!-)(tkn-char(char !))..])
((" -"-)[make-binding (" -"-)(tkn-char(char "))..]) ((" -#-)[make-binding (" -#-)(tkn-char(char #))..])
((" -$-)[make-binding (" -$-)(tkn-char(char $))..]) ((" -%-)[make-binding (" -%-)(tkn-char(char %))..])
((" -&-)[make-binding (" -&-)(tkn-char(char &))..]) ((" -'-)[make-binding (" -'-)(tkn-char(char '))..])
((" -*-)[make-binding (" -*-)(tkn-char(char *))..]) ((" -+-)[make-binding (" -+-)(tkn-char(char +))..])
((" -,-)[make-binding (" -,-)(tkn-char(char ,))..]) ((" ---)[make-binding (" ---)(tkn-char(char -))..])
((" -.-)[make-binding (" -.-)(tkn-char(char .))..]) ((" -/-)[make-binding (" -/-)(tkn-char(char /))..])
((" -0-)[make-binding (" -0-)(tkn-char(char 0))..]) ((" -1-)[make-binding (" -1-)(tkn-char(char 1))..])
((" -2-)[make-binding (" -2-)(tkn-char(char 2))..]) ((" -3-)[make-binding (" -3-)(tkn-char(char 3))..])
((" -4-)[make-binding (" -4-)(tkn-char(char 4))..]) ((" -5-)[make-binding (" -5-)(tkn-char(char 5))..])
((" -6-)[make-binding (" -6-)(tkn-char(char 6))..]) ((" -7-)[make-binding (" -7-)(tkn-char(char 7))..])
((" -8-)[make-binding (" -8-)(tkn-char(char 8))..]) ((" -9-)[make-binding (" -9-)(tkn-char(char 9))..])
((" -<-)[make-binding (" -<-)(tkn-char(char <))..]) ((" -=-)[make-binding (" -=-)(tkn-char(char =))..])
((" ->-)[make-binding (" ->-)(tkn-char(char >))..]) ((" -?-)[make-binding (" -?-)(tkn-char(char ?))..])
((" -@-)[make-binding (" -@-)(tkn-char(char @))..]) ((" -A-)[make-binding (" -A-)(tkn-char(char A))..])
((" -B-)[make-binding (" -B-)(tkn-char(char B))..]) ((" -C-)[make-binding (" -C-)(tkn-char(char C))..])
((" -D-)[make-binding (" -D-)(tkn-char(char D))..]) ((" -E-)[make-binding (" -E-)(tkn-char(char E))..])
((" -F-)[make-binding (" -F-)(tkn-char(char F))..]) ((" -G-)[make-binding (" -G-)(tkn-char(char G))..])
((" -H-)[make-binding (" -H-)(tkn-char(char H))..]) ((" -I-)[make-binding (" -I-)(tkn-char(char I))..])
((" -J-)[make-binding (" -J-)(tkn-char(char J))..]) ((" -K-)[make-binding (" -K-)(tkn-char(char K))..])
((" -L-)[make-binding (" -L-)(tkn-char(char L))..]) ((" -M-)[make-binding (" -M-)(tkn-char(char M))..])
((" -N-)[make-binding (" -N-)(tkn-char(char N))..]) ((" -O-)[make-binding (" -O-)(tkn-char(char O))..])
((" -P-)[make-binding (" -P-)(tkn-char(char P))..]) ((" -Q-)[make-binding (" -Q-)(tkn-char(char Q))..])
((" -R-)[make-binding (" -R-)(tkn-char(char R))..]) ((" -S-)[make-binding (" -S-)(tkn-char(char S))..])
((" -T-)[make-binding (" -T-)(tkn-char(char T))..]) ((" -U-)[make-binding (" -U-)(tkn-char(char U))..])
((" -V-)[make-binding (" -V-)(tkn-char(char V))..]) ((" -W-)[make-binding (" -W-)(tkn-char(char W))..])
((" -X-)[make-binding (" -X-)(tkn-char(char X))..]) ((" -Y-)[make-binding (" -Y-)(tkn-char(char Y))..])
((" -Z-)[make-binding (" -Z-)(tkn-char(char Z))..]) ((" -\-)[make-binding (" -\-)(tkn-char(char \))..])
((" -^-)[make-binding (" -^-)(tkn-char(char ^))..]) ((" -_-)[make-binding (" -_-)(tkn-char(char _))..])
((" -`-)[make-binding (" -`-)(tkn-char(char `))..]) ((" -a-)[make-binding (" -a-)(tkn-char(char a))..])
((" -b-)[make-binding (" -b-)(tkn-char(char b))..]) ((" -c-)[make-binding (" -c-)(tkn-char(char c))..])
((" -d-)[make-binding (" -d-)(tkn-char(char d))..]) ((" -e-)[make-binding (" -e-)(tkn-char(char e))..])
((" -f-)[make-binding (" -f-)(tkn-char(char f))..]) ((" -g-)[make-binding (" -g-)(tkn-char(char g))..])
((" -h-)[make-binding (" -h-)(tkn-char(char h))..]) ((" -i-)[make-binding (" -i-)(tkn-char(char i))..])
((" -j-)[make-binding (" -j-)(tkn-char(char j))..]) ((" -k-)[make-binding (" -k-)(tkn-char(char k))..])
((" -l-)[make-binding (" -l-)(tkn-char(char l))..]) ((" -m-)[make-binding (" -m-)(tkn-char(char m))..])
((" -n-)[make-binding (" -n-)(tkn-char(char n))..]) ((" -o-)[make-binding (" -o-)(tkn-char(char o))..])
((" -p-)[make-binding (" -p-)(tkn-char(char p))..]) ((" -q-)[make-binding (" -q-)(tkn-char(char q))..])
((" -r-)[make-binding (" -r-)(tkn-char(char r))..]) ((" -s-)[make-binding (" -s-)(tkn-char(char s))..])
((" -t-)[make-binding (" -t-)(tkn-char(char t))..]) ((" -u-)[make-binding (" -u-)(tkn-char(char u))..])
((" -v-)[make-binding (" -v-)(tkn-char(char v))..]) ((" -w-)[make-binding (" -w-)(tkn-char(char w))..])
((" -x-)[make-binding (" -x-)(tkn-char(char x))..]) ((" -y-)[make-binding (" -y-)(tkn-char(char y))..])
((" -z-)[make-binding (" -z-)(tkn-char(char z))..]) ((" -|-)[make-binding (" -|-)(tkn-char(char |))..])
((" -~-)[make-binding (" -~-)(tkn-char(char ~))..]) ((" @fst)[make-binding (" @fst) @car ..])
((" @rst)[make-binding (" @rst) @cdr ..]) ((" lst)[make-binding (" lst) cons ..])
((" token?)[make-binding (" token?) i/f.token? ..]) ((" emt?)[make-binding (" emt?) emt?! ..])
((" emt)[make-binding (" emt) emt! ..]) ((" char=)[make-binding (" char=) i/f.char= ..])
((" var=)[make-binding (" var=) vbl= ..]) ((" var?)[make-binding (" var?) vbl? ..])
((" var)[make-binding (" var) vbl ..]) ((" gentok)[make-binding (" gentok) i/f.gentok ..])))) (do
(-- Evaluate the metaprogram)
[evaluate-files $:source-fns $:object-fns $:intrinsic-fns meta-exprs func-exprs bndgs buf buf2 handler]
(-- Compile the program in the metaprogram's environment)
[compile-files $:source-fns $:intrinsic-fns meta-exprs func-exprs bndgs buf buf2 handler]
(storage _ no-error))))))))))))
(handler err (sub (.. cleanup) (do
(switch = (@0 err)
(multiple-definition-error (do
[print-str (stdout) (" The definition of(space)) ..]
[print-str (stdout) (@1 err) ..]
[print-str (stdout) (" (space)erroneously occured multiple times.(lf)) ..]))
(undefined-symbol-error (do
[print-str (stdout) (" Undefined symbol(colon)(space)) ..]
[print-str (stdout) (@1 err) ..]
[print-str (stdout) (" .(lf)) ..]))
(special-form-error (if [not= (@2 err) null-fragment]
(do
[print-str (stdout) (" The subexpression(space)) ..]
[print-fragment (@2 err) ..]
[print-str (stdout) (" (space)does not satisfy the requirements of the expression(space)) ..]
[print-fragment (@1 err) ..]
[print-str (stdout) (" .(lf)) ..])
(do
[print-str (stdout) (" The expression(space)) ..]
[print-fragment (@1 err) ..]
[print-str (stdout) (" (space)has an incorrect number of subexpressions.(lf)) ..])))
(unexpected-char-error (do
[print-str (stdout) (" Unexpectedly read(space)) ..]
[print-char (stdout) (@1 err) ..]
[print-str (stdout) (" (space)at(space)) ..]
[print-uint (stdout) (@2 err) ..]
[print-str (stdout) (" .(lf)) ..]))
(file-access-error (if [getb (@1 err)]
(do
[print-str (stdout) (" Inaccessable file(colon)(space)) ..]
[print-str (stdout) (@1 err) ..]
[print-str (stdout) (" .(lf)) ..])
[print-str (stdout) (" Inaccessable file.) ..]))
(arguments-error [print-str (stdout)
(" Bad command line arguments.(lf)
Usage(colon)(space)l2evaluate src1.l2 ... - intr1.o ... - obj1.o ...(lf)
Outcome(colon)(space)Loads the functions in the source files, intrinsic objects, and object files into memory,(lf)
then preprocesses the source files using the functions in memory, then compiles the source files(lf)
into object files, and then writes out the intrinsic object files.(lf)) ..])
(memory-access-error (do
[print-str (stdout) (" Memory access error with code(colon)(space)) ..]
[print-uint (stdout) (@1 err) ..]
[print-str (stdout) (" .(lf)) ..]))
(object-error [print-str (stdout) (" Bad object file supplied.(lf)) ..])
(unification-error [print-str (stdout) (" Type equations have no solution.(lf)) ..])
(unsupported-intrinsics-error (do
[print-str (stdout) (" Compiler does not support the intrinsics library(colon)(space)) ..]
[print-str (stdout) (@1 err) ..]
[print-str (stdout) (" .(lf)) ..]))
(unsupported-instruction-error (do
[print-str (stdout) (" Assembler does not support the following instruction(colon)(lf)) ..]
[print-instr (@1 err) ..]
[print-str (stdout) (" .(lf)) ..]))
(meta-expr-error (do
[print-str (stdout) (" Meta-expression threw the following error(colon)(lf)) ..]
[print-fragment (@1 err) ..]
[print-str (stdout) (" .(lf)) ..]))
(~))
err)))
(cleanup err (do [destroy-region buf exit-cont] err))))
(exit-cont err [exit (if [= (@0 err) no-error] #:0 #:1)]))