Mercurial > repos > icfp2014

comparison code/gcc.tp @ 49:ec87d53603dd

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc simulator now works correctly at least for the subset used by ghc.lm and has some primitive debugging facilities
author Michael Pavone <pavone@retrodev.com>
date Sun, 27 Jul 2014 13:36:56 -0700
parents 6d2cbad5fca9
children
comparison
equal deleted inserted replaced
48:8b6f6e2cbf38 49:ec87d53603dd
1 #{ 1 #{
2 new <- :code { 2 getTag <- :val {
3 if: (val isInteger?) {
4 "INTEGER"
5 } else: {
6 val tag
7 }
8 }
9
10 ifError:else <- :val iferr :else {
11 if: (val isInteger?) {
12 else:
13 } else: {
14 if: (val isError?) {
15 iferr:
16 } else: {
17 else:
18 }
19 }
20 }
21
22 new <- :rawCode {
3 consUsage <- 0 23 consUsage <- 0
4 dataStack <- [] 24 dataStack <- []
5 controlStack <- 0 25 controlStack <- 0
6 stackSize <- 0 26 stackSize <- 0
7 pc <- 0 27 _pc <- 0
8 28
9 error <- :_msg { 29 error <- :_msg {
10 #{ 30 #{
11 msg <- { _msg } 31 msg <- { _msg }
12 isInteger? <- { false } 32 isInteger? <- { false }
15 isEnvironment? <- { false } 35 isEnvironment? <- { false }
16 isCons? <- { false } 36 isCons? <- { false }
17 isJoin? <- { false } 37 isJoin? <- { false }
18 isStop? <- { false } 38 isStop? <- { false }
19 tag <- { "ERROR" } 39 tag <- { "ERROR" }
40 string <- { _msg }
20 } 41 }
21 } 42 }
22 _dummy <- #{ 43 _dummy <- #{
23 isInteger? <- { false } 44 isInteger? <- { false }
24 isError? <- { false } 45 isError? <- { false }
26 isEnvironment? <- { false } 47 isEnvironment? <- { false }
27 isCons? <- { false } 48 isCons? <- { false }
28 isJoin? <- { false } 49 isJoin? <- { false }
29 isStop? <- { false } 50 isStop? <- { false }
30 tag <- { "DUMMY" } 51 tag <- { "DUMMY" }
31 } 52 string <- { tag }
32
33 getTag <- :val {
34 if: (val isInteger?) {
35 "INTEGER"
36 } else: {
37 val tag
38 }
39 } 53 }
40 54
41 push <- :val { 55 push <- :val {
42 dataStack <- val | dataStack 56 dataStack <- val | dataStack
43 stackSize <- stackSize + 1 57 stackSize <- stackSize + 1
62 error: "invalid environment" 76 error: "invalid environment"
63 } 77 }
64 rapLoad <- { 78 rapLoad <- {
65 error: "invalid environment" 79 error: "invalid environment"
66 } 80 }
81 arr <- { #[] }
67 isError? <- { false } 82 isError? <- { false }
68 isEnvironment? <- { true } 83 isEnvironment? <- { true }
69 isJoin? <- { false } 84 isJoin? <- { false }
70 isReturn? <- { false } 85 isReturn? <- { false }
71 isStop? <- { false } 86 isStop? <- { false }
72 tag <- { "TOPENV" } 87 tag <- { "TOPENV" }
88 string <- { tag }
73 } 89 }
74 90
75 cons <- :_car _cdr { 91 cons <- :_car _cdr {
76 consUsage <- consUsage + 1 92 consUsage <- consUsage + 1
77 #{ 93 #{
82 isClosure? <- { false } 98 isClosure? <- { false }
83 isEnvironment? <- { false } 99 isEnvironment? <- { false }
84 isCons? <- { true } 100 isCons? <- { true }
85 isJoin? <- { false } 101 isJoin? <- { false }
86 tag <- { "CONS" } 102 tag <- { "CONS" }
103 string <- { "(" . _car . ", " . _cdr . ")" }
87 } 104 }
88 } 105 }
89 106
90 107
91 env:dummy? <- :_size _parent :_dummy? { 108 env:dummy? <- :_size _parent :_dummy? {
184 isEnvironment? <- { true } 201 isEnvironment? <- { true }
185 isJoin? <- { false } 202 isJoin? <- { false }
186 isReturn? <- { false } 203 isReturn? <- { false }
187 isStop? <- { false } 204 isStop? <- { false }
188 tag <- { "ENVIRONMENT" } 205 tag <- { "ENVIRONMENT" }
206 string <- { tag }
207 arr <- { _arr }
189 } 208 }
190 } 209 }
191 } 210 }
192 211
193 212
201 isClosure? <- { true } 220 isClosure? <- { true }
202 isEnvironment? <- { false } 221 isEnvironment? <- { false }
203 isCons? <- { false } 222 isCons? <- { false }
204 isJoin? <- { false } 223 isJoin? <- { false }
205 tag <- { "CLOSURE" } 224 tag <- { "CLOSURE" }
206 } 225 string <- { "{" . _address . ", " . _env . "}" }
207 } 226 }
208 227 }
209 join <- :_address { 228
229 joinVal <- :_address {
210 #{ 230 #{
211 address <- { _address } 231 address <- { _address }
212 isError? <- { false } 232 isError? <- { false }
213 isEnvironment? <- { false } 233 isEnvironment? <- { false }
214 isJoin? <- { true } 234 isJoin? <- { true }
215 isReturn? <- { false } 235 isReturn? <- { false }
216 isStop? <- { false } 236 isStop? <- { false }
217 tag <- { "JOIN" } 237 tag <- { "JOIN" }
238 string <- { tag }
218 } 239 }
219 } 240 }
220 return <- :_address { 241 return <- :_address {
221 #{ 242 #{
222 address <- { _address } 243 address <- { _address }
224 isEnvironment? <- { false } 245 isEnvironment? <- { false }
225 isJoin? <- { false } 246 isJoin? <- { false }
226 isReturn? <- { true } 247 isReturn? <- { true }
227 isStop? <- { false } 248 isStop? <- { false }
228 tag <- { "RETURN" } 249 tag <- { "RETURN" }
250 string <- { tag . " " . _address }
229 } 251 }
230 } 252 }
231 stop <- #{ 253 stop <- #{
232 isError? <- { false } 254 isError? <- { false }
233 isEnvironment? <- { false } 255 isEnvironment? <- { false }
234 isJoin? <- { false } 256 isJoin? <- { false }
235 isReturn? <- { false } 257 isReturn? <- { false }
236 isStop? <- { true } 258 isStop? <- { true }
237 tag <- { "STOP" } 259 tag <- { "STOP" }
260 string <- { tag }
238 } 261 }
239 262
240 _instConstructors <- dict hash 263 _instConstructors <- dict hash
241 _instConstructors set: "LDC" :args { 264 _instConstructors set: "LDC" :args {
242 _const <- args get: 0 265 _const <- args get: 0
279 b <- pop: 302 b <- pop:
280 if: (b isInteger?) { 303 if: (b isInteger?) {
281 push: op 304 push: op
282 _dummy 305 _dummy
283 } else: { 306 } else: {
284 if: (b isError?) { 307 if: (b isError?) {
285 b 308 b
286 } else: { 309 } else: {
287 error: "Got wrong type for left param of " . name . " instruction" 310 error: "Got wrong type for left param of " . name . " instruction"
288 } 311 }
289 } 312 }
379 _t <- args get: 0 402 _t <- args get: 0
380 _f <- args get: 1 403 _f <- args get: 1
381 { 404 {
382 val <- pop: 405 val <- pop:
383 if: (val isInteger?) { 406 if: (val isInteger?) {
384 controlStack <- cons: (join: pc) controlStack 407 controlStack <- cons: (joinVal: _pc) controlStack
385 pc <- if: (val != 0) { _t } else: { _f } 408 _pc <- if: (val != 0) { _t } else: { _f }
386 _dummy 409 _dummy
387 } else: { 410 } else: {
388 if: (val isError?) { 411 if: (val isError?) {
389 val 412 val
390 } else: { 413 } else: {
397 _t <- args get: 0 420 _t <- args get: 0
398 _f <- args get: 1 421 _f <- args get: 1
399 { 422 {
400 val <- pop: 423 val <- pop:
401 if: (val isInteger?) { 424 if: (val isInteger?) {
402 pc <- if: (val != 0) { _t } else: { _f } 425 _pc <- if: (val != 0) { _t } else: { _f }
403 _dummy 426 _dummy
404 } else: { 427 } else: {
405 if: (val isError?) { 428 if: (val isError?) {
406 val 429 val
407 } else: { 430 } else: {
416 error: "JOIN tried to pull value from empty control stack" 439 error: "JOIN tried to pull value from empty control stack"
417 } else: { 440 } else: {
418 val <- controlStack car 441 val <- controlStack car
419 controlStack <- controlStack cdr 442 controlStack <- controlStack cdr
420 if: (val isJoin?) { 443 if: (val isJoin?) {
421 pc <- val address 444 _pc <- val address
422 _dummy 445 _dummy
423 } else: { 446 } else: {
424 error: "JOIN expects JOIN cell, got " . (val tag) . " instead" 447 error: "JOIN expects JOIN cell, got " . (val tag) . " instead"
425 } 448 }
426 } 449 }
446 if: (val isClosure?) { 469 if: (val isClosure?) {
447 frame <- env: _envSize (val env) dummy?: false 470 frame <- env: _envSize (val env) dummy?: false
448 if: (frame isError?) { 471 if: (frame isError?) {
449 frame 472 frame
450 } else: { 473 } else: {
451 controlStack <- cons: (return: pc+1) (cons: _curEnv controlStack) 474 controlStack <- cons: (return: _pc) (cons: _curEnv controlStack)
452 _curEnv <- frame 475 _curEnv <- frame
453 pc <- val address 476 _pc <- val address
454 _dummy 477 _dummy
455 } 478 }
456 } else: { 479 } else: {
457 error: "AP expects CLOSURE, got " . (val tag) . " instead" 480 error: "AP expects CLOSURE, got " . (val tag) . " instead"
458 } 481 }
474 frame <- env: _envSize (val env) dummy?: false 497 frame <- env: _envSize (val env) dummy?: false
475 if: (frame isError?) { 498 if: (frame isError?) {
476 frame 499 frame
477 } else: { 500 } else: {
478 _curEnv <- frame 501 _curEnv <- frame
479 pc <- val address 502 _pc <- val address
480 _dummy 503 _dummy
481 } 504 }
482 } else: { 505 } else: {
483 error: "TAP expects CLOSURE, got " . (val tag) . " instead" 506 error: "TAP expects CLOSURE, got " . (val tag) . " instead"
484 } 507 }
494 val <- controlStack car 517 val <- controlStack car
495 controlStack <- controlStack cdr 518 controlStack <- controlStack cdr
496 if: (val isReturn?) { 519 if: (val isReturn?) {
497 _curEnv <- controlStack car 520 _curEnv <- controlStack car
498 controlStack <- controlStack cdr 521 controlStack <- controlStack cdr
499 pc <- val address 522 _pc <- val address
500 _dummy 523 _dummy
501 } else: { 524 } else: {
502 if: (val isStop?) { 525 if: (val isStop?) {
503 val 526 val
504 } else: { 527 } else: {
534 res <- _curEnv rapLoad: _envSize 557 res <- _curEnv rapLoad: _envSize
535 if: (not: (res isError?)) { 558 if: (not: (res isError?)) {
536 if: (val env) != _curEnv { 559 if: (val env) != _curEnv {
537 res <- error: "CLOSURE environment must equal current environment for RAP" 560 res <- error: "CLOSURE environment must equal current environment for RAP"
538 } else: { 561 } else: {
539 controlStack <- cons: (return: pc+1) (cons: (_curEnv parent) controlStack) 562 controlStack <- cons: (return: _pc) (cons: (_curEnv parent) controlStack)
540 pc <- val address 563 _pc <- val address
541 } 564 }
542 } 565 }
543 res 566 res
544 } else: { 567 } else: {
545 error: "RAP expects CLOSURE, got " . (val tag) . " instead" 568 error: "RAP expects CLOSURE, got " . (val tag) . " instead"
562 res <- _curEnv rapLoad: _envSize 585 res <- _curEnv rapLoad: _envSize
563 if: (not: (res isError?)) { 586 if: (not: (res isError?)) {
564 if: (val env) != _curEnv { 587 if: (val env) != _curEnv {
565 res <- error: "CLOSURE environment must equal current environment for RAP" 588 res <- error: "CLOSURE environment must equal current environment for RAP"
566 } else: { 589 } else: {
567 pc <- val address 590 _pc <- val address
568 } 591 }
569 } 592 }
570 res 593 res
571 } else: { 594 } else: {
572 error: "RAP expects CLOSURE, got " . (val tag) . " instead" 595 error: "RAP expects CLOSURE, got " . (val tag) . " instead"
595 { 618 {
596 _dummy 619 _dummy
597 } 620 }
598 } 621 }
599 622
600 code <- code map: :i { 623 code <- rawCode map: :i {
601 foobar <- _instConstructors get: (i inst) else: { { stop } } 624 foobar <- _instConstructors get: (i inst) else: { { stop } }
602 foobar: (i args) 625 foobar: (i args)
603 } 626 }
604 627
628
629 _stepMode? <- false
630 _lastCommand <- ""
631 _breakFun <- :cpu {
632 i <- (rawCode get: (cpu pc))
633 print: (string: (cpu pc)) . ": " . (i inst) . " " . ((i args) join: " ") . "\n"
634
635 command <- ""
636 while: { command != "c" && command != "s"} do: {
637 command <- ((file stdin) nextLine) trim
638 if: command = "" {
639 command <- _lastCommand
640 } else: {
641 _lastCommand <- command
642 }
643 if: command = "d" {
644 print: "Data Stack:\n"
645 ds <- cpu dstack
646 while: { not: (ds empty?) } do: {
647 print: "\t" . (ds value) . "\n"
648 ds <- ds tail
649 }
650 }
651 if: command = "b" {
652 print: "Control Stack:\n"
653 cs <- cpu cstack
654 while: { not: (cs isInteger?) } do: {
655 print: "\t" . (cs car) . "\n"
656 cs <- cs cdr
657 }
658 }
659 if: command = "e" {
660 print: "Environment:\n"
661 env <- cpu environment
662 foreach: ((cpu environment) arr) :idx val {
663 print: "\t" . idx . ": " . val . "\n"
664 }
665 }
666 }
667 if: command = "c" {
668 cpu runMode
669 }
670 }
671 _cycles <- 0
605 #{ 672 #{
606 limit <- 3072 * 1000 673 limit <- 3072 * 1000
674 stepMode <- {
675 _stepMode? <- true
676 self
677 }
678 runMode <- {
679 _stepMode? <- false
680 self
681 }
682 breakFun <- _breakFun
683
684 pc <- { _pc }
685 dstack <- { dataStack }
686 cstack <- { controlStack }
687 environment <- { _curEnv }
688 cycles <- { _cycles }
689
607 run <- { 690 run <- {
608 cycles <- 0 691 _cycles <- 0
692 controlStack <- cons: stop 0
609 status <- _dummy 693 status <- _dummy
610 while: { (not: (status isError?)) && (not: (status isStop?)) } do: { 694 while: { (not: (status isError?)) && (not: (status isStop?)) } do: {
611 oldpc <- pc 695 if: _stepMode? {
612 if: (cycles >= limit) { 696 break <- breakFun
697 break: self
698 }
699 if: (_cycles >= limit) {
613 status <- error: "cycle limit of " . limit . " exceeded" 700 status <- error: "cycle limit of " . limit . " exceeded"
614 } else: { 701 } else: {
615 if: (pc >= (code length)) { 702 if: (_pc >= (code length)) {
616 status <- error: "PC walked off end of program" 703 status <- error: "PC walked off end of program"
617 } else: { 704 } else: {
618 inst <- code get: pc 705 inst <- code get: _pc
619 pc <- -1 706 _pc <- _pc + 1
620 status <- inst: 707 status <- inst:
621 if: pc = -1 { 708 _cycles <- _cycles + 1
622 pc <- oldpc + 1 709 }
623 } 710 }
624 cycles <- cycles + 1 711 }
625 }
626 }
627 }
628 print: "Status: " . (status tag) . "\n"
629 if: (status isStop?) { 712 if: (status isStop?) {
630 if: (dataStack empty?) { 713 if: (dataStack empty?) {
631 _dummy 714 _dummy
632 } else: { 715 } else: {
633 pop: 716 pop:
664 if: (args length) > 1 { 747 if: (args length) > 1 {
665 f <- file open: (args get: 1) 748 f <- file open: (args get: 1)
666 if: (f fd) >= 0 { 749 if: (f fd) >= 0 {
667 code <- parseFile: f 750 code <- parseFile: f
668 cpu <- new: code 751 cpu <- new: code
752 if: (args length) > 2 {
753 cpu stepMode
754 }
669 res <- cpu run 755 res <- cpu run
670 print: "Returned value of type: " . (res tag) . "\n" 756 print: "Ran for " . (cpu cycles) . " cycles\n"
671 if: (res isError?) { 757 print: "Returned value of type: " . (getTag: res) . " - value: " . res . "\n"
672 print: (res msg) . "\n"
673 }
674 0 758 0
675 } else: { 759 } else: {
676 (file stderr) write: "Failed to open " . (args get: 1) . " for reading\n" 760 (file stderr) write: "Failed to open " . (args get: 1) . " for reading\n"
677 1 761 1
678 } 762 }