Mercurial > repos > icfp2014

comparison code/gcc.tp @ 43:6d2cbad5fca9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
WIP version of a compiler for the LamCo GCC
author Michael Pavone <pavone@retrodev.com>
date Sun, 27 Jul 2014 01:50:49 -0700
parents
children ec87d53603dd
comparison
equal deleted inserted replaced
42:f1453e8970ca 43:6d2cbad5fca9
1 #{
2 new <- :code {
3 consUsage <- 0
4 dataStack <- []
5 controlStack <- 0
6 stackSize <- 0
7 pc <- 0
8
9 error <- :_msg {
10 #{
11 msg <- { _msg }
12 isInteger? <- { false }
13 isError? <- { true }
14 isClosure? <- { false }
15 isEnvironment? <- { false }
16 isCons? <- { false }
17 isJoin? <- { false }
18 isStop? <- { false }
19 tag <- { "ERROR" }
20 }
21 }
22 _dummy <- #{
23 isInteger? <- { false }
24 isError? <- { false }
25 isClosure? <- { false }
26 isEnvironment? <- { false }
27 isCons? <- { false }
28 isJoin? <- { false }
29 isStop? <- { false }
30 tag <- { "DUMMY" }
31 }
32
33 getTag <- :val {
34 if: (val isInteger?) {
35 "INTEGER"
36 } else: {
37 val tag
38 }
39 }
40
41 push <- :val {
42 dataStack <- val | dataStack
43 stackSize <- stackSize + 1
44 }
45
46 pop <- {
47 if: (dataStack empty?) {
48 error: "datastack empty"
49 } else: {
50 ret <- dataStack value
51 dataStack <- dataStack tail
52 stackSize <- stackSize - 1
53 ret
54 }
55 }
56
57 _curEnv <- #{
58 ld <- :envNum slotNum {
59 error: "invalid environment"
60 }
61 st <- :envNum slotNum val {
62 error: "invalid environment"
63 }
64 rapLoad <- {
65 error: "invalid environment"
66 }
67 isError? <- { false }
68 isEnvironment? <- { true }
69 isJoin? <- { false }
70 isReturn? <- { false }
71 isStop? <- { false }
72 tag <- { "TOPENV" }
73 }
74
75 cons <- :_car _cdr {
76 consUsage <- consUsage + 1
77 #{
78 car <- { _car }
79 cdr <- { _cdr }
80 isInteger? <- { false }
81 isError? <- { false }
82 isClosure? <- { false }
83 isEnvironment? <- { false }
84 isCons? <- { true }
85 isJoin? <- { false }
86 tag <- { "CONS" }
87 }
88 }
89
90
91 env:dummy? <- :_size _parent :_dummy? {
92 consUsage <- consUsage + 1 + _size / 2
93 _arr <- #[]
94 _hasError <- false
95 _error <- false
96 if: _size > 0 {
97 _arr resize: _size
98 i <- 0
99 while: { i < _size } do: {
100 _arr append: 0
101 i <- i + 1
102 }
103
104 if: (not: _dummy?) {
105 i <- _size - 1
106 while: { (not: _hasError) && i >= 0 } do: {
107 val <- pop:
108 if: ((not: (val isInteger?)) && (val isError?)) {
109 _error <- error: "data stack empty while populating env at slot " . i . " of " . _size
110 _hasError <- true
111 } else: {
112 _arr set: i val
113 i <- i - 1
114 }
115 }
116 }
117 }
118 if: _hasError {
119 _error
120 } else: {
121 #{
122 != <- :other {
123 //TODO: implement me properly
124 tag != (other tag)
125 }
126 ld <- :envNum slotNum {
127 if: envNum > 0 {
128 _parent ld: envNum - 1 slotNum
129 } else: {
130 if: _dummy? {
131 error: "attempt to ld from dummy env"
132 } else: {
133 if: slotNum < _size {
134 _arr get: slotNum
135 } else: {
136 error: "attempt to access invalid slot " . slotNum . " in env of size " . _size
137 }
138 }
139 }
140 }
141 st <- :envNum slotNum val {
142 if: envNum > 0 {
143 _parent st: envNum - 1 slotNum val
144 } else: {
145 if: _dummy? {
146 error: "attempt to st to dummy env"
147 } else: {
148 if: slotNum < _size {
149 _arr set: slotNum val
150 _dummy
151 } else: {
152 error: "attempt to access invalid slot " . slotNum . " in env of size " . _size
153 }
154 }
155 }
156 }
157 rapLoad <- :rapSize {
158 if: _dummy? {
159 if: rapSize != _size {
160 _hasError <- true
161 _error <- error: "frame size mismatch for RAP instruction"
162 } else: {
163 i <- 0
164 i <- _size - 1
165 while: { (not: _hasError) && i >= 0 } do: {
166 val <- pop:
167 if: ((not: (val isInteger?)) && (val isError?)) {
168 _error <- error: "data stack empty while populating env at slot " . i . " of " . _size
169 _hasError <- true
170 } else: {
171 _arr set: i val
172 i <- i - 1
173 }
174 }
175 _dummy? <- false
176 }
177 } else: {
178 _hasError <- true
179 _error <- error: "attempt to RAP into non-dummy environment"
180 }
181 if: _hasError { _error } else: { _dummy }
182 }
183 isError? <- { false }
184 isEnvironment? <- { true }
185 isJoin? <- { false }
186 isReturn? <- { false }
187 isStop? <- { false }
188 tag <- { "ENVIRONMENT" }
189 }
190 }
191 }
192
193
194 closure <- :_address {
195 _env <- _curEnv
196 #{
197 address <- { _address }
198 env <- { _env }
199 isInteger? <- { false }
200 isError? <- { false }
201 isClosure? <- { true }
202 isEnvironment? <- { false }
203 isCons? <- { false }
204 isJoin? <- { false }
205 tag <- { "CLOSURE" }
206 }
207 }
208
209 join <- :_address {
210 #{
211 address <- { _address }
212 isError? <- { false }
213 isEnvironment? <- { false }
214 isJoin? <- { true }
215 isReturn? <- { false }
216 isStop? <- { false }
217 tag <- { "JOIN" }
218 }
219 }
220 return <- :_address {
221 #{
222 address <- { _address }
223 isError? <- { false }
224 isEnvironment? <- { false }
225 isJoin? <- { false }
226 isReturn? <- { true }
227 isStop? <- { false }
228 tag <- { "RETURN" }
229 }
230 }
231 stop <- #{
232 isError? <- { false }
233 isEnvironment? <- { false }
234 isJoin? <- { false }
235 isReturn? <- { false }
236 isStop? <- { true }
237 tag <- { "STOP" }
238 }
239
240 _instConstructors <- dict hash
241 _instConstructors set: "LDC" :args {
242 _const <- args get: 0
243 {
244 push: _const
245 _dummy
246 }
247 }
248 _instConstructors set: "LD" :args {
249 _env <- args get: 0
250 _slot <- args get: 1
251 {
252 val <- _curEnv ld: _env _slot
253 if: (not: (val isInteger?)) && (val isError?) {
254 val
255 } else: {
256 push: val
257 _dummy
258 }
259 }
260 }
261 _instConstructors set: "ST" :args {
262 _env <- args get: 0
263 _slot <- args get: 1
264 {
265 val <- pop:
266 if: (not: (val isInteger?)) && (val isError?) {
267 val
268 } else: {
269 _curEnv st: _env _slot val
270 }
271 }
272 }
273
274 binaryConstruct <- macro: :name op a b{
275 quote: (_instConstructors set: name :args {
276 {
277 a <- pop:
278 if: (a isInteger?) {
279 b <- pop:
280 if: (b isInteger?) {
281 push: op
282 _dummy
283 } else: {
284 if: (b isError?) {
285 b
286 } else: {
287 error: "Got wrong type for left param of " . name . " instruction"
288 }
289 }
290 } else: {
291 if: (a isError?) {
292 a
293 } else: {
294 error: "Got wrong type for right param of " . name . " instruction"
295 }
296 }
297 }
298 })
299 }
300
301 binaryConstruct: "ADD" b + a a b
302 binaryConstruct: "SUB" b - a a b
303 binaryConstruct: "MUL" b * a a b
304 binaryConstruct: "DIV" b / a a b
305 binaryConstruct: "CEQ" (if: b = a { 1 } else: { 0 }) a b
306 binaryConstruct: "CGT" (if: b > a { 1 } else: { 0 }) a b
307 binaryConstruct: "CGTE" (if: b >= a { 1 } else: { 0 }) a b
308 _instConstructors set: "ATOM" :args {
309 {
310 val <- pop:
311 if: (val isInteger?) {
312 push: 1
313 _dummy
314 } else: {
315 if: (val isError?) {
316 val
317 } else: {
318 push: 0
319 _dummy
320 }
321 }
322 }
323 }
324 _instConstructors set: "CONS" :args {
325 {
326 a <- pop:
327 if: ((not: (a isInteger?)) && (a isError?)) {
328 a
329 } else: {
330 b <- pop:
331 if: ((not: (b isInteger?)) && (b isError?)) {
332 b
333 } else: {
334 push: (cons: b a)
335 _dummy
336 }
337 }
338 }
339 }
340 _instConstructors set: "CAR" :args {
341 {
342 val <- pop:
343 if: (val isInteger?) {
344 error: "CAR expects CONS cell, got INTEGER instead"
345 } else: {
346 if: (val isError?) {
347 val
348 } else: {
349 if: (val isCons?) {
350 push: (val car)
351 _dummy
352 } else: {
353 error: "CAR expects CONS cell, got " . (val tag) . " instead"
354 }
355 }
356 }
357 }
358 }
359 _instConstructors set: "CDR" :args {
360 {
361 val <- pop:
362 if: (val isInteger?) {
363 error: "CDR expects CONS cell, got integer instead"
364 } else: {
365 if: (val isError?) {
366 val
367 } else: {
368 if: (val isCons?) {
369 push: (val cdr)
370 _dummy
371 } else: {
372 error: "CDR expects CONS cell, got " . (val tag) . " instead"
373 }
374 }
375 }
376 }
377 }
378 _instConstructors set: "SEL" :args {
379 _t <- args get: 0
380 _f <- args get: 1
381 {
382 val <- pop:
383 if: (val isInteger?) {
384 controlStack <- cons: (join: pc) controlStack
385 pc <- if: (val != 0) { _t } else: { _f }
386 _dummy
387 } else: {
388 if: (val isError?) {
389 val
390 } else: {
391 error: "SEL expects INTEGER, got " . (val tag) . " instead"
392 }
393 }
394 }
395 }
396 _instConstructors set: "TSEL" :args {
397 _t <- args get: 0
398 _f <- args get: 1
399 {
400 val <- pop:
401 if: (val isInteger?) {
402 pc <- if: (val != 0) { _t } else: { _f }
403 _dummy
404 } else: {
405 if: (val isError?) {
406 val
407 } else: {
408 error: "TSEL expects INTEGER, got " . (val tag) . " instead"
409 }
410 }
411 }
412 }
413 _instConstructors set: "JOIN" :args {
414 {
415 if: (controlStack isInteger?) {
416 error: "JOIN tried to pull value from empty control stack"
417 } else: {
418 val <- controlStack car
419 controlStack <- controlStack cdr
420 if: (val isJoin?) {
421 pc <- val address
422 _dummy
423 } else: {
424 error: "JOIN expects JOIN cell, got " . (val tag) . " instead"
425 }
426 }
427 }
428 }
429 _instConstructors set: "LDF" :args {
430 _address <- args get: 0
431 {
432 push: (closure: _address)
433 _dummy
434 }
435 }
436 _instConstructors set: "AP" :args {
437 _envSize <- args get: 0
438 {
439 val <- pop:
440 if: (val isInteger?) {
441 error: "AP expects CLOSURE, got INTEGER instead"
442 } else: {
443 if: (val isError?) {
444 val
445 } else: {
446 if: (val isClosure?) {
447 frame <- env: _envSize (val env) dummy?: false
448 if: (frame isError?) {
449 frame
450 } else: {
451 controlStack <- cons: (return: pc+1) (cons: _curEnv controlStack)
452 _curEnv <- frame
453 pc <- val address
454 _dummy
455 }
456 } else: {
457 error: "AP expects CLOSURE, got " . (val tag) . " instead"
458 }
459 }
460 }
461 }
462 }
463 _instConstructors set: "TAP" :args {
464 _envSize <- args get: 0
465 {
466 val <- pop:
467 if: (val isInteger?) {
468 error: "TAP expects CLOSURE, got INTEGER instead"
469 } else: {
470 if: (val isError?) {
471 val
472 } else: {
473 if: (val isClosure?) {
474 frame <- env: _envSize (val env) dummy?: false
475 if: (frame isError?) {
476 frame
477 } else: {
478 _curEnv <- frame
479 pc <- val address
480 _dummy
481 }
482 } else: {
483 error: "TAP expects CLOSURE, got " . (val tag) . " instead"
484 }
485 }
486 }
487 }
488 }
489 _instConstructors set: "RTN" :args {
490 {
491 if: (controlStack isInteger?) {
492 error: "control stack is empty for RTN instruction"
493 } else: {
494 val <- controlStack car
495 controlStack <- controlStack cdr
496 if: (val isReturn?) {
497 _curEnv <- controlStack car
498 controlStack <- controlStack cdr
499 pc <- val address
500 _dummy
501 } else: {
502 if: (val isStop?) {
503 val
504 } else: {
505 error: "RTN expects RETURN, got " . (val tag) . " instead"
506 }
507 }
508 }
509 }
510 }
511 _instConstructors set: "DUM" :args {
512 _envSize <- args get: 0
513 {
514 frame <- env: _envSize _curEnv dummy?: true
515 if: (frame isError?) {
516 frame
517 } else: {
518 _curEnv <- frame
519 _dummy
520 }
521 }
522 }
523 _instConstructors set: "RAP" :args {
524 _envSize <- args get: 0
525 {
526 val <- pop:
527 if: (val isInteger?) {
528 error: "RAP expects CLOSURE, got INTEGER instead"
529 } else: {
530 if: (val isError?) {
531 val
532 } else: {
533 if: (val isClosure?) {
534 res <- _curEnv rapLoad: _envSize
535 if: (not: (res isError?)) {
536 if: (val env) != _curEnv {
537 res <- error: "CLOSURE environment must equal current environment for RAP"
538 } else: {
539 controlStack <- cons: (return: pc+1) (cons: (_curEnv parent) controlStack)
540 pc <- val address
541 }
542 }
543 res
544 } else: {
545 error: "RAP expects CLOSURE, got " . (val tag) . " instead"
546 }
547 }
548 }
549 }
550 }
551 _instConstructors set: "TRAP" :args {
552 _envSize <- args get: 0
553 {
554 val <- pop:
555 if: (val isInteger?) {
556 error: "RAP expects CLOSURE, got INTEGER instead"
557 } else: {
558 if: (val isError?) {
559 val
560 } else: {
561 if: (val isClosure?) {
562 res <- _curEnv rapLoad: _envSize
563 if: (not: (res isError?)) {
564 if: (val env) != _curEnv {
565 res <- error: "CLOSURE environment must equal current environment for RAP"
566 } else: {
567 pc <- val address
568 }
569 }
570 res
571 } else: {
572 error: "RAP expects CLOSURE, got " . (val tag) . " instead"
573 }
574 }
575 }
576 }
577 }
578 _instConstructors set: "STOP" :args {
579 {
580 stop
581 }
582 }
583 _instConstructors set: "DBUG" :args {
584 {
585 val <- pop:
586 if: (not: (val isInteger?)) && (val isError?) {
587 val
588 } else: {
589 print: (string: val) . "\n"
590 _dummy
591 }
592 }
593 }
594 _instConstructors set: "BRK" :args {
595 {
596 _dummy
597 }
598 }
599
600 code <- code map: :i {
601 foobar <- _instConstructors get: (i inst) else: { { stop } }
602 foobar: (i args)
603 }
604
605 #{
606 limit <- 3072 * 1000
607 run <- {
608 cycles <- 0
609 status <- _dummy
610 while: { (not: (status isError?)) && (not: (status isStop?)) } do: {
611 oldpc <- pc
612 if: (cycles >= limit) {
613 status <- error: "cycle limit of " . limit . " exceeded"
614 } else: {
615 if: (pc >= (code length)) {
616 status <- error: "PC walked off end of program"
617 } else: {
618 inst <- code get: pc
619 pc <- -1
620 status <- inst:
621 if: pc = -1 {
622 pc <- oldpc + 1
623 }
624 cycles <- cycles + 1
625 }
626 }
627 }
628 print: "Status: " . (status tag) . "\n"
629 if: (status isStop?) {
630 if: (dataStack empty?) {
631 _dummy
632 } else: {
633 pop:
634 }
635 } else: {
636 status
637 }
638 }
639 }
640 }
641
642 parseLines <- :lines {
643 //remove comments and filter blank lines
644 lines <- (lines map: :line {
645 ((line partitionOn: ";") before) trim
646 }) filter: :line { line != "" }
647 //parse the preprocessed lines
648 lines map: :line {
649 ret <- line partitionOn: " "
650 _inst <- ret before
651 _args <- (((ret after) trim) splitOn: " ") map: :arg { int32: arg }
652 #{
653 inst <- { _inst }
654 args <- { _args }
655 }
656 }
657 }
658
659 parseFile <- :f {
660 parseLines: (f lines)
661 }
662
663 main <- :args {
664 if: (args length) > 1 {
665 f <- file open: (args get: 1)
666 if: (f fd) >= 0 {
667 code <- parseFile: f
668 cpu <- new: code
669 res <- cpu run
670 print: "Returned value of type: " . (res tag) . "\n"
671 if: (res isError?) {
672 print: (res msg) . "\n"
673 }
674 0
675 } else: {
676 (file stderr) write: "Failed to open " . (args get: 1) . " for reading\n"
677 1
678 }
679 } else: {
680 (file stderr) write: "USAGE: gcc FILE\n"
681 1
682 }
683 }
684 }