1;;============================================================================ 2 3;;; File: "_t-univ-1.scm" 4 5;;; Copyright (c) 2011-2018 by Marc Feeley, All Rights Reserved. 6;;; Copyright (c) 2012 by Eric Thivierge, All Rights Reserved. 7 8(include "generic.scm") 9 10(include-adt "_envadt.scm") 11(include-adt "_gvmadt.scm") 12(include-adt "_ptreeadt.scm") 13(include-adt "_sourceadt.scm") 14(include-adt "_univadt.scm") 15 16;;---------------------------------------------------------------------------- 17 18(define deb #t) 19(set! deb #f) 20(define (tt tag . stuff) (if deb (list "/*{" tag "*/" stuff "/*}*/") stuff));;;;;;;;;;;;;;;;;;;; 21 22(define univ-enable-jump-destination-inlining? #f) 23(set! univ-enable-jump-destination-inlining? #t) 24 25(define univ-dyn-load? #f) 26(set! univ-dyn-load? #f) 27 28(define (univ-get-semantics-changing-option ctx name) 29 (let ((x (assq name (ctx-semantics-changing-options ctx)))) 30 (and x (pair? (cdr x)) (cadr x)))) 31 32(define (univ-module-representation ctx) 33 (or (univ-get-semantics-changing-option ctx 'repr-module) 34 (case (target-name (ctx-target ctx)) 35 ((java) 36 'class) 37 (else 38 'global)))) 39 40(define (univ-procedure-representation ctx) 41 (or (univ-get-semantics-changing-option ctx 'repr-procedure) 42 (case (target-name (ctx-target ctx)) 43 ((java) 44 'class) 45 ((php) 46 (if (univ-php-pre53? ctx) 47 'class 48 'host)) 49 (else 50 'host)))) 51 52(define (univ-frame-representation ctx) 53 (or (univ-get-semantics-changing-option ctx 'repr-frame) 54 (case (target-name (ctx-target ctx)) 55 ((java) 56 'class) 57 (else 58 'host)))) 59 60(define (univ-null-representation ctx) 61 (or (univ-get-semantics-changing-option ctx 'repr-null) 62 (case (target-name (ctx-target ctx)) 63 ((js) 64 'host) 65 (else 66 'class)))) 67 68(define (univ-void-representation ctx) 69 (or (univ-get-semantics-changing-option ctx 'repr-void) 70 'host)) 71 72(define (univ-eof-representation ctx) 73 'class) 74 75(define (univ-absent-representation ctx) 76 'class) 77 78(define (univ-deleted-representation ctx) 79 'class) 80 81(define (univ-unused-representation ctx) 82 'class) 83 84(define (univ-unbound-representation ctx) 85 'class) 86 87(define (univ-optional-representation ctx) 88 'class) 89 90(define (univ-key-representation ctx) 91 'class) 92 93(define (univ-rest-representation ctx) 94 'class) 95 96(define (univ-boolean-representation ctx) 97 (or (univ-get-semantics-changing-option ctx 'repr-boolean) 98 (case (target-name (ctx-target ctx)) 99 ((java) 100 'class) 101 (else 102 'host)))) 103 104(define (univ-char-representation ctx) 105 'class) 106 107(define (univ-fixnum-representation ctx) 108 (or (univ-get-semantics-changing-option ctx 'repr-fixnum) 109 (case (target-name (ctx-target ctx)) 110 ((java) 111 'class) 112 (else 113 'host)))) 114 115(define (univ-flonum-representation ctx) 116 (or (univ-get-semantics-changing-option ctx 'repr-flonum) 117 'class)) 118 119(define (univ-vector-representation ctx) 120 (or (univ-get-semantics-changing-option ctx 'repr-vector) 121 (case (target-name (ctx-target ctx)) 122 ((php java) 123 'class) 124 (else 125 'host)))) 126 127(define (univ-values-representation ctx) 128 (or (univ-get-semantics-changing-option ctx 'repr-values) 129 'class)) 130 131(define (univ-u8vector-representation ctx) 132 (or (univ-get-semantics-changing-option ctx 'repr-u8vector) 133 'class)) 134 135(define (univ-u16vector-representation ctx) 136 (or (univ-get-semantics-changing-option ctx 'repr-u16vector) 137 'class)) 138 139(define (univ-u32vector-representation ctx) 140 (or (univ-get-semantics-changing-option ctx 'repr-u32vector) 141 'class)) 142 143(define (univ-u64vector-representation ctx) 144 (or (univ-get-semantics-changing-option ctx 'repr-u64vector) 145 'class)) 146 147(define (univ-s8vector-representation ctx) 148 (or (univ-get-semantics-changing-option ctx 'repr-s8vector) 149 'class)) 150 151(define (univ-s16vector-representation ctx) 152 (or (univ-get-semantics-changing-option ctx 'repr-s16vector) 153 'class)) 154 155(define (univ-s32vector-representation ctx) 156 (or (univ-get-semantics-changing-option ctx 'repr-s32vector) 157 'class)) 158 159(define (univ-s64vector-representation ctx) 160 (or (univ-get-semantics-changing-option ctx 'repr-s64vector) 161 'class)) 162 163(define (univ-f32vector-representation ctx) 164 (or (univ-get-semantics-changing-option ctx 'repr-f32vector) 165 'class)) 166 167(define (univ-f64vector-representation ctx) 168 (or (univ-get-semantics-changing-option ctx 'repr-f64vector) 169 'class)) 170 171(define (univ-structure-representation ctx) 172 'class) 173 174(define (univ-string-representation ctx) 175 (or (univ-get-semantics-changing-option ctx 'repr-string) 176 'class)) 177 178(define (univ-symbol-representation ctx) 179 (or (univ-get-semantics-changing-option ctx 'repr-symbol) 180 'class)) 181 182(define (univ-keyword-representation ctx) 183 'class) 184 185(define (univ-tostr-method-name ctx) 186 (case (target-name (ctx-target ctx)) 187 188 ((js java) 189 'toString) 190 191 ((php) 192 '__toString) 193 194 ((python) 195 '__str__) 196 197 ((ruby) 198 'to_s) 199 200 (else 201 (compiler-internal-error 202 "univ-tostr-method-name, unknown target")))) 203 204(define (univ-proc-name-attrib ctx) 205 (case (target-name (ctx-target ctx)) 206 207 ((js) 208 '_name) ;; avoid clash with builtin "name" attribute of functions 209 210 (else 211 'name))) 212 213(define (univ-ns-prefix sem-changing-options) 214 (let ((x (assq 'namespace sem-changing-options))) 215 (or (and x (pair? (cdr x)) (cadr x)) 216 "g_"))) 217 218(define (univ-ns-prefix-class sem-changing-options) 219 (let ((ns (univ-ns-prefix sem-changing-options))) 220 (if (= (string-length ns) 0) 221 ns 222 (let ((lst (string->list ns))) 223 (list->string (cons (char-upcase (car lst)) (cdr lst))))))) 224 225(define univ-thread-cont-slot 21) 226(define univ-thread-denv-slot 22) 227 228(define (univ-php-pre53? ctx) 229 (assq 'pre53 (ctx-semantics-changing-options ctx))) 230 231(define (univ-python-pre3? ctx) 232 (assq 'pre3 (ctx-semantics-changing-options ctx))) 233 234(define (univ-java-pre7? ctx) 235 (assq 'pre7 (ctx-semantics-changing-options ctx))) 236 237(define (univ-always-return-jump? ctx) 238 (assq 'always-return-jump (ctx-semantics-preserving-options ctx))) 239 240(define (univ-never-return-jump? ctx) 241 (assq 'never-return-jump (ctx-semantics-preserving-options ctx))) 242 243(define (univ-stack-resizable? ctx) 244 (case (target-name (ctx-target ctx)) 245 ((java) #f) 246 (else #t))) 247 248(define univ-tag-bits 2) 249(define univ-word-bits 32) 250 251(define univ-fixnum-max+1 252 (arithmetic-shift 1 (- univ-word-bits (+ 1 univ-tag-bits)))) 253 254(define univ-fixnum-max (- univ-fixnum-max+1 1)) 255(define univ-fixnum-min (- -1 univ-fixnum-max)) 256(define univ-fixnum-max*2+1 (+ (* univ-fixnum-max 2) 1)) 257 258;;;---------------------------------------------------------------------------- 259;; 260;; "Universal" back-end. 261 262;; Initialization/finalization of back-end. 263 264(define (univ-setup 265 target-language 266 file-extensions 267 semantics-changing-options 268 semantics-preserving-options) 269 270 (define common-semantics-changing-options 271 '((repr-module symbol) 272 (repr-procedure symbol) 273 (repr-frame symbol) 274 (repr-null symbol) 275 (repr-void symbol) 276 (repr-boolean symbol) 277 (repr-fixnum symbol) 278 (repr-flonum symbol) 279 (repr-vector symbol) 280 (repr-u8vector symbol) 281 (repr-u16vector symbol) 282 (repr-u32vector symbol) 283 (repr-u64vector symbol) 284 (repr-s8vector symbol) 285 (repr-s16vector symbol) 286 (repr-s32vector symbol) 287 (repr-s64vector symbol) 288 (repr-f32vector symbol) 289 (repr-f64vector symbol) 290 (repr-values symbol) 291 (repr-string symbol) 292 (repr-symbol symbol) 293 (namespace string))) 294 295 (define common-semantics-preserving-options 296 '((always-return-jump) 297 (never-return-jump))) 298 299 (let ((targ 300 (make-target 12 301 target-language 302 file-extensions 303 (append semantics-changing-options 304 common-semantics-changing-options) 305 (append semantics-preserving-options 306 common-semantics-preserving-options) 307 0))) 308 309 (define (begin! sem-changing-opts 310 sem-preserving-opts 311 info-port) 312 313 (target-dump-set! 314 targ 315 (lambda (procs output c-intf module-descr linker-name) 316 (univ-dump targ 317 procs 318 output 319 c-intf 320 module-descr 321 linker-name 322 sem-changing-opts 323 sem-preserving-opts))) 324 325 (target-link-info-set! 326 targ 327 (lambda (file) 328 (univ-link-info targ file))) 329 330 (target-link-set! 331 targ 332 (lambda (extension? inputs output linker-name warnings?) 333 (univ-link targ extension? inputs output linker-name warnings?))) 334 335 (target-prim-info-set! 336 targ 337 (lambda (name) 338 (univ-prim-info targ name))) 339 340 (target-frame-constraints-set! 341 targ 342 (make-frame-constraints univ-frame-reserve univ-frame-alignment)) 343 344 (target-proc-result-set! 345 targ 346 (make-reg 1)) 347 348 (target-task-return-set! 349 targ 350 (make-reg 0)) 351 352 (target-switch-testable?-set! 353 targ 354 (lambda (obj) 355 (univ-switch-testable? targ obj))) 356 357 (target-eq-testable?-set! 358 targ 359 (lambda (obj) 360 (univ-eq-testable? targ obj))) 361 362 (target-object-type-set! 363 targ 364 (lambda (obj) 365 (univ-object-type targ obj))) 366 367 (univ-set-nb-regs targ sem-changing-opts) 368 369 #f) 370 371 (define (end!) 372 #f) 373 374 (target-begin!-set! targ begin!) 375 (target-end!-set! targ end!) 376 (target-add targ))) 377 378(univ-setup 'js '((".js" . JavaScript)) '() '()) 379(univ-setup 'python '((".py" . Python)) '((pre3)) '()) 380(univ-setup 'ruby '((".rb" . Ruby)) '() '()) 381(univ-setup 'php '((".php" . PHP)) '((pre53)) '()) 382 383(univ-setup 'java '((".java" . Java)) '((pre7)) '()) 384;;(univ-setup 'c '((".c" . C)) '() '()) 385;;(univ-setup 'c++ '((".cc" . C++)) '() '()) 386;;(univ-setup 'objc '((".m" . Objective-C)) '() '()) 387 388;;;---------------------------------------------------------------------------- 389 390;; ***** REGISTERS AVAILABLE 391 392;; The registers available in the virtual machine default to 393;; univ-default-nb-gvm-regs and univ-default-nb-arg-regs but can be 394;; changed with the gsc options -nb-gvm-regs and -nb-arg-regs. 395;; 396;; nb-gvm-regs = total number of registers available 397;; nb-arg-regs = maximum number of arguments passed in registers 398 399(define univ-default-nb-gvm-regs 5) 400(define univ-default-nb-arg-regs 3) 401 402(define (univ-nb-gvm-regs ctx) (target-nb-regs (ctx-target ctx))) 403(define (univ-nb-arg-regs ctx) (target-nb-arg-regs (ctx-target ctx))) 404 405(define (univ-set-nb-regs targ sem-changing-opts) 406 (let ((nb-gvm-regs 407 (get-option sem-changing-opts 408 'nb-gvm-regs 409 univ-default-nb-gvm-regs)) 410 (nb-arg-regs 411 (get-option sem-changing-opts 412 'nb-arg-regs 413 univ-default-nb-arg-regs))) 414 415 (if (not (and (<= 3 nb-gvm-regs) 416 (<= nb-gvm-regs 25))) 417 (compiler-error "-nb-gvm-regs option must be between 3 and 25")) 418 419 (if (not (and (<= 1 nb-arg-regs) 420 (<= nb-arg-regs (- nb-gvm-regs 2)))) 421 (compiler-error 422 (string-append "-nb-arg-regs option must be between 1 and " 423 (number->string (- nb-gvm-regs 2))))) 424 425 (target-nb-regs-set! targ nb-gvm-regs) 426 (target-nb-arg-regs-set! targ nb-arg-regs))) 427 428;;;---------------------------------------------------------------------------- 429 430;; Generation of textual target code. 431 432(define (univ-indent . rest) 433 (cons '$$indent$$ rest)) 434 435(define (univ-constant val) 436 (univ-box val val)) 437 438(define (univ-box boxed unboxed) 439 (list '$$box$$ boxed unboxed)) 440 441(define (univ-box? x) 442 (and (pair? x) 443 (eq? (car x) '$$box$$))) 444 445(define (univ-unbox x) 446 (and (univ-box? x) 447 (cddr x))) 448 449(define (univ-display x port) 450 451 (define indent-level 0) 452 (define after-newline? #t) 453 454 (define (indent) 455 (if after-newline? 456 (begin 457 (display (make-string (* 2 indent-level) #\space) port) 458 (set! after-newline? #f)))) 459 460 (define (disp x) 461 462 (cond ((string? x) 463 (let loop1 ((i 0)) 464 (let loop2 ((j i)) 465 466 (define (display-substring limit) 467 (if (< i limit) 468 (begin 469 (if (or (> (- limit i) 1) 470 (not (char=? (string-ref x (- limit 1)) 471 #\newline))) 472 (indent)) 473 (if (and (= i 0) (= limit (string-length x))) 474 (display x port) 475 (display (substring x i limit) port))))) 476 477 (if (< j (string-length x)) 478 479 (let ((c (string-ref x j)) 480 (j+1 (+ j 1))) 481 (if (char=? c #\newline) 482 (begin 483 (display-substring j+1) 484 (set! after-newline? #t) 485 (loop1 j+1)) 486 (loop2 j+1))) 487 488 (display-substring j))))) 489 490 ((symbol? x) 491 (disp (symbol->string x))) 492 493 ((char? x) 494 (disp (string x))) 495 496 ((null? x)) 497 498 ((pair? x) 499 (case (car x) 500 (($$indent$$) 501 (set! indent-level (+ indent-level 1)) 502 (disp (cdr x)) 503 (set! indent-level (- indent-level 1))) 504 (($$box$$) 505 (disp (cadr x))) 506 (else 507 (disp (car x)) 508 (disp (cdr x))))) 509 510 ((vector? x) 511 (disp (vector->list x))) 512 513 (else 514 (indent) 515 (display x port)))) 516 517 (disp x)) 518 519(define (univ-display-to-file x path) 520 (let ((port (open-output-file-preserving-case path))) 521 (univ-display x port) 522 (close-output-port port))) 523 524;;;---------------------------------------------------------------------------- 525 526;; The frame constraints are defined by the parameters 527;; univ-frame-reserve and univ-frame-alignment. 528 529(define univ-frame-reserve 0) ;; no extra slots reserved 530(define univ-frame-alignment 1) ;; no alignment constraint 531 532;;;---------------------------------------------------------------------------- 533 534;; ***** PRIMITIVE PROCEDURE DATABASE 535 536(define univ-prim-proc-table 537 (let ((t (make-prim-proc-table))) 538 (for-each 539 (lambda (x) (prim-proc-add! t x)) 540 '(("##inline-host-statement" 1 #t 0 0 (#f) extended) 541 ("##inline-host-expression" 1 #t 0 0 (#f) extended) 542 ("##inline-host-declaration" (1) #t 0 0 (#f) extended) 543 ("##univ-table-make-hashtable" (2) #t 0 0 (#f) extended) 544 ("##univ-table-key-exists?" (2) #f 0 0 boolean extended) 545 ("##univ-table-keys" (1) #f 0 0 (#f) extended) 546 ("##univ-table-ref" (2) #f 0 0 (#f) extended) 547 ("##univ-table-set!" (3) #t 0 0 (#f) extended) 548 ("##univ-table-delete" (2) #f 0 0 (#f) extended) 549 ("##univ-table-length" (1) #f 0 0 number extended))) 550 t)) 551 552(define (univ-prim-info targ name) 553 (univ-prim-info* name)) 554 555(define (univ-prim-info* name) 556 (prim-proc-info univ-prim-proc-table name)) 557 558;;;---------------------------------------------------------------------------- 559 560;; ***** OBJECT PROPERTIES 561 562(define (univ-switch-testable? targ obj) 563 ;;(pretty-print (list 'univ-switch-testable? 'targ obj)) 564 #f);;;;;;;;;;;;;;;;;;;;;;;;;;;; 565 566(define (univ-eq-testable? targ obj) 567 ;;(pretty-print (list 'univ-eq-testable? 'targ obj)) 568 #f);;;;;;;;;;;;;;;;;;;;;;;;;;; 569 570(define (univ-object-type targ obj) 571 ;;(pretty-print (list 'univ-object-type 'targ obj)) 572 'bignum);;;;;;;;;;;;;;;;;;;;;;;;; 573 574;;;---------------------------------------------------------------------------- 575 576(define (univ-emit-popcount! ctx arg) 577 578 (define (popcount arg acc len) 579 (if (>= len univ-word-bits) 580 (^ acc 581 (^assign arg (^bitand arg (^int #x0000003F)))) 582 (popcount 583 arg 584 (^ acc 585 (case len 586 ((1) 587 (^assign arg (^- arg 588 (^parens (^bitand (^parens (^>> arg (^int 1))) 589 (^int #x55555555)))))) 590 ((2) 591 (^assign arg (^+ (^parens (^bitand arg (^int #x33333333))) 592 (^parens (^bitand (^parens (^>> arg (^int 2))) 593 (^int #x33333333)))))) 594 ((4) 595 (^assign arg (^bitand (^parens (^+ arg (^parens (^>> arg (^int 4))))) 596 (^int #x0F0F0F0F)))) 597 (else 598 (^assign arg (^+ arg (^parens (^>> arg len))))))) 599 (* len 2)))) 600 601 (popcount arg 602 (^assign arg (^bitand arg (^int univ-fixnum-max*2+1))) 603 1)) 604 605(define (univ-emit-map ctx fn array) 606 (case (target-name (ctx-target ctx)) 607 608 ((js) 609 (^ array ".map( " fn " )")) 610 611 ((php) 612 (^ "array_map( '" fn "', " array ")")) 613 614 ((python) 615 (^ "map( "fn ", " array " )")) 616 617 ((ruby) 618 (^ array ".map { |x| " fn "(x) } " )) 619 620 (else 621 (compiler-internal-error 622 "univ-emit-map, unknown target")))) 623 624(define (univ-emit-call-with-arg-array ctx fn array) 625 (case (target-name (ctx-target ctx)) 626 627 ((js) 628 (^ fn ".apply( null, " array " )")) 629 630 ((php) 631 (^ "call_user_func_array( " fn ", " array " )")) 632 633 ((python) 634 (^ fn "( *" array " )")) 635 636 ((ruby) 637 (^ fn ".( *" array " )")) 638 639 (else 640 (compiler-internal-error 641 "univ-emit-call-with-arg-array, unknown target")))) 642 643(define (univ-emit-var-declaration ctx type name #!optional (init #f)) 644 (case (target-name (ctx-target ctx)) 645 646 ((js) 647 (^ "var " name (if init (^ " = " init) (^)) ";\n")) 648 649 ((python ruby) 650 (^ name " = " (or init (^obj #f)) "\n")) 651 652 ((php) 653 (^ name " = " (or init (^obj #f)) ";\n")) 654 655 ((java) 656 (^ (^decl type name) (if init (^ " = " init) (^)) ";\n")) 657 658 (else 659 (compiler-internal-error 660 "univ-emit-var-declaration, unknown target")))) 661 662(define (univ-emit-expr-statement ctx expr) 663 (case (target-name (ctx-target ctx)) 664 665 ((js php java) 666 (^ expr ";\n")) 667 668 ((python ruby) 669 (^ expr "\n")) 670 671 (else 672 (compiler-internal-error 673 "univ-emit-expr-statement, unknown target")))) 674 675(define (univ-emit-if ctx test true #!optional (false #f)) 676 (case (target-name (ctx-target ctx)) 677 678 ((js php java) 679 (^ "if (" test ") {\n" 680 (univ-indent true) 681 (if false 682 (^ "} else {\n" 683 (univ-indent false)) 684 (^)) 685 "}\n")) 686 687 ((python) 688 (^ "if " test ":\n" 689 (univ-indent true) 690 (if false 691 (^ "else:\n" 692 (univ-indent false)) 693 (^)))) 694 695 ((ruby) 696 (^ "if " test "\n" 697 (univ-indent true) 698 (if false 699 (^ "else\n" 700 (univ-indent false)) 701 (^)) 702 "end\n")) 703 704 (else 705 (compiler-internal-error 706 "univ-emit-if, unknown target")))) 707 708(define (univ-emit-if-expr ctx expr1 expr2 expr3) 709 (case (target-name (ctx-target ctx)) 710 711 ((js ruby java) 712 (^ expr1 " ? " expr2 " : " expr3)) 713 714 ((php) 715 (^parens (^ expr1 " ? " expr2 " : " expr3))) 716 717 ((python) 718 (^ expr2 " if " expr1 " else " expr3)) 719 720 (else 721 (compiler-internal-error 722 "univ-emit-if-expr, unknown target")))) 723 724(define (univ-emit-while ctx test body) 725 (case (target-name (ctx-target ctx)) 726 727 ((js php java) 728 (^ "while (" test ") {\n" 729 (univ-indent body) 730 "}\n")) 731 732 ((python) 733 (^ "while " test ":\n" 734 (univ-indent body))) 735 736 ((ruby) 737 (^ "while " test "\n" 738 (univ-indent body) 739 "end\n")) 740 741 (else 742 (compiler-internal-error 743 "univ-emit-while, unknown target")))) 744 745(define (univ-emit-eq? ctx expr1 expr2) 746 (case (target-name (ctx-target ctx)) 747 748 ((js php) 749 (^ expr1 " === " expr2)) 750 751 ((python) 752 (^ expr1 " is " expr2)) 753 754 ((ruby) 755 (^ expr1 ".equal?(" expr2 ")")) 756 757 ((java) 758 (^ expr1 " == " expr2)) 759 760 (else 761 (compiler-internal-error 762 "univ-emit-eq?, unknown target")))) 763 764(define (univ-emit-+ ctx expr1 #!optional (expr2 #f)) 765 (case (target-name (ctx-target ctx)) 766 767 ((js php python ruby java) 768 (if expr2 769 (^ expr1 " + " expr2) 770 (^ "+ " expr1))) 771 772 (else 773 (compiler-internal-error 774 "univ-emit-+, unknown target")))) 775 776(define (univ-emit-- ctx expr1 #!optional (expr2 #f)) 777 (case (target-name (ctx-target ctx)) 778 779 ((js php python ruby java) 780 (if expr2 781 (^ expr1 " - " expr2) 782 (^ "- " expr1))) 783 784 (else 785 (compiler-internal-error 786 "univ-emit--, unknown target")))) 787 788(define (univ-emit-* ctx expr1 expr2) 789 (case (target-name (ctx-target ctx)) 790 791 ((js php python ruby java) 792 (^ expr1 " * " expr2)) 793 794 (else 795 (compiler-internal-error 796 "univ-emit-*, unknown target")))) 797 798(define (univ-emit-/ ctx expr1 expr2) 799 (case (target-name (ctx-target ctx)) 800 801 ((js php python ruby java) 802 (^ expr1 " / " expr2)) 803 804 (else 805 (compiler-internal-error 806 "univ-emit-/, unknown target")))) 807 808(define (univ-wrap ctx expr) 809 (case (target-name (ctx-target ctx)) 810 811 ((js java) 812 (^>> (^<< (^parens expr) 813 (^int univ-tag-bits)) 814 (^int univ-tag-bits))) 815 816 ((python) 817 (^>> (^member (^call-prim 818 "ctypes.c_int32" 819 (^<< (^parens expr) 820 (^int univ-tag-bits))) 821 'value) 822 (^int univ-tag-bits))) 823 824 ((ruby php) 825 (^- (^parens (^bitand (^parens (^+ (^parens expr) 826 (^int univ-fixnum-max+1))) 827 (^int univ-fixnum-max*2+1))) 828 (^int univ-fixnum-max+1))) 829 830 (else 831 (compiler-internal-error 832 "univ-wrap, unknown target")))) 833 834(define (univ-wrap+ ctx expr1 expr2) 835 (univ-wrap ctx (^+ expr1 expr2))) 836 837(define (univ-wrap- ctx expr1 #!optional (expr2 #f)) 838 (univ-wrap ctx (if expr2 839 (^- expr1 expr2) 840 (^- expr1)))) 841 842(define (univ-wrap* ctx expr1 expr2) 843 (case (target-name (ctx-target ctx)) 844 845 ((js) 846 (univ-wrap ctx 847 (^+ (^* (^parens (^bitand expr1 #xffff)) 848 expr2) 849 (^* (^parens (^bitand expr1 #xffff0000)) 850 (^parens (^bitand expr2 #xffff)))))) 851 852 ((php python ruby java) 853 (univ-wrap ctx (^* expr1 expr2))) 854 855 (else 856 (compiler-internal-error 857 "univ-wrap*, unknown target")))) 858 859(define (univ-wrap/ ctx expr1 expr2) 860 (case (target-name (ctx-target ctx)) 861 862 ((python php ruby) 863 ;; The default behavior is to round down, but it should round toward 0 864 (univ-wrap ctx (^float-toint (^parens (^/ expr1 (^float-fromint expr2)))))) 865 866 (else (univ-wrap ctx (^/ expr1 expr2))))) 867 868(define (univ-emit-<< ctx expr1 expr2) 869 (case (target-name (ctx-target ctx)) 870 871 ((js php python ruby java) 872 (^ expr1 " << " expr2)) 873 874 (else 875 (compiler-internal-error 876 "univ-emit-<<, unknown target")))) 877 878(define (univ-emit->> ctx expr1 expr2) 879 (case (target-name (ctx-target ctx)) 880 881 ((js php python ruby java) 882 (^ expr1 " >> " expr2)) 883 884 (else 885 (compiler-internal-error 886 "univ-emit->>, unknown target")))) 887 888(define (univ-emit->>> ctx expr1 expr2) 889 (case (target-name (ctx-target ctx)) 890 891 ((js java) 892 (^ expr1 " >>> " expr2)) 893 894 ((python ruby php) 895 ;; These targets don't need >>>, but just in case... 896 (^bitand 897 (^>> expr1 898 expr2) 899 (^- (^parens 900 (^<< (^int 1) 901 (^- (^int univ-word-bits) expr2))) 902 (^int 1)))) 903 904 (else 905 (compiler-internal-error 906 "univ-emit->>>, unknown target")))) 907 908(define (univ-emit-bitnot ctx expr) 909 (case (target-name (ctx-target ctx)) 910 911 ((js php python ruby java) 912 (^ "~ " expr)) 913 914 (else 915 (compiler-internal-error 916 "univ-emit-bitnot, unknown target")))) 917 918(define (univ-emit-bitand ctx expr1 expr2) 919 (case (target-name (ctx-target ctx)) 920 921 ((js php python ruby java) 922 (^ expr1 " & " expr2)) 923 924 (else 925 (compiler-internal-error 926 "univ-emit-bitand, unknown target")))) 927 928(define (univ-emit-bitior ctx expr1 expr2) 929 (case (target-name (ctx-target ctx)) 930 931 ((js php python ruby java) 932 (^ expr1 " | " expr2)) 933 934 (else 935 (compiler-internal-error 936 "univ-emit-bitior, unknown target")))) 937 938(define (univ-emit-bitxor ctx expr1 expr2) 939 (case (target-name (ctx-target ctx)) 940 941 ((js php python ruby java) 942 (^ expr1 " ^ " expr2)) 943 944 (else 945 (compiler-internal-error 946 "univ-emit-bitxor, unknown target")))) 947 948(define (univ-emit-= ctx expr1 expr2) 949 (case (target-name (ctx-target ctx)) 950 951 ((js) 952 (^ expr1 " === " expr2)) 953 954 ((python ruby php java) 955 (^ expr1 " == " expr2)) 956 957 (else 958 (compiler-internal-error 959 "univ-emit-=, unknown target")))) 960 961(define (univ-emit-!= ctx expr1 expr2) 962 (case (target-name (ctx-target ctx)) 963 964 ((js) 965 (^ expr1 " !== " expr2)) 966 967 ((python ruby php java) 968 (^ expr1 " != " expr2)) 969 970 (else 971 (compiler-internal-error 972 "univ-emit-!=, unknown target")))) 973 974(define (univ-emit-< ctx expr1 expr2) 975 (univ-emit-comparison ctx " < " expr1 expr2)) 976 977(define (univ-emit-<= ctx expr1 expr2) 978 (univ-emit-comparison ctx " <= " expr1 expr2)) 979 980(define (univ-emit-> ctx expr1 expr2) 981 (univ-emit-comparison ctx " > " expr1 expr2)) 982 983(define (univ-emit->= ctx expr1 expr2) 984 (univ-emit-comparison ctx " >= " expr1 expr2)) 985 986(define (univ-emit-comparison ctx comp expr1 expr2) 987 (case (target-name (ctx-target ctx)) 988 989 ((js python ruby php java) 990 (^ expr1 comp expr2)) 991 992 (else 993 (compiler-internal-error 994 "univ-emit-comparison, unknown target")))) 995 996(define (univ-emit-not ctx expr) 997 (case (target-name (ctx-target ctx)) 998 999 ((js php ruby java) 1000 (^ "!" expr)) 1001 1002 ((python) 1003 (^ "not " expr)) 1004 1005 (else 1006 (compiler-internal-error 1007 "univ-emit-not, unknown target")))) 1008 1009(define (univ-emit-&& ctx expr1 expr2) 1010 (case (target-name (ctx-target ctx)) 1011 1012 ((js ruby php java) 1013 (^ expr1 " && " expr2)) 1014 1015 ((python) 1016 (^ expr1 " and " expr2)) 1017 1018 (else 1019 (compiler-internal-error 1020 "univ-emit-&&, unknown target")))) 1021 1022(define (univ-emit-and ctx expr1 expr2) 1023 (case (target-name (ctx-target ctx)) 1024 1025 ((js ruby java) 1026 (^ expr1 " && " expr2)) 1027 1028 ((python) 1029 (^ expr1 " and " expr2)) 1030 1031 ((php) 1032 (^ expr1 " ? " expr2 " : false")) 1033 1034 (else 1035 (compiler-internal-error 1036 "univ-emit-and, unknown target")))) 1037 1038(define (univ-emit-or ctx expr1 expr2) 1039 (case (target-name (ctx-target ctx)) 1040 1041 ((js ruby php java) 1042 (^ expr1 " || " expr2)) ;; TODO: PHP || operator always yields a boolean 1043 1044 ((python) 1045 (^ expr1 " or " expr2)) 1046 1047 (else 1048 (compiler-internal-error 1049 "univ-emit-or, unknown target")))) 1050 1051(define (univ-emit-concat ctx expr1 expr2) 1052 (case (target-name (ctx-target ctx)) 1053 1054 ((js python ruby java) 1055 (^ expr1 " + " expr2)) 1056 1057 ((php) 1058 (^ expr1 " . " expr2)) 1059 1060 (else 1061 (compiler-internal-error 1062 "univ-emit-concat, unknown target")))) 1063 1064(define (univ-emit-tostr ctx expr) 1065 (case (target-name (ctx-target ctx)) 1066 1067 ((js java) 1068 (^ expr ".toString()")) 1069 1070 ((python) 1071 (^ "str(" expr ")")) 1072 1073 ((php) 1074 (^ "(string)" expr)) 1075 1076 ((ruby) 1077 (^ expr ".to_s")) 1078 1079 (else 1080 (compiler-internal-error 1081 "univ-emit-tostr, unknown target")))) 1082 1083(define (univ-emit-cast ctx type expr) 1084 (^parens (^ (^parens type) (^parens expr)))) 1085 1086(define (univ-emit-cast* ctx type-name expr) 1087 (case (target-name (ctx-target ctx)) 1088 ((java) 1089 (^cast (^type type-name) expr)) 1090 (else 1091 expr))) 1092 1093(define (univ-emit-cast*-scmobj ctx expr) 1094 (^cast* 'scmobj expr)) 1095 1096(define (univ-emit-cast*-jumpable ctx expr) 1097 (^cast* 'jumpable expr)) 1098 1099(define (univ-emit-seq ctx expr1 expr2) 1100 (case (target-name (ctx-target ctx)) 1101 1102 ((js java) 1103 (^parens (^ expr1 " , " expr2))) 1104 1105 ((ruby) 1106 (^parens (^ expr1 " ; " expr2))) 1107 1108 (else 1109 (compiler-internal-error 1110 "univ-emit-seq, unknown target")))) 1111 1112(define (univ-emit-parens ctx expr) 1113 (case (target-name (ctx-target ctx)) 1114 1115 ((js ruby php python java) 1116 (^ "(" expr ")")) 1117 1118 (else 1119 (compiler-internal-error 1120 "univ-emit-parens, unknown target")))) 1121 1122(define (univ-emit-parens-php ctx expr) 1123 (if (eq? (target-name (ctx-target ctx)) 'php) 1124 (^parens expr) 1125 expr)) 1126 1127(define (univ-emit-local-var ctx name) 1128 (case (target-name (ctx-target ctx)) 1129 1130 ((js python ruby java) 1131 name) 1132 1133 ((php) 1134 (^ "$" name)) 1135 1136 (else 1137 (compiler-internal-error 1138 "univ-emit-local-var, unknown target")))) 1139 1140(define (univ-emit-global-var ctx name) 1141 (case (target-name (ctx-target ctx)) 1142 1143 ((js python java) 1144 name) 1145 1146 ((php ruby) 1147 (^ "$" name)) 1148 1149 (else 1150 (compiler-internal-error 1151 "univ-emit-global-var, unknown target")))) 1152 1153(define (univ-emit-global-function ctx name) 1154 (case (target-name (ctx-target ctx)) 1155 1156 ((js python java) 1157 name) 1158 1159 ((php ruby) name);;TODO: added 1160#; 1161 ((php ruby) 1162 (^ "$" name)) 1163 1164 (else 1165 (compiler-internal-error 1166 "univ-emit-global-function, unknown target")))) 1167 1168(define (univ-emit-this-mod-field ctx name) 1169 (^mod-field (ctx-module-name ctx) name)) 1170 1171(define (univ-emit-this-mod-method ctx name) 1172 (^mod-method (ctx-module-name ctx) name)) 1173 1174(define (univ-emit-this-mod-jumpable ctx name) 1175 (^mod-jumpable (ctx-module-name ctx) name)) 1176 1177(define (univ-emit-mod-member ctx mod-name name) 1178 (if (and (case (target-name (ctx-target ctx)) 1179 ((js) 1180 #f) 1181 ((python) 1182 (not (eq? (univ-module-representation ctx) 'class))) 1183 (else 1184 #t)) 1185 (eq? (ctx-module-name ctx) mod-name)) ;; optimize access to self 1186 name 1187 (case (target-name (ctx-target ctx)) 1188 1189 ((js python ruby java) 1190 (^member (^prefix-class mod-name) name)) 1191 1192 ((php) 1193 (^ (^prefix-class mod-name) "::" name)) 1194 1195 (else 1196 (compiler-internal-error 1197 "univ-emit-mod-member, unknown target"))))) 1198 1199(define (univ-emit-mod-field ctx mod-name name) 1200 (case (univ-module-representation ctx) 1201 1202 ((class) 1203 (tt"000"(univ-emit-mod-member ctx mod-name name))) 1204 1205 (else 1206 (tt"111"(^global-var (^prefix name)))))) 1207 1208(define (univ-emit-mod-method ctx mod-name name) 1209 (case (univ-module-representation ctx) 1210 1211 ((class) 1212 (tt"222"(univ-emit-mod-member ctx mod-name name))) 1213 1214 (else 1215 (tt"333"(^global-function (^prefix name)))))) 1216 1217(define (univ-mod-jumpable-is-field? ctx) 1218 (eq? (target-name (ctx-target ctx)) 'ruby)) 1219 1220(define (univ-emit-mod-jumpable ctx mod-name name) 1221 (if (eq? (univ-procedure-representation ctx) 'class) 1222 (let ((x (^mod-field mod-name name))) 1223 (use-global ctx x) 1224 x) 1225 (if (univ-mod-jumpable-is-field? ctx) 1226 (^mod-field mod-name name) 1227 (univ-method-reference 1228 ctx 1229 (^mod-method mod-name name))))) 1230 1231(define (univ-emit-mod-class ctx mod-name name) 1232 (case (univ-module-representation ctx) 1233 1234 ((class) 1235 (tt"444"(univ-emit-mod-member ctx mod-name name))) 1236 1237 (else 1238 (tt"555"(^prefix-class name))))) 1239 1240(define (univ-emit-rts-method ctx name) 1241 (case (univ-module-representation ctx) 1242 1243 ((class) 1244 (tt"666"name)) 1245 1246 (else 1247 (tt"777"(^global-function (^prefix name)))))) 1248 1249(define (univ-emit-rts-method-ref ctx name) 1250 (case (univ-module-representation ctx) 1251 1252 ((class) 1253 (tt"66"(univ-emit-mod-member ctx (univ-rts-module-name ctx) name))) 1254 1255 (else 1256 (tt"77"(^global-function (^prefix name)))))) 1257 1258(define (univ-emit-rts-method-use ctx name) 1259 (univ-use-rtlib ctx name) 1260 (univ-emit-rts-method-ref ctx name)) 1261 1262(define (univ-emit-rts-field ctx name) 1263 (case (univ-module-representation ctx) 1264 1265 ((class) 1266 (tt"888"name)) 1267 1268 (else 1269 (tt"999"(^global-var (^prefix name)))))) 1270 1271(define (univ-emit-rts-field-ref ctx name) 1272 (case (univ-module-representation ctx) 1273 1274 ((class) 1275 (tt"88"(univ-emit-mod-member ctx (univ-rts-module-name ctx) name))) 1276 1277 (else 1278 (tt"99"(^global-var (^prefix name)))))) 1279 1280(define (univ-emit-rts-field-use ctx name) 1281 (univ-use-rtlib ctx name) 1282 (let ((x (univ-emit-rts-field-ref ctx name))) 1283 (use-global ctx x) 1284 x)) 1285 1286(define (univ-emit-rts-jumpable-use ctx name) 1287 (univ-use-rtlib ctx name) 1288 (^mod-jumpable (univ-rts-module-name ctx) name)) 1289 1290(define (univ-emit-rts-class ctx name) 1291 (let ((real-name (univ-rts-type-alias ctx name))) 1292 (case (univ-module-representation ctx) 1293 1294 ((class) 1295 (tt"0"(univ-emit-mod-member ctx (univ-rts-module-name ctx) real-name))) 1296 1297 (else 1298 (tt"1"(^prefix-class real-name)))))) 1299 1300(define (univ-emit-rts-class-ref ctx name) 1301 (let ((real-name (univ-rts-type-alias ctx name))) 1302 (case (univ-module-representation ctx) 1303 1304 ((class) 1305 (tt"00"(univ-emit-mod-member ctx (univ-rts-module-name ctx) real-name))) 1306 1307 (else 1308 (tt"11"(^prefix-class real-name)))))) 1309 1310(define (univ-emit-rts-class-use ctx name) 1311 (univ-use-rtlib ctx name) 1312 (univ-emit-rts-class-ref ctx name)) 1313 1314(define (univ-rts-module-name ctx) 1315 (case (target-name (ctx-target ctx)) 1316 1317 ((js php python ruby java) 1318 "RTS") 1319 1320 (else 1321 (compiler-internal-error 1322 "univ-rts-module-name, unknown target")))) 1323 1324(define (univ-emit-prefix ctx name) 1325 (case (univ-module-representation ctx) 1326 1327 ((class) 1328 name) 1329 1330 (else 1331 (^ (ctx-ns-prefix ctx) name)))) 1332 1333(define (univ-emit-prefix-class ctx name) 1334 (case (univ-module-representation ctx) 1335 1336; ((class) 1337; name) 1338 1339 (else 1340 (^ (ctx-ns-prefix-class ctx) name)))) 1341 1342(define (univ-emit-assign-expr ctx loc expr) 1343 (^ loc " = " expr)) 1344 1345(define (univ-emit-assign ctx loc expr) 1346 (^expr-statement 1347 (^assign-expr loc expr))) 1348 1349(define (univ-emit-inc-by ctx loc expr #!optional (embed #f)) 1350 1351 (define (embed-read x) 1352 (if embed 1353 (embed x) 1354 (^))) 1355 1356 (define (embed-expr x parens?) 1357 (if embed 1358 (embed (if parens? (^parens x) x)) 1359 (^expr-statement x))) 1360 1361 (define (inc-general loc expr) 1362 (if (and (number? expr) (< expr 0)) 1363 (^ loc " -= " (- expr)) 1364 (^ loc " += " expr))) 1365 1366 (if (equal? expr 0) 1367 1368 (embed-read loc) 1369 1370 (case (target-name (ctx-target ctx)) 1371 1372 ((js php java) 1373 (cond ((equal? expr 1) 1374 (embed-expr (^ "++" loc) #f)) 1375 ((equal? expr -1) 1376 (embed-expr (^ "--" loc) #f)) 1377 (else 1378 (embed-expr (inc-general loc expr) 1379 (eq? (target-name (ctx-target ctx)) 'php))))) 1380 1381 ((python) 1382 (^ (^expr-statement (inc-general loc expr)) 1383 (embed-read loc))) 1384 1385 ((ruby) 1386 (embed-expr (inc-general loc expr) #t)) 1387 1388 (else 1389 (compiler-internal-error 1390 "univ-emit-inc-by, unknown target"))))) 1391 1392(define (univ-emit-alias ctx expr) 1393 (case (target-name (ctx-target ctx)) 1394 1395 ((js python ruby java) 1396 expr) 1397 1398 ((php) 1399 (^ "&" expr)) 1400 1401 (else 1402 (compiler-internal-error 1403 "univ-emit-alias, unknown target")))) 1404 1405(define (univ-emit-unalias ctx expr) 1406 (case (target-name (ctx-target ctx)) 1407 1408 ((js python ruby java) 1409 (^)) 1410 1411 ((php) 1412 (^expr-statement 1413 (^ "unset(" expr ")"))) 1414 1415 (else 1416 (compiler-internal-error 1417 "univ-emit-unalias, unknown target")))) 1418 1419(define (univ-emit-array? ctx expr) 1420 (case (target-name (ctx-target ctx)) 1421 1422 ((js ruby) 1423 (^instanceof "Array" expr)) 1424 1425 ((php) 1426 (^call-prim "is_array" expr)) 1427 1428 ((python) 1429 (^instanceof "list" expr)) 1430 1431 ((java) 1432 (^ expr ".getClass().isArray()")) 1433 1434 (else 1435 (compiler-internal-error 1436 "univ-emit-array?, unknown target")))) 1437 1438(define (univ-emit-array-length ctx expr) 1439 (case (target-name (ctx-target ctx)) 1440 1441 ((js ruby java) 1442 (^ expr ".length")) 1443 1444 ((php) 1445 (^ "count(" expr ")")) 1446 1447 ((python) 1448 (^ "len(" expr ")")) 1449 1450 (else 1451 (compiler-internal-error 1452 "univ-emit-array-length, unknown target")))) 1453 1454(define (univ-emit-array-shrink! ctx expr1 expr2) 1455 (case (target-name (ctx-target ctx)) 1456 1457 ((js) 1458 (^assign (^ expr1 ".length") expr2)) 1459 1460 ((php) 1461 (^expr-statement 1462 (^call-prim 'array_splice expr1 expr2))) 1463 1464 ((python) 1465 (^expr-statement 1466 (^ expr1 "[" expr2 ":] = []"))) 1467 1468 ((ruby) 1469 (^expr-statement 1470 (^ expr1 ".slice!(" expr2 "," expr1 ".length)"))) 1471 1472 ((java) 1473 ;; assumes expr1 is an lvalue, and creates a copy of the array 1474 (^assign expr1 (^subarray expr1 0 expr2))) 1475 1476 (else 1477 (compiler-internal-error 1478 "univ-emit-array-shrink!, unknown target")))) 1479 1480(define (univ-emit-array-shrink-possibly-copy! ctx expr1 expr2) 1481 (case (target-name (ctx-target ctx)) 1482 1483 ((js) 1484 (^seq 1485 (^assign-expr (^member expr1 'length) expr2) 1486 expr1)) 1487 1488 ((php) 1489 (^call-prim 'array_splice expr1 (^int 0) expr2)) 1490 1491 ((python java) 1492 (^subarray expr1 (^int 0) expr2)) 1493 1494 ((ruby) 1495 (^seq 1496 (^call-prim (^member expr1 'slice!) expr2 (^member expr1 'length)) 1497 expr1)) 1498 1499 (else 1500 (compiler-internal-error 1501 "univ-emit-array-shrink-possibly-copy!, unknown target")))) 1502 1503(define (univ-emit-move-array-to-array ctx array1 srcpos array2 destpos len) 1504 (case (target-name (ctx-target ctx)) 1505 1506 ((java) 1507 (^expr-statement 1508 (^call-prim 1509 (^member 'System 'arraycopy) 1510 array1 1511 srcpos 1512 array2 1513 destpos 1514 len))) 1515 1516 (else 1517 (compiler-internal-error 1518 "univ-emit-move-array-to-array, unknown target")))) 1519 1520(define (univ-emit-copy-array-to-extensible-array ctx expr len) 1521 (case (target-name (ctx-target ctx)) 1522 1523 ((js php ruby java) 1524 (^subarray expr 0 len)) 1525 1526 ((python) 1527 (^ "dict(zip(range(" len ")," expr "))")) 1528 1529 (else 1530 (compiler-internal-error 1531 "univ-emit-array-to-extensible-array, unknown target")))) 1532 1533(define (univ-emit-extensible-array-to-array! ctx var len) 1534 (case (target-name (ctx-target ctx)) 1535 1536 ((js php ruby java) 1537 (^)) 1538 1539 ((python) 1540 (^assign var (^ "[" var "[i] for i in range(" len ")]"))) 1541 1542 (else 1543 (compiler-internal-error 1544 "univ-emit-extensible-array-to-array!, unknown target")))) 1545 1546(define (univ-emit-extensible-subarray ctx expr start len) 1547 (case (target-name (ctx-target ctx)) 1548 1549 ((js ruby php java) (^subarray expr start len)) 1550 1551 ((python) 1552 (^ "[" expr "[i] for i in range(" 1553 (if (eq? start 0) 1554 len 1555 (^ start ", " (^+ start len))) 1556 ")]")) 1557 (else 1558 (compiler-internal-error 1559 "univ-emit-extensible-subarray, unknown target")))) 1560 1561(define (univ-emit-subarray ctx expr1 expr2 expr3) 1562 (case (target-name (ctx-target ctx)) 1563 1564 ((js) 1565 (^call-prim (^member expr1 'slice) 1566 expr2 1567 (if (equal? expr2 0) expr3 (^+ expr2 expr3)))) 1568 1569 ((php) 1570 (^call-prim 'array_slice expr1 expr2 expr3)) 1571 1572 ((python) 1573 (^ expr1 "[" expr2 ":" (if (equal? expr2 0) expr3 (^+ expr2 expr3)) "]")) 1574 1575 ((ruby) 1576 (^call-prim (^member expr1 'slice) 1577 expr2 1578 (if (equal? expr2 0) expr3 (^+ expr2 expr3)))) 1579 1580 ((java) 1581 (^call-prim (^member 'Arrays 'copyOfRange) 1582 expr1 1583 expr2 1584 (if (equal? expr2 0) expr3 (^+ expr2 expr3)))) 1585 1586 (else 1587 (compiler-internal-error 1588 "univ-emit-subarray, unknown target")))) 1589 1590(define (univ-emit-array-index ctx expr1 expr2) 1591 (^ expr1 "[" expr2 "]")) 1592 1593(define (univ-emit-prop-index ctx expr1 expr2 expr3) 1594 (if expr3 1595 (^if-expr (^prop-index-exists? expr1 expr2) 1596 (^prop-index expr1 expr2) 1597 expr3) 1598 (^ expr1 "[" expr2 "]"))) 1599 1600(define (univ-emit-prop-index-exists? ctx expr1 expr2) 1601 (case (target-name (ctx-target ctx)) 1602 1603 ((js) 1604 (^ "Object.prototype.hasOwnProperty.call(" expr1 "," expr2 ")")) 1605 1606 ((php) 1607 (^ "array_key_exists(" expr2 "," expr1 ")")) 1608 1609 ((python) 1610 (^ expr2 " in " expr1)) 1611 1612 ((ruby) 1613 (^ expr1 ".has_key?(" expr2 ")")) 1614 1615 (else 1616 (compiler-internal-error 1617 "univ-emit-prop-index-exists?, unknown target")))) 1618 1619(define (univ-emit-get ctx obj name) 1620 (case (target-name (ctx-target ctx)) 1621 1622 ((js python ruby) 1623 (^prop-index obj (^str name))) 1624 1625 ((php) 1626 (^call-prim 1627 (^rts-method-use 'get) 1628 obj 1629 (^str name))) 1630 1631 (else 1632 (compiler-internal-error 1633 "univ-emit-get, unknown target")))) 1634 1635(define (univ-emit-set ctx obj name val) 1636 (case (target-name (ctx-target ctx)) 1637 1638 ((js python ruby) 1639 (^assign-expr (^prop-index obj (^str name)) val)) 1640 1641 ((php) 1642 (^call-prim 1643 (^rts-method-use 'set) 1644 obj 1645 (^str name) 1646 val)) 1647 1648 (else 1649 (compiler-internal-error 1650 "univ-emit-set, unknown target")))) 1651 1652(define (univ-emit-attribute-exists? ctx expr1 expr2) 1653 (case (target-name (ctx-target ctx)) 1654 1655 ((js) 1656 (^ "Object.prototype.hasOwnProperty.call(" expr1 "," expr2 ")")) 1657 1658 ((php) 1659 (^call-prim 'property_exists expr1 expr2)) 1660 1661 ((python) 1662 (^call-prim 'hasattr expr1 expr2)) 1663 1664 ((ruby) 1665 (^call-prim 1666 (^member expr1 'instance_variable_defined?) (^ ":@" expr2))) 1667 1668 (else 1669 (compiler-internal-error 1670 "univ-emit-prop-index-exists?, unknown target")))) 1671 1672;; ***** DUMPING OF A COMPILATION MODULE 1673 1674(define (univ-dump targ procs output c-intf module-descr linker-name sem-changing-options sem-preserving-options) 1675 (let ((code 1676 (univ-dump-code targ procs output c-intf module-descr linker-name sem-changing-options sem-preserving-options))) 1677 (univ-display-to-file code output) 1678 (lambda () output))) 1679 1680(define (univ-dump-code targ procs output c-intf module-descr linker-name sem-changing-options sem-preserving-options) 1681 (let* ((module-name-str 1682 (symbol->string (vector-ref module-descr 0))) 1683 1684 (module-name 1685 (scheme-id->c-id module-name-str)) 1686 1687 (module-proc 1688 (list-ref procs 0)) 1689 1690 (ctx 1691 (make-ctx 1692 targ 1693 sem-changing-options 1694 sem-preserving-options 1695 module-name 1696 (univ-ns-prefix sem-changing-options) 1697 (univ-ns-prefix-class sem-changing-options) 1698 "zzz" ;;;;;;;;;;;;;;;;; 1699 (make-objs-used) 1700 (make-resource-set) 1701 (make-table) 1702 (queue-empty))) 1703 1704 (defs-procs 1705 (univ-dump-procs ctx procs)) 1706 1707 (code-module 1708 (univ-defs->code 1709 ctx 1710 (^prefix-class module-name) 1711 (univ-defs-combine 1712 (univ-objs-defs ctx) 1713 (univ-defs-combine 1714 defs-procs 1715 (univ-module-register ctx module-descr))))) 1716 1717 (code-decls 1718 (queue->list (ctx-decls ctx))) 1719 1720 (rtlib-features 1721 (resource-set-stack (ctx-rtlib-features-used ctx)))) 1722 1723 (^ (univ-link-info-header 1724 ctx 1725 module-name-str 1726 (list (list module-name-str)) 1727 rtlib-features 1728 (ctx-glo-used ctx) 1729 #f) 1730 code-decls 1731 code-module 1732 (univ-link-info-footer ctx)))) 1733 1734(define (univ-module-register ctx module-descr) 1735 (univ-add-init 1736 (univ-make-empty-defs) 1737 (lambda (ctx) 1738 (^expr-statement 1739 (^call-prim (^rts-method-use 'module_register) 1740 (^obj module-descr)))))) 1741 1742(define (univ-defs->code ctx root-name defs) 1743 (univ-emit-defs 1744 ctx 1745 #t 1746 (case (univ-module-representation ctx) 1747 1748 ((class) 1749 (let ((class-fields 1750 (reverse (univ-defs-fields defs))) 1751 (instance-fields 1752 '()) 1753 (class-methods 1754 (reverse (univ-defs-methods defs))) 1755 (instance-methods 1756 '()) 1757 (class-classes 1758 (reverse (univ-defs-classes defs))) 1759 (inits 1760 (reverse (univ-defs-inits defs)))) 1761 (univ-add-class 1762 (univ-make-empty-defs) 1763 (univ-class 1764 root-name ;; root-name 1765 '() ;; properties 1766 #f ;; extends 1767 class-fields 1768 '() ;; instance-fields 1769 class-methods 1770 '() ;; instance-methods 1771 class-classes 1772 #f ;; constructor 1773 inits)))) 1774 1775 (else 1776 defs)))) 1777 1778(define (univ-link-info-header ctx name mods-and-flags rtlib-features-used glo-used module-meta-info) 1779 (let ((glos (table->list glo-used))) 1780 (^ (univ-link-info-prefix (target-name (ctx-target ctx))) 1781 (object->string 1782 (list (compiler-version) 1783 (list (target-name (ctx-target ctx)) 1784 (ctx-semantics-changing-options ctx)) 1785 name 1786 mods-and-flags 1787 rtlib-features-used 1788 (map car (keep (lambda (x) (not (eq? (cdr x) 'wr))) glos)) 1789 (map car (keep (lambda (x) (not (eq? (cdr x) 'rd))) glos)) 1790 (map car (keep (lambda (x) (eq? (cdr x) 'rdwr)) glos)) 1791 module-meta-info)) 1792 "\n\n" 1793 (univ-external-libs ctx)))) 1794 1795(define (univ-link-info-footer ctx) 1796 (univ-source-file-footer (target-name (ctx-target ctx)))) 1797 1798(define (univ-link-info targ file) 1799 (let ((in (open-input-file*-preserving-case file))) 1800 (and in 1801 (let* ((pref 1802 (univ-link-info-prefix (target-name targ))) 1803 (info 1804 (let loop ((i 0)) 1805 (if (< i (string-length pref)) 1806 (let ((c (read-char in))) 1807 (if (or (eof-object? c) 1808 (not (char=? c (string-ref pref i)))) 1809 #f 1810 (loop (+ i 1)))) 1811 (read in))))) 1812 (close-input-port in) 1813 (and (pair? info) 1814 (pair? (cdr info)) 1815 (pair? (cadr info)) 1816 (equal? (car info) (compiler-version)) 1817 (equal? (car (cadr info)) (target-name targ)) 1818 info))))) 1819 1820(define (univ-link-semantics-changing-options inputs warnings?) 1821 1822 (define (sem-changing-opts x) 1823 (let ((info (caddr x))) 1824 (cadr (list-ref info 1)))) 1825 1826 (let* ((rev-inputs (reverse inputs)) 1827 (first (car rev-inputs))) 1828 (if warnings? 1829 (let loop ((lst (cdr rev-inputs))) 1830 (if (pair? lst) 1831 (let ((input (car inputs))) 1832 (if (not (equal? (sem-changing-opts first) 1833 (sem-changing-opts input))) 1834 (compiler-user-warning #f "inconsistent semantics changing options for files" (car first) (car input))) 1835 (loop (cdr lst)))))) 1836 (sem-changing-opts first))) 1837 1838(define (univ-link-mods-and-flags inputs) 1839 1840 (define (m-and-f x) 1841 (let ((info (caddr x))) 1842 (list-ref info 3))) 1843 1844 (let ((rev-inputs (reverse inputs))) 1845 (let loop ((lst rev-inputs) (mods-and-flags '())) 1846 (if (pair? lst) 1847 (let ((info (caddr (car lst)))) 1848 (loop (cdr lst) 1849 (append (list-ref info 3) mods-and-flags))) 1850 mods-and-flags)))) 1851 1852(define (univ-link-features-used ctx inputs warnings?) 1853 1854 (for-each (lambda (x) 1855 (let ((info (caddr x))) 1856 (for-each (lambda (feature) 1857 (univ-use-rtlib ctx feature)) 1858 (list-ref info 4)) 1859 (for-each (lambda (name) 1860 (univ-glo-use ctx name 'rd)) 1861 (list-ref info 5)) 1862 (for-each (lambda (name) 1863 (univ-glo-use ctx name 'wr)) 1864 (list-ref info 6)) 1865 (for-each (lambda (name) 1866 (univ-glo-use ctx name 'rd) 1867 (univ-glo-use ctx name 'wr)) 1868 (list-ref info 7)))) 1869 (reverse inputs)) 1870 1871 (if warnings? 1872 1873 (let ((undefs (make-table))) 1874 1875 (for-each (lambda (x) 1876 (let ((info (caddr x)) 1877 (t (ctx-glo-used ctx))) 1878 (for-each (lambda (name) 1879 (let ((dir (table-ref t name 'rd))) 1880 (if (eq? dir 'rd) 1881 (let ((files (table-ref undefs name '()))) 1882 (table-set! undefs name (cons (car x) files)))))) 1883 (list-ref info 5)))) 1884 (reverse inputs)) 1885 1886 (for-each (lambda (x) 1887 (let ((name (car x)) 1888 (files (cdr x))) 1889 (display "*** WARNING -- \"") 1890 (display (symbol->string name)) 1891 (display "\" is not defined,") 1892 (newline) 1893 (display "*** referenced in: ") 1894 (write files) 1895 (newline))) 1896 (table->list undefs)))) 1897 1898 (if (and warnings? univ-all-warnings) 1899 1900 (let ((unrefs (make-table))) 1901 1902 (for-each (lambda (x) 1903 (let ((info (caddr x)) 1904 (t (ctx-glo-used ctx))) 1905 (for-each (lambda (name) 1906 (let ((dir (table-ref t name 'wr))) 1907 (if (eq? dir 'wr) 1908 (let ((files (table-ref unrefs name '()))) 1909 (table-set! unrefs name (cons (car x) files)))))) 1910 (list-ref info 6)))) 1911 (reverse inputs)) 1912 1913 (for-each (lambda (x) 1914 (let ((name (car x)) 1915 (files (cdr x))) 1916 (display "*** WARNING -- \"") 1917 (display (symbol->string name)) 1918 (display "\" is defined but not referenced,") 1919 (newline) 1920 (display "*** defined in: ") 1921 (write files) 1922 (newline))) 1923 (table->list unrefs))))) 1924 1925(define univ-all-warnings #t) 1926(set! univ-all-warnings #f) 1927 1928(define (univ-link targ extension? inputs output linker-name warnings?) 1929 (let* ((root 1930 (path-strip-extension output)) 1931 1932 (name 1933 (path-strip-directory root)) 1934 1935 (sem-changing-options 1936 (univ-link-semantics-changing-options inputs warnings?)) 1937 1938 (mods-and-flags 1939 (univ-link-mods-and-flags inputs)) 1940 1941 (ctx 1942 (make-ctx 1943 targ 1944 sem-changing-options 1945 '() ;; semantics-preserving-options 1946 "" ;; module-name filled in later 1947 (univ-ns-prefix sem-changing-options) 1948 (univ-ns-prefix-class sem-changing-options) 1949 "zzz" ;;;;;;;;;;;; 1950 (make-objs-used) 1951 (make-resource-set) 1952 (make-table) 1953 (queue-empty))) 1954 1955 (_ 1956 (ctx-module-name-set! ctx (univ-rts-module-name ctx))) 1957 1958 (rtlib-init 1959 (univ-rtlib-init ctx mods-and-flags)) 1960 1961 (_ 1962 (univ-link-features-used ctx inputs warnings?)) 1963 1964 (features-used 1965 (resource-set-stack (ctx-rtlib-features-used ctx))) 1966 1967 (code-entry 1968 (case (target-name targ) 1969 ((java) 1970 (univ-defs->code 1971 ctx 1972 name 1973 (univ-entry-defs ctx mods-and-flags))) 1974 (else 1975 (^)))) 1976 1977 (code-rtlib 1978 (univ-defs->code 1979 ctx 1980 (^prefix-class (univ-rts-module-name ctx)) 1981 (univ-rtlib-defs ctx rtlib-init))) 1982 1983 (code-decls 1984 (queue->list (ctx-decls ctx))) 1985 1986 (code 1987 (^ (univ-link-info-header 1988 ctx 1989 name 1990 mods-and-flags 1991 features-used 1992 (ctx-glo-used ctx) 1993 #f) 1994 code-entry 1995 code-rtlib 1996 code-decls 1997 (univ-link-info-footer ctx)))) 1998 1999 (univ-display-to-file code output) 2000 2001 output)) 2002 2003;;TODO: add constants 2004#; 2005(define (univ-module-header ctx) 2006 (^ (^var-declaration 'scmobj (gvm-state-cst ctx) (^extensible-array-literal 'scmobj '())) 2007 "\n")) 2008 2009(define (univ-objs-defs ctx) 2010 (let* ((objs-used (ctx-objs-used ctx)) 2011 (stack (reverse (objs-used-stack objs-used))) 2012 (table (objs-used-table objs-used))) 2013 (let loop ((lst stack) (defs (univ-make-empty-defs))) 2014 (if (pair? lst) 2015 (loop (cdr lst) 2016 (let ((obj (car lst))) 2017 (if (proc-obj? obj) 2018 defs 2019 (let ((state (table-ref table obj))) 2020 (if (or (> (vector-ref state 0) 1) ;; use a variable? 2021 (eq? (target-name (ctx-target ctx)) 'python)) ;; Python can't handle deep nestings 2022 (let ((cst 2023 (vector-ref state 2)) 2024 (val 2025 (car (vector-ref state 1)))) 2026 ;;(pp (list cst obj));;;;;;;;;;;;;;; 2027 (set-car! (vector-ref state 1) 2028 (^this-mod-field cst)) 2029 (univ-add-field 2030 defs 2031 (univ-field 2032 cst 2033 'scmobj ;; (univ-obj-type obj) 2034 val 2035 '(public)))) 2036 defs))))) 2037 defs)))) 2038 2039(define (univ-obj-use ctx obj force-var? gen-expr) 2040 2041 (define (use-cst cst) 2042 (if (not (eq? (univ-module-representation ctx) 'class)) 2043 (use-global ctx (^this-mod-field cst)))) 2044 2045 (let* ((objs-used (ctx-objs-used ctx)) 2046 (table (objs-used-table objs-used)) 2047 (state (table-ref table obj #f))) 2048 (if state ;; don't add to table if obj was added before 2049 2050 (begin 2051 (use-cst (vector-ref state 2)) 2052 (vector-set! state 0 (+ (vector-ref state 0) 1)) ;; increment reference count 2053 (vector-ref state 1)) 2054 2055 (let* ((code 2056 (list #f)) 2057 (cst 2058 (string->symbol 2059 (string-append 2060 "cst" 2061 (number->string (table-length table)) 2062 (if (eq? (univ-module-representation ctx) 'class) 2063 "" 2064 (string-append "_" (ctx-module-name ctx)))))) 2065 (state 2066 (vector (if force-var? 2 1) code cst))) 2067 (use-cst cst) 2068 (table-set! table obj state) 2069 (set-car! code (gen-expr)) 2070 (let ((stack (objs-used-stack objs-used))) 2071 (objs-used-stack-set! objs-used (cons obj stack))) 2072 code)))) 2073 2074(define (make-objs-used) 2075 (vector '() 2076 (make-table test: eq?))) 2077 2078(define (objs-used-stack ou) (vector-ref ou 0)) 2079(define (objs-used-stack-set! ou x) (vector-set! ou 0 x)) 2080 2081(define (objs-used-table ou) (vector-ref ou 1)) 2082(define (objs-used-table-set! ou x) (vector-set! ou 1 x)) 2083 2084(define (univ-dump-procs global-ctx procs) 2085 2086 (let ((proc-seen (queue-empty)) 2087 (proc-left (queue-empty))) 2088 2089 (define (scan-obj obj) 2090 (if (and (proc-obj? obj) 2091 (proc-obj-code obj) 2092 (not (memq obj (queue->list proc-seen)))) 2093 (begin 2094 (queue-put! proc-seen obj) 2095 (queue-put! proc-left obj)))) 2096 2097 (define (dump-proc p) 2098 2099 (define ctrlpts 2100 (make-stretchable-vector #f)) 2101 2102 (define ctrlpts-init 2103 (list #f)) 2104 2105 (define (scan-bbs ctx bbs) 2106 (let* ((bb-done (make-stretchable-vector #f)) 2107 (bb-todo (queue-empty))) 2108 2109 (define (todo-lbl-num! n) 2110 (queue-put! bb-todo (lbl-num->bb n bbs))) 2111 2112 (define (scan-bb ctx bb) 2113 (if (stretchable-vector-ref bb-done (bb-lbl-num bb)) 2114 (univ-make-empty-defs) 2115 (begin 2116 (stretchable-vector-set! bb-done (bb-lbl-num bb) #t) 2117 (scan-bb-all ctx bb)))) 2118 2119 (define (scan-bb-all ctx bb) 2120 (scan-gvm-label 2121 ctx 2122 (bb-label-instr bb) 2123 (lambda (ctx) 2124 (scan-bb-all-except-label ctx bb)))) 2125 2126 (define (scan-bb-all-except-label ctx bb) 2127 (let loop ((lst (bb-non-branch-instrs bb)) 2128 (rev-res '())) 2129 (if (pair? lst) 2130 (loop (cdr lst) 2131 (cons (scan-gvm-instr ctx (car lst)) 2132 rev-res)) 2133 (reverse 2134 (cons (scan-gvm-instr ctx (bb-branch-instr bb)) 2135 rev-res))))) 2136 2137 (define (scan-gvm-label ctx gvm-instr proc) 2138 2139 (define (frame-info gvm-instr) 2140 (let* ((frame 2141 (gvm-instr-frame gvm-instr)) 2142 (fs 2143 (frame-size frame)) 2144 (vars 2145 (reverse (frame-slots frame))) 2146 (link 2147 (pos-in-list ret-var vars))) 2148 (vector fs link))) 2149 2150 (with-stack-base-offset 2151 ctx 2152 (- (frame-size (gvm-instr-frame gvm-instr))) 2153 (lambda (ctx) 2154 (let* ((id 2155 (gvm-bb-use ctx (label-lbl-num gvm-instr) (ctx-ns ctx))) 2156 (header 2157 (case (label-type gvm-instr) 2158 2159 ((simple) 2160 (^ "\n")) 2161 2162 ((entry) 2163 (if (label-entry-rest? gvm-instr) 2164 (^ " " 2165 (univ-emit-comment 2166 ctx 2167 (if (label-entry-closed? gvm-instr) 2168 "closure-entry-point (+rest)\n" 2169 "entry-point (+rest)\n"))) 2170 (^ " " 2171 (univ-emit-comment 2172 ctx 2173 (if (label-entry-closed? gvm-instr) 2174 "closure-entry-point\n" 2175 "entry-point\n"))))) 2176 2177 ((return) 2178 (^ " " 2179 (univ-emit-comment ctx "return-point\n"))) 2180 2181 ((task-entry) 2182 (^ " " 2183 (univ-emit-comment ctx "task-entry-point\n"))) 2184 2185 ((task-return) 2186 (^ " " 2187 (univ-emit-comment ctx "task-return-point\n"))) 2188 2189 (else 2190 (compiler-internal-error 2191 "scan-gvm-label, unknown label type")))) 2192 (gen-body 2193 (lambda (ctx) 2194 (^ (case (label-type gvm-instr) 2195 2196 ((entry) 2197 (univ-label-entry ctx 2198 gvm-instr 2199 (^mod-jumpable 2200 (ctx-module-name ctx) 2201 id))) 2202 2203 (else 2204 (^))) 2205 2206 (proc ctx)))) 2207 (entry 2208 (bbs-entry-lbl-num bbs)) 2209 (lbl-num 2210 (label-lbl-num gvm-instr))) 2211 2212 (univ-jumpable-declaration-defs 2213 2214 ctx 2215 2216 ;; global? 2217 #t 2218 2219 ;; name 2220 id 2221 2222 ;; jumpable-type 2223 (case (label-type gvm-instr) 2224 ((entry) (if (= lbl-num entry) 2225 'parententrypt 2226 'entrypt)) 2227 ((return) 'returnpt) 2228 (else 'ctrlpt)) 2229 2230 ;; params 2231 '() 2232 2233 ;; attribs 2234 (if (memq (label-type gvm-instr) '(entry return)) 2235 2236 (append 2237 2238 (let ((ctrlpt-id 2239 (stretchable-vector-length ctrlpts))) 2240 (stretchable-vector-set! 2241 ctrlpts 2242 ctrlpt-id 2243 lbl-num) 2244 (list (univ-field 'id 2245 'int 2246 (^int ctrlpt-id) 2247 '(inherited)) 2248 (univ-field 'parent 2249 'parententrypt 2250 (let ((entry? (= lbl-num entry))) 2251 (cond ((and entry? 2252 (univ-parent-entry-point-has-null-parent? ctx)) 2253 (^null)) 2254 ((and entry? 2255 (eq? (univ-procedure-representation ctx) 'class)) 2256 (^this)) 2257 (else 2258 (let ((the-ns (ctx-ns ctx))) 2259 (lambda (ctx2) 2260 (let ((ns (ctx-ns ctx2))) 2261 (ctx-ns-set! ctx2 the-ns) 2262 (let ((x (univ-ctrlpt-reference 2263 ctx2 2264 entry))) 2265 (ctx-ns-set! ctx2 ns) 2266 x))))))) 2267 '(inherited)))) 2268 2269 (if (eq? (label-type gvm-instr) 'return) 2270 2271 (let ((info (frame-info gvm-instr))) 2272 (list (univ-field 'fs 2273 'int 2274 (^int (vector-ref info 0)) 2275 '(inherited)) 2276 (univ-field 'link 2277 'int 2278 (^int (+ (vector-ref info 1) 1)) 2279 '(inherited)))) 2280 2281 (append 2282 (list (univ-field 2283 'nfree 2284 'int 2285 (if (label-entry-closed? gvm-instr) 2286 (let* ((frame (gvm-instr-frame gvm-instr)) 2287 (nfree (length (frame-closed frame)))) 2288 (^int nfree)) 2289 (^int -1)) 2290 '(inherited))) 2291 (if (= lbl-num entry) 2292 (list (univ-field (univ-proc-name-attrib ctx) 2293 'symbol 2294 (lambda (ctx) 2295 (univ-prm-name ctx (proc-obj-name p))) 2296 '(inherited)) 2297 (univ-field 'ctrlpts 2298 '(array ctrlpt) 2299 ctrlpts-init 2300 '(inherited)) 2301 (univ-field 'info 2302 'scmobj 2303 (^obj #f) ;; TODO 2304 '(inherited))) 2305 '())))) 2306 2307 '()) 2308 2309 ;; body 2310 (univ-emit-fn-body ctx header gen-body)))))) 2311 2312 (define (unwind-stack? gvm-instr) 2313 (let ((node (comment-get (gvm-instr-comment gvm-instr) 'node))) 2314 (and node (not (intrs-enabled? (node-env node))) 'unwind))) 2315 2316 (define (scan-gvm-instr ctx gvm-instr) 2317 2318 ;; TODO: combine with scan-gvm-opnd 2319 (define (scan-opnd gvm-opnd) 2320 (cond ((not gvm-opnd)) 2321 ((lbl? gvm-opnd) 2322 (todo-lbl-num! (lbl-num gvm-opnd))) 2323 ((obj? gvm-opnd) 2324 (scan-obj (obj-val gvm-opnd))) 2325 ((clo? gvm-opnd) 2326 (scan-opnd (clo-base gvm-opnd))))) 2327 2328 ;;(write-gvm-instr gvm-instr ##stderr-port)(newline ##stderr-port);;;;;;;;;;;;;;;;;; 2329 2330 ;; TODO: combine with scan-gvm-opnd 2331 (case (gvm-instr-type gvm-instr) 2332 2333 ((apply) 2334 (for-each scan-opnd (apply-opnds gvm-instr)) 2335 (if (apply-loc gvm-instr) 2336 (scan-opnd (apply-loc gvm-instr)))) 2337 2338 ((copy) 2339 (scan-opnd (copy-opnd gvm-instr)) 2340 (scan-opnd (copy-loc gvm-instr))) 2341 2342 ((close) 2343 (for-each (lambda (parms) 2344 (scan-opnd (closure-parms-loc parms)) 2345 (scan-opnd (make-lbl (closure-parms-lbl parms))) 2346 (for-each scan-opnd (closure-parms-opnds parms))) 2347 (close-parms gvm-instr))) 2348 2349 ((ifjump) 2350 (for-each scan-opnd (ifjump-opnds gvm-instr))) 2351 2352 ((switch) 2353 (scan-opnd (switch-opnd gvm-instr)) 2354 (for-each (lambda (c) (scan-obj (switch-case-obj c))) 2355 (switch-cases gvm-instr))) 2356 2357 ((jump) 2358 (scan-opnd (jump-opnd gvm-instr)) 2359 (if (jump-ret gvm-instr) 2360 (todo-lbl-num! (jump-ret gvm-instr))))) 2361 2362 (case (gvm-instr-type gvm-instr) 2363 2364 ((apply) 2365 (let ((loc (apply-loc gvm-instr)) 2366 (prim (apply-prim gvm-instr)) 2367 (opnds (apply-opnds gvm-instr))) 2368 (let ((proc (proc-obj-inline prim))) 2369 (if (not proc) 2370 2371 (compiler-internal-error 2372 "scan-gvm-instr, unknown 'prim'" prim) 2373 2374 (proc 2375 ctx 2376 (lambda (result) 2377 (cond (loc ;; result is needed? 2378 (^setloc loc (or result (^void-obj)))) 2379 ;; if result is not needed, don't generate expression 2380 ;;(result 2381 ;; (^expr-statement result)) 2382 (else 2383 (^)))) 2384 opnds))))) 2385 2386 ((copy) 2387 (let ((loc (copy-loc gvm-instr)) 2388 (opnd (copy-opnd gvm-instr))) 2389 (if opnd 2390 (begin 2391 (scan-gvm-opnd ctx loc);;;;;;;;;;;;;;;; needed? 2392 (scan-gvm-opnd ctx opnd) 2393 (^setloc loc (^getopnd opnd))) 2394 (^)))) 2395 2396 ((close) 2397 (let () 2398 2399 (define (alloc lst rev-loc-names) 2400 (if (pair? lst) 2401 2402 (let* ((parms (car lst)) 2403 (lbl (closure-parms-lbl parms)) 2404 (loc (closure-parms-loc parms)) 2405 (opnds (closure-parms-opnds parms))) 2406 (univ-closure-alloc 2407 ctx 2408 lbl 2409 (map (lambda (opnd) 2410 (cond ((assv opnd rev-loc-names) => cdr) 2411 ((memv opnd (map closure-parms-loc lst)) 2412 (^null)) 2413 (else 2414 (^getopnd opnd)))) 2415 opnds) 2416 (lambda (name) 2417 (alloc (cdr lst) 2418 (cons (cons loc name) 2419 rev-loc-names))))) 2420 2421 (init (close-parms gvm-instr) (reverse rev-loc-names)))) 2422 2423 (define (init lst loc-names) 2424 (if (pair? lst) 2425 2426 (let* ((parms (car lst)) 2427 (loc (closure-parms-loc parms)) 2428 (opnds (closure-parms-opnds parms)) 2429 (loc-name (assv loc loc-names))) 2430 (let loop ((i 1) ;; 0 2431 (opnds opnds) ;; (cons (make-lbl lbl) opnds) 2432 (rev-code '())) 2433 (if (pair? opnds) 2434 (let ((opnd (car opnds))) 2435 (loop (+ i 1) 2436 (cdr opnds) 2437 (cons (if (and (assv opnd loc-names) 2438 (memv opnd (map closure-parms-loc lst))) 2439 (^setclo 2440 (cdr loc-name) 2441 i 2442 (cdr (assv opnd loc-names))) 2443 (^)) 2444 rev-code))) 2445 (^ (reverse rev-code) 2446 (init (cdr lst) loc-names))))) 2447 2448 (map 2449 (lambda (loc-name) 2450 (let* ((loc (car loc-name)) 2451 (name (cdr loc-name))) 2452 (^setloc loc name))) 2453 loc-names))) 2454 2455 (alloc (close-parms gvm-instr) '()))) 2456 2457 ((ifjump) 2458 (let ((test (ifjump-test gvm-instr)) 2459 (opnds (ifjump-opnds gvm-instr)) 2460 (true (ifjump-true gvm-instr)) 2461 (false (ifjump-false gvm-instr)) 2462 (fs (frame-size (gvm-instr-frame gvm-instr))) 2463 (poll? (or (ifjump-poll? gvm-instr) 2464 (unwind-stack? gvm-instr)))) 2465 2466 (let ((proc (proc-obj-test test))) 2467 (if (not proc) 2468 2469 (compiler-internal-error 2470 "scan-gvm-instr, unknown 'test'" test) 2471 2472 (proc 2473 ctx 2474 (lambda (result) 2475 (^if result 2476 (jump-to-label ctx true fs poll?) 2477 (jump-to-label ctx false fs poll?))) 2478 opnds))))) 2479 2480 ((switch) 2481 ;; TODO 2482 ;; (switch-opnd gvm-instr) 2483 ;; (switch-cases gvm-instr) 2484 ;; (switch-poll? gvm-instr) 2485 ;; (switch-default gvm-instr) 2486 (univ-throw ctx "\"switch GVM instruction unimplemented\"")) 2487 2488 ((jump) 2489 ;; TODO 2490 ;; (jump-safe? gvm-instr) 2491 ;; test: (jump-poll? gvm-instr) 2492 2493 (let ((nb-args (jump-nb-args gvm-instr)) 2494 (safe? (jump-safe? gvm-instr)) 2495 (opnd (jump-opnd gvm-instr)) 2496 (ret (jump-ret gvm-instr)) 2497 (fs (frame-size (gvm-instr-frame gvm-instr))) 2498 (poll? (or (jump-poll? gvm-instr) 2499 (unwind-stack? gvm-instr)))) 2500 2501 (or (and (obj? opnd) 2502 (proc-obj? (obj-val opnd)) 2503 nb-args 2504 (let* ((proc (obj-val opnd)) 2505 (jump-inliner (proc-obj-jump-inline proc))) 2506 (and jump-inliner 2507 (jump-inliner ctx ret nb-args poll? safe? fs)))) 2508 2509 (^ (if ret 2510 (^setloc (make-reg 0) (^getopnd (make-lbl ret))) 2511 (^)) 2512 2513 (if nb-args 2514 (^setnargs nb-args) 2515 (^)) 2516 2517 (or (and (lbl? opnd) 2518 (jump-to-label ctx (lbl-num opnd) fs poll?)) 2519 2520 (with-stack-pointer-adjust 2521 ctx 2522 (+ fs 2523 (ctx-stack-base-offset ctx)) 2524 (lambda (ctx) 2525 (^return-poll 2526 (if (jump-safe? gvm-instr) 2527 (if (glo? opnd) 2528 (^call-prim 2529 (^rts-method-use 'check_procedure_glo) 2530 (scan-gvm-opnd ctx opnd) 2531 (^obj (glo-name opnd))) 2532 (^call-prim 2533 (^rts-method-use 'check_procedure) 2534 (scan-gvm-opnd ctx opnd))) 2535 (let ((o (scan-gvm-opnd ctx opnd))) 2536 (if (or (lbl? opnd) (obj? opnd)) 2537 o 2538 (^cast*-jumpable o)))) 2539 poll? 2540 (and 2541 2542 ;; avoid call optimization on globals 2543 ;; because some VMs, such as V8 and PyPy, 2544 ;; use a counterproductive speculative 2545 ;; optimization (which slows 2546 ;; down fib by an order of magnitude!) 2547 (not (reg? opnd)) 2548 2549 (case (target-name (ctx-target ctx)) 2550 ((php) 2551 ;; avoid call optimization on PHP 2552 ;; because it generates syntactically 2553 ;; incorrect code (PHP grammar issue) 2554 #f) 2555 (else 2556 #t))))))))))) 2557 2558 (else 2559 (compiler-internal-error 2560 "scan-gvm-instr, unknown 'gvm-instr':" 2561 gvm-instr)))) 2562 2563 (define (jump-to-label ctx n jump-fs poll?) 2564 (with-stack-pointer-adjust 2565 ctx 2566 (+ jump-fs 2567 (ctx-stack-base-offset ctx)) 2568 (lambda (ctx) 2569 2570 (define (cont) 2571 (cond ((and (ctx-allow-jump-destination-inlining? ctx) 2572 (let* ((bb (lbl-num->bb n bbs)) 2573 (label-instr (bb-label-instr bb))) 2574 (and (eq? (label-type label-instr) 'simple) 2575 (or (= (length (bb-precedents bb)) 1) 2576 (= (length (bb-non-branch-instrs bb)) 0))))) ;; very short destination bb? 2577 (let* ((bb (lbl-num->bb n bbs)) 2578 (label-instr (bb-label-instr bb)) 2579 (label-fs (frame-size (gvm-instr-frame label-instr)))) 2580 (with-stack-base-offset 2581 ctx 2582 (- label-fs) 2583 (lambda (ctx) 2584 (with-allow-jump-destination-inlining? 2585 ctx 2586 (= (length (bb-precedents bb)) 1) ;; #f 2587 (lambda (ctx) 2588 (scan-bb-all-except-label ctx bb))))))) 2589 2590 (else 2591 (^return-jump 2592 (scan-gvm-opnd ctx (make-lbl n)))))) 2593 2594 (univ-emit-poll-or-continue ctx (scan-gvm-opnd ctx (make-lbl n)) poll? cont)))) 2595 2596 (define (scan-gvm-opnd ctx gvm-opnd) 2597 (if (lbl? gvm-opnd) 2598 (todo-lbl-num! (lbl-num gvm-opnd))) 2599 (^getopnd gvm-opnd));;;;;;;;;;;;;;;;;;;;;;;scan-gvm-loc ? 2600 2601 (todo-lbl-num! (bbs-entry-lbl-num bbs)) 2602 2603 (let* ((bbs-defs 2604 (let loop ((defs (univ-make-empty-defs))) 2605 (if (queue-empty? bb-todo) 2606 defs 2607 (loop (univ-defs-combine 2608 defs 2609 (scan-bb ctx (queue-get! bb-todo))))))) 2610 (init1 2611 (let* ((lbl 2612 (make-lbl (bbs-entry-lbl-num bbs))) 2613 (entry-id 2614 (gvm-lbl-use ctx lbl)) 2615 (ctrlpts-array 2616 (^array-literal 2617 (univ-ctrlpt-reference-type ctx) 2618 (map (lambda (n) 2619 (univ-ctrlpt-reference ctx n)) 2620 (stretchable-vector->list ctrlpts))))) 2621 (if (eq? (univ-ctrlpt-reference-type ctx) 'str) 2622 2623 (begin 2624 (set-car! ctrlpts-init ctrlpts-array) 2625 (lambda (ctx) (^))) 2626 2627 (begin 2628 (set-car! ctrlpts-init (^null)) 2629 (lambda (ctx) 2630 (^ "\n" 2631 (univ-with-ctrlpt-attribs 2632 ctx 2633 #f 2634 entry-id 2635 (lambda () 2636 (univ-set-ctrlpt-attrib 2637 ctx 2638 entry-id 2639 'ctrlpts 2640 ctrlpts-array))))))))) 2641 (init2 2642 (lambda (ctx) 2643 (let ((name (string->symbol (proc-obj-name p)))) 2644 (^ "\n" 2645 (^setpeps name (^obj p)) 2646 (if (proc-obj-primitive? p) 2647 (^setglo name (^obj p)) 2648 (^))))))) 2649 (univ-add-init (univ-add-init bbs-defs init1) init2)))) 2650 2651 (let ((ctx (make-ctx 2652 (ctx-target global-ctx) 2653 (ctx-semantics-changing-options global-ctx) 2654 (ctx-semantics-preserving-options global-ctx) 2655 (ctx-module-name global-ctx) 2656 (ctx-ns-prefix global-ctx) 2657 (ctx-ns-prefix-class global-ctx) 2658 (scheme-id->c-id (proc-obj-name p)) 2659 (ctx-objs-used global-ctx) 2660 (ctx-rtlib-features-used global-ctx) 2661 (ctx-glo-used global-ctx) 2662 (ctx-decls global-ctx)))) 2663 (let ((x (proc-obj-code p))) 2664 (if (bbs? x) 2665 (scan-bbs ctx x) 2666 (univ-make-empty-defs))))) 2667 2668 (for-each scan-obj procs) 2669 2670 (let loop ((defs (univ-make-empty-defs))) 2671 (if (queue-empty? proc-left) 2672 defs 2673 (loop (univ-defs-combine defs (dump-proc (queue-get! proc-left)))))))) 2674 2675(define (univ-label-entry ctx gvm-instr id) 2676 (let* ((nb-parms (label-entry-nb-parms gvm-instr)) 2677 (opts (label-entry-opts gvm-instr)) 2678 (keys (label-entry-keys gvm-instr)) 2679 (rest? (label-entry-rest? gvm-instr)) 2680 (closed? (label-entry-closed? gvm-instr)) 2681 (nb-parms-except-rest 2682 (- nb-parms (if rest? 1 0))) 2683 (nb-keys 2684 (if keys (length keys) 0)) 2685 (nb-req-and-opt 2686 (- nb-parms-except-rest nb-keys)) 2687 (nb-opts 2688 (length opts)) 2689 (nb-req 2690 (- nb-req-and-opt nb-opts)) 2691 (defaults 2692 (append opts (map cdr (or keys '()))))) 2693 2694 (define (dispatch-on-nb-args nb-args) 2695 (if (> nb-args (- nb-req-and-opt (if rest? 0 1))) 2696 2697 (cond 2698 ((and keys rest?) 2699 (let ((error (^local-var 'error))) 2700 (^ 2701 (^var-declaration 'jumpable error 2702 (^call-prim (^rts-method-use 'build_key_rest) 2703 (^int nb-req-and-opt) 2704 (^int nb-parms) 2705 (^array-literal 'scmobj 2706 (apply append 2707 (map (lambda (x) 2708 (list (^obj (car x)) (^obj (obj-val (cdr x))))) 2709 keys))))) 2710 (^if (^not (^parens (^eq? error (^null)))) 2711 (^return-call-prim 2712 (^rts-method-use 'wrong_key_args) 2713 (if closed? 2714 (^cast*-jumpable (^getreg (+ (univ-nb-arg-regs ctx) 1))) 2715 id) 2716 error))))) 2717 (keys 2718 (let ((error (^local-var 'error))) 2719 (^ 2720 (^var-declaration 'jumpable error 2721 (^call-prim (^rts-method-use 'build_key) 2722 (^int nb-req-and-opt) 2723 (^int nb-parms) 2724 (^array-literal 'scmobj 2725 (apply append 2726 (map (lambda (x) 2727 (list (^obj (car x)) (^obj (obj-val (cdr x))))) 2728 keys))))) 2729 (^if (^not (^parens (^eq? error (^null)))) 2730 (^return-call-prim 2731 (^rts-method-use 'wrong_key_args) 2732 (if closed? 2733 (^cast*-jumpable (^getreg (+ (univ-nb-arg-regs ctx) 1))) 2734 id) 2735 error))))) 2736 (else 2737 (^if (if rest? 2738 (^not (^call-prim 2739 (^rts-method-use 'build_rest) 2740 (^int nb-parms-except-rest))) 2741 (^!= (^getnargs) 2742 (^int nb-parms-except-rest))) 2743 (^return-call-prim 2744 (^rts-method-use 'wrong_nargs) 2745 (if closed? 2746 (^cast*-jumpable (^getreg (+ (univ-nb-arg-regs ctx) 1))) 2747 id))))) 2748 2749 (let ((nb-stacked (max 0 (- nb-args (univ-nb-arg-regs ctx)))) 2750 (nb-stacked* (max 0 (- nb-parms (univ-nb-arg-regs ctx))))) 2751 2752 (define (setup-parameter i) 2753 (if (<= i nb-parms) 2754 (let* ((rest (setup-parameter (+ i 1))) 2755 (src-reg (- i nb-stacked)) 2756 (src (cond ((<= i nb-args) 2757 (^getreg src-reg)) 2758 ((and rest? (= i nb-parms)) 2759 (^obj '())) 2760 (else 2761 (^obj 2762 (obj-val (list-ref defaults (- i nb-req 1)))))))) 2763 (if (<= i nb-stacked*) 2764 (^ (^push src) 2765 rest) 2766 (if (and (<= i nb-args) (= nb-stacked nb-stacked*)) 2767 rest 2768 (let ((dst-reg (- i nb-stacked*))) 2769 (^ (^setreg dst-reg src) 2770 rest))))) 2771 (^))) 2772 2773 (let ((x (setup-parameter (+ nb-stacked 1)))) 2774 (^if (^= (^getnargs) 2775 (^int nb-args)) 2776 x 2777 (dispatch-on-nb-args (+ nb-args 1))))))) 2778 2779 (dispatch-on-nb-args nb-req))) 2780 2781(define closure-count 0) 2782 2783(define (univ-separated-list sep lst) 2784 (if (pair? lst) 2785 (if (pair? (cdr lst)) 2786 (list (car lst) sep (univ-separated-list sep (cdr lst))) 2787 (car lst)) 2788 '())) 2789 2790(define (univ-map-index f lst) 2791 2792 (define (mp f lst i) 2793 (if (pair? lst) 2794 (cons (f (car lst) i) 2795 (mp f (cdr lst) (+ i 1))) 2796 '())) 2797 2798 (mp f lst 0)) 2799 2800(define (univ-gensym ctx name) 2801 (let ((count (ctx-serial-num ctx))) 2802 (ctx-serial-num-set! ctx (+ count 1)) 2803 (string->symbol 2804 (string-append 2805 (symbol->string name) 2806 (number->string count))))) 2807 2808(define (univ-closure-alloc ctx lbl exprs cont) 2809 (let ((closure-var (^local-var (univ-gensym ctx 'closure)))) 2810 (^ (^var-declaration 2811 'closure 2812 closure-var 2813 (^call-prim 2814 (^rts-method-use 'closure_alloc) 2815 (^array-literal 2816 'scmobj 2817 (cons (gvm-lbl-use ctx (make-lbl lbl)) 2818 exprs)))) 2819 (cont closure-var)))) 2820 2821(define (make-ctx 2822 target 2823 semantics-changing-options 2824 semantics-preserving-options 2825 module-name 2826 ns-prefix 2827 ns-prefix-class 2828 ns 2829 objs-used 2830 rtlib-features-used 2831 glo-used 2832 decls) 2833 (vector target 2834 semantics-changing-options 2835 semantics-preserving-options 2836 module-name 2837 ns-prefix 2838 ns-prefix-class 2839 ns 2840 0 2841 0 2842 univ-enable-jump-destination-inlining? 2843 (make-resource-set) 2844 (make-resource-set) 2845 (make-resource-set) 2846 objs-used 2847 rtlib-features-used 2848 glo-used 2849 decls)) 2850 2851(define (ctx-target ctx) (vector-ref ctx 0)) 2852(define (ctx-target-set! ctx x) (vector-set! ctx 0 x)) 2853 2854(define (ctx-semantics-changing-options ctx) (vector-ref ctx 1)) 2855(define (ctx-semantics-changing-options-set! ctx x) (vector-set! ctx 1 x)) 2856 2857(define (ctx-semantics-preserving-options ctx) (vector-ref ctx 2)) 2858(define (ctx-semantics-preserving-options-set! ctx x) (vector-set! ctx 2 x)) 2859 2860(define (ctx-module-name ctx) (vector-ref ctx 3)) 2861(define (ctx-module-name-set! ctx x) (vector-set! ctx 3 x)) 2862 2863(define (ctx-ns-prefix ctx) (vector-ref ctx 4)) 2864(define (ctx-ns-prefix-set! ctx x) (vector-set! ctx 4 x)) 2865 2866(define (ctx-ns-prefix-class ctx) (vector-ref ctx 5)) 2867(define (ctx-ns-prefix-class-set! ctx x) (vector-set! ctx 5 x)) 2868 2869(define (ctx-ns ctx) (vector-ref ctx 6)) 2870(define (ctx-ns-set! ctx x) (vector-set! ctx 6 x)) 2871 2872(define (ctx-stack-base-offset ctx) (vector-ref ctx 7)) 2873(define (ctx-stack-base-offset-set! ctx x) (vector-set! ctx 7 x)) 2874 2875(define (ctx-serial-num ctx) (vector-ref ctx 8)) 2876(define (ctx-serial-num-set! ctx x) (vector-set! ctx 8 x)) 2877 2878(define (ctx-allow-jump-destination-inlining? ctx) (vector-ref ctx 9)) 2879(define (ctx-allow-jump-destination-inlining?-set! ctx x) (vector-set! ctx 9 x)) 2880 2881(define (ctx-resources-used-rd ctx) (vector-ref ctx 10)) 2882(define (ctx-resources-used-rd-set! ctx x) (vector-set! ctx 10 x)) 2883 2884(define (ctx-resources-used-wr ctx) (vector-ref ctx 11)) 2885(define (ctx-resources-used-wr-set! ctx x) (vector-set! ctx 11 x)) 2886 2887(define (ctx-globals-used ctx) (vector-ref ctx 12)) 2888(define (ctx-globals-used-set! ctx x) (vector-set! ctx 12 x)) 2889 2890(define (ctx-objs-used ctx) (vector-ref ctx 13)) 2891(define (ctx-objs-used-set! ctx x) (vector-set! ctx 13 x)) 2892 2893(define (ctx-rtlib-features-used ctx) (vector-ref ctx 14)) 2894(define (ctx-rtlib-features-used-set! ctx x) (vector-set! ctx 14 x)) 2895 2896(define (ctx-glo-used ctx) (vector-ref ctx 15)) 2897(define (ctx-glo-used-set! ctx x) (vector-set! ctx 15 x)) 2898 2899(define (ctx-decls ctx) (vector-ref ctx 16)) 2900(define (ctx-decls-set! ctx x) (vector-set! ctx 16 x)) 2901 2902(define (with-stack-base-offset ctx n proc) 2903 (let ((save (ctx-stack-base-offset ctx))) 2904 (ctx-stack-base-offset-set! ctx n) 2905 (let ((result (proc ctx))) 2906 (ctx-stack-base-offset-set! ctx save) 2907 result))) 2908 2909(define (with-stack-pointer-adjust ctx n proc) 2910 (^ (if (equal? n 0) 2911 (^) 2912 (^inc-by (gvm-state-sp-use ctx 'rdwr) 2913 n)) 2914 (with-stack-base-offset 2915 ctx 2916 (- (ctx-stack-base-offset ctx) n) 2917 proc))) 2918 2919(define (with-allow-jump-destination-inlining? ctx allow? proc) 2920 (let ((save (ctx-allow-jump-destination-inlining? ctx))) 2921 (ctx-allow-jump-destination-inlining?-set! ctx allow?) 2922 (let ((result (proc ctx))) 2923 (ctx-allow-jump-destination-inlining?-set! ctx save) 2924 result))) 2925 2926(define (with-new-resources-used ctx proc) 2927 (let ((save-rsrc-rd (ctx-resources-used-rd ctx)) 2928 (save-rsrc-wr (ctx-resources-used-wr ctx)) 2929 (save-glob-rd (ctx-globals-used ctx))) 2930 (ctx-resources-used-rd-set! ctx (make-resource-set)) 2931 (ctx-resources-used-wr-set! ctx (make-resource-set)) 2932 (ctx-globals-used-set! ctx (make-resource-set)) 2933 (let ((result (proc ctx))) 2934 (ctx-resources-used-rd-set! ctx save-rsrc-rd) 2935 (ctx-resources-used-wr-set! ctx save-rsrc-wr) 2936 (ctx-globals-used-set! ctx save-glob-rd) 2937 result))) 2938 2939(define (make-resource-set) 2940 (cons (make-table) '())) 2941 2942(define (resource-set-add! set element) 2943 (let ((t (car set))) 2944 (if (not (table-ref t element #f)) 2945 (begin 2946 (table-set! t element #t) 2947 (set-cdr! set (cons element (cdr set))))))) 2948 2949(define (resource-set-member? set element) 2950 (table-ref (car set) element #f)) 2951 2952(define (resource-set-stack set) 2953 (cdr set)) 2954 2955(define (resource-set-pop set) 2956 (let ((s (cdr set))) 2957 (if (pair? s) 2958 (begin 2959 (set-cdr! set (cdr s)) 2960 (car s)) 2961 #f))) 2962 2963(define (use-resource-rd ctx resource) 2964 (resource-set-add! (ctx-resources-used-rd ctx) resource)) 2965 2966(define (use-resource-wr ctx resource) 2967 (resource-set-add! (ctx-resources-used-wr ctx) resource)) 2968 2969(define (use-global ctx global) 2970 (resource-set-add! (ctx-globals-used ctx) global)) 2971 2972(define (univ-use-rtlib ctx feature) 2973 ;;(pp (list 'use-rtlib feature));;;;;;;;;;;; 2974 (resource-set-add! (ctx-rtlib-features-used ctx) feature) 2975 (symbol->string feature)) 2976 2977(define (use-resource ctx dir resource) 2978 (if (or (eq? dir 'rd) (eq? dir 'rdwr)) 2979 (use-resource-rd ctx resource)) 2980 (if (or (eq? dir 'wr) (eq? dir 'rdwr)) 2981 (use-resource-wr ctx resource))) 2982 2983(define (gvm-state-pollcount ctx) 2984 (^rts-field-use 'pollcount)) 2985 2986(define (gvm-state-nargs ctx) 2987 (^rts-field-use 'nargs)) 2988 2989(define (gvm-state-reg ctx num) 2990 (^rts-field-use (string->symbol (string-append "r" (number->string num))))) 2991 2992(define (gvm-state-stack ctx) 2993 (^rts-field-use 'stack)) 2994 2995(define (gvm-state-sp ctx) 2996 (^rts-field-use 'sp)) 2997 2998(define (gvm-state-peps ctx) 2999 (^rts-field-use 'peps)) 3000 3001(define (gvm-state-glo ctx) 3002 (^rts-field-use 'glo)) 3003 3004(define (gvm-state-pollcount-use ctx dir) 3005 (use-resource ctx dir 'pollcount) 3006 (gvm-state-pollcount ctx)) 3007 3008(define (gvm-state-nargs-use ctx dir) 3009 (use-resource ctx dir 'nargs) 3010 (gvm-state-nargs ctx)) 3011 3012(define (gvm-state-reg-use ctx dir num) 3013 (use-resource ctx dir num) 3014 (gvm-state-reg ctx num)) 3015 3016(define (gvm-state-stack-use ctx dir) 3017 (use-resource ctx dir 'stack) 3018 (gvm-state-stack ctx)) 3019 3020(define (gvm-state-sp-use ctx dir) 3021 (use-resource ctx dir 'sp) 3022 (gvm-state-sp ctx)) 3023 3024(define (gvm-state-peps-use ctx dir) 3025 (use-resource ctx dir 'peps) 3026 (gvm-state-peps ctx)) 3027 3028(define (gvm-state-glo-use ctx dir) 3029 (use-resource ctx dir 'glo) 3030 (gvm-state-glo ctx)) 3031 3032(define (univ-emit-tos ctx) 3033 (^array-index 3034 (gvm-state-stack-use ctx 'rd) 3035 (gvm-state-sp-use ctx 'rd))) 3036 3037(define (univ-emit-pop ctx receiver) 3038 (^ (receiver (^tos)) 3039 (^inc-by (gvm-state-sp-use ctx 'rdwr) 3040 -1))) 3041 3042(define (univ-emit-push ctx val) 3043 (^inc-by (gvm-state-sp-use ctx 'rdwr) 3044 1 3045 (lambda (x) 3046 (^assign 3047 (^array-index 3048 (gvm-state-stack-use ctx 'rd) 3049 x) 3050 val)))) 3051 3052(define (univ-emit-getnargs ctx) 3053 (gvm-state-nargs-use ctx 'rd)) 3054 3055(define (univ-emit-setnargs ctx nb-args) 3056 (^assign 3057 (gvm-state-nargs-use ctx 'wr) 3058 nb-args)) 3059 3060(define (univ-emit-getreg ctx num) 3061 (gvm-state-reg-use ctx 'rd num)) 3062 3063(define (univ-emit-setreg ctx num val) 3064 (^assign 3065 (gvm-state-reg-use ctx 'wr num) 3066 val)) 3067 3068(define (univ-stk-slot-from-tos ctx offset) 3069 (^array-index 3070 (gvm-state-stack-use ctx 'rd) 3071 (^- (gvm-state-sp-use ctx 'rd) 3072 offset))) 3073 3074(define (univ-stk-location ctx offset) 3075 (^array-index 3076 (gvm-state-stack-use ctx 'rd) 3077 (^ (gvm-state-sp-use ctx 'rd) 3078 (cond ((= offset 0) 3079 (^)) 3080 ((< offset 0) 3081 (^ offset)) 3082 (else 3083 (^ "+" offset)))))) 3084 3085(define (univ-emit-getstk ctx offset) 3086 (univ-stk-location ctx offset)) 3087 3088(define (univ-emit-setstk ctx offset val) 3089 (^assign 3090 (univ-stk-location ctx offset) 3091 val)) 3092 3093(define (univ-clo-slots ctx closure) 3094 (case (univ-procedure-representation ctx) 3095 3096 ((class) 3097 (^member (^cast* 'closure closure) 'slots)) 3098 3099 (else 3100 (case (target-name (ctx-target ctx)) 3101 ((php) 3102 ;;(^member (^cast* 'closure closure) 'slots) 3103 (^member closure 'slots)) 3104 (else 3105 (^jump closure (^bool #t))))))) 3106 3107(define (univ-emit-getclo ctx closure index) 3108 (^closure-ref closure index)) 3109 3110(define (univ-emit-setclo ctx closure index val) 3111 (^closure-set! closure index val)) 3112 3113(define (univ-glo-dependency ctx name dir) 3114 (univ-glo-use ctx name dir) 3115 (gvm-state-glo-use ctx 'rd) 3116 (if (member name 3117 '(println 3118 real-time-milliseconds 3119 ##exit-process)) 3120 (begin 3121 (univ-glo-use ctx name 'wr) ;; automatically defined primitives 3122 (univ-use-rtlib 3123 ctx 3124 (string->symbol (string-append "glo-" (symbol->string name))))))) 3125 3126(define (univ-glo-use ctx name dir) 3127 (let* ((t (ctx-glo-used ctx)) 3128 (x (table-ref t name #f))) 3129 (table-set! t name (if (or (not x) (eq? dir x)) dir 'rdwr)))) 3130 3131(define (univ-emit-getpeps ctx name) 3132 (^dict-get (gvm-state-peps-use ctx 'rd) 3133 (^str (symbol->string name)))) 3134 3135(define (univ-emit-setpeps ctx name val) 3136 (^dict-set (gvm-state-peps-use ctx 'rd) 3137 (^str (symbol->string name)) 3138 val)) 3139 3140(define (univ-emit-getglo ctx name) 3141 (univ-glo-dependency ctx name 'rd) 3142 (^dict-get (gvm-state-glo-use ctx 'rd) 3143 (^str (symbol->string name)))) 3144 3145(define (univ-emit-setglo ctx name val) 3146 (univ-glo-dependency ctx name 'wr) 3147 (^dict-set (gvm-state-glo-use ctx 'rd) 3148 (^str (symbol->string name)) 3149 val)) 3150 3151(define (univ-emit-glo-var-ref ctx sym) 3152 (^dict-get (gvm-state-glo-use ctx 'rd) 3153 (^symbol-unbox sym))) 3154 3155(define (univ-emit-glo-var-primitive-ref ctx sym) 3156 (^dict-get (gvm-state-peps-use ctx 'rd) 3157 (^symbol-unbox sym))) 3158 3159(define (univ-emit-glo-var-set! ctx sym val) 3160 (^dict-set (gvm-state-glo-use ctx 'rd) 3161 (^symbol-unbox sym) 3162 val)) 3163 3164(define (univ-emit-glo-var-primitive-set! ctx sym val) 3165 (^dict-set (gvm-state-peps-use ctx 'rd) 3166 (^symbol-unbox sym) 3167 val)) 3168 3169(define (univ-emit-getopnd ctx gvm-opnd) 3170 3171 (cond ((reg? gvm-opnd) 3172 (^getreg (reg-num gvm-opnd))) 3173 3174 ((stk? gvm-opnd) 3175 (^getstk (+ (stk-num gvm-opnd) (ctx-stack-base-offset ctx)))) 3176 3177 ((glo? gvm-opnd) 3178 (^getglo (glo-name gvm-opnd))) 3179 3180 ((clo? gvm-opnd) 3181 (^getclo (^getopnd (clo-base gvm-opnd)) 3182 (clo-index gvm-opnd))) 3183 3184 ((lbl? gvm-opnd) 3185 (gvm-lbl-use ctx gvm-opnd)) 3186 3187 ((obj? gvm-opnd) 3188 (^obj (obj-val gvm-opnd))) 3189 3190 (else 3191 (compiler-internal-error 3192 "univ-emit-getopnd, unknown 'gvm-opnd':" 3193 gvm-opnd)))) 3194 3195(define (univ-emit-getopnds ctx gvm-opnds) 3196 (map (lambda (gvm-opnd) (univ-emit-getopnd ctx gvm-opnd)) 3197 gvm-opnds)) 3198 3199(define (univ-emit-setloc ctx gvm-loc val) 3200 3201 (cond ((reg? gvm-loc) 3202 (^setreg (reg-num gvm-loc) 3203 val)) 3204 3205 ((stk? gvm-loc) 3206 (^setstk (+ (stk-num gvm-loc) (ctx-stack-base-offset ctx)) 3207 val)) 3208 3209 ((glo? gvm-loc) 3210 (^setglo (glo-name gvm-loc) 3211 val)) 3212 3213 ((clo? gvm-loc) 3214 (^setclo (^getopnd (clo-base gvm-loc)) 3215 (clo-index gvm-loc) 3216 val)) 3217 3218 (else 3219 (compiler-internal-error 3220 "univ-emit-setloc, unknown 'gvm-loc':" 3221 gvm-loc)))) 3222 3223(define (univ-emit-obj* ctx obj force-var?) 3224 3225 (cond ((or (false-object? obj) 3226 (boolean? obj)) 3227 (^boolean-obj obj)) 3228 3229 ((number? obj) 3230 (cond ((not (real? obj)) ;; non-real complex number 3231 (univ-obj-use 3232 ctx 3233 obj 3234 force-var? 3235 (lambda () 3236 (^cpxnum-make (univ-emit-obj* ctx (real-part obj) #f) 3237 (univ-emit-obj* ctx (imag-part obj) #f))))) 3238 3239 ((not (exact? obj)) ;; floating-point number 3240 (^flonum-box (^float obj))) 3241 3242 ((not (integer? obj)) ;; non-integer rational number 3243 (univ-obj-use 3244 ctx 3245 obj 3246 force-var? 3247 (lambda () 3248 (^ratnum-make (univ-emit-obj* ctx (numerator obj) #f) 3249 (univ-emit-obj* ctx (denominator obj) #f))))) 3250 3251 (else ;; exact integer 3252 (if (and (>= obj univ-fixnum-min) 3253 (<= obj univ-fixnum-max)) 3254 3255 (^fixnum-box (^int obj)) 3256 3257 (univ-obj-use 3258 ctx 3259 obj 3260 force-var? 3261 (lambda () 3262 (^new (^type 'bignum) 3263 (^array-literal 3264 'bigdigit 3265 (univ-bignum->digits obj))))))))) 3266 3267 ((char? obj) 3268 (^char-obj obj force-var?)) 3269 3270 ((string? obj) 3271 (^string-obj obj force-var?)) 3272 3273 ((symbol-object? obj) 3274 (^symbol-obj obj force-var?)) 3275 3276 ((keyword-object? obj) 3277 (^keyword-obj obj force-var?)) 3278 3279 ((null? obj) 3280 (^null-obj)) 3281 3282 ((void-object? obj) 3283 (^void-obj)) 3284 3285 ((end-of-file-object? obj) 3286 (^eof)) 3287 3288 ((absent-object? obj) 3289 (^absent)) 3290 3291 ((deleted-object? obj) 3292 (^deleted)) 3293 3294 ((unused-object? obj) 3295 (^unused)) 3296 3297 ((unbound1-object? obj) 3298 (^unbound1)) 3299 3300 ((unbound2-object? obj) 3301 (^unbound2)) 3302 3303 ((optional-object? obj) 3304 (^optional)) 3305 3306 ((key-object? obj) 3307 (^key)) 3308 3309 ((rest-object? obj) 3310 (^rest)) 3311 3312 ((proc-obj? obj) 3313 (let ((name (proc-obj-name obj))) 3314 (if (proc-obj-code obj) ;; procedure defined in this module? 3315 (^this-mod-jumpable (gvm-proc-use ctx name)) 3316 (^getpeps (string->symbol name))))) 3317 3318 ((pair? obj) 3319 (univ-obj-use 3320 ctx 3321 obj 3322 force-var? 3323 (lambda () 3324 (^cons (univ-emit-obj* ctx (car obj) #f) 3325 (univ-emit-obj* ctx (cdr obj) #f))))) 3326 3327 ((vector-object? obj) 3328 (univ-obj-use 3329 ctx 3330 obj 3331 force-var? 3332 (lambda () 3333 (^vector-box 3334 (^array-literal 3335 'scmobj 3336 (map (lambda (x) (univ-emit-obj* ctx x #f)) 3337 (vector->list obj))))))) 3338 3339 ((u8vect? obj) 3340 (univ-obj-use 3341 ctx 3342 obj 3343 force-var? 3344 (lambda () 3345 (^u8vector-box 3346 (^array-literal 3347 'u8 3348 (map (lambda (x) (^num-of-type 'u8 x)) 3349 (u8vect->list obj))))))) 3350 3351 ((u16vect? obj) 3352 (univ-obj-use 3353 ctx 3354 obj 3355 force-var? 3356 (lambda () 3357 (^u16vector-box 3358 (^array-literal 3359 'u16 3360 (map (lambda (x) (^num-of-type 'u16 x)) 3361 (u16vect->list obj))))))) 3362 3363 ((u32vect? obj) 3364 (univ-obj-use 3365 ctx 3366 obj 3367 force-var? 3368 (lambda () 3369 (^u32vector-box 3370 (^array-literal 3371 'u32 3372 (map (lambda (x) (^num-of-type 'u32 x)) 3373 (u32vect->list obj))))))) 3374 3375 ((u64vect? obj) 3376 (univ-obj-use 3377 ctx 3378 obj 3379 force-var? 3380 (lambda () 3381 (^u64vector-box 3382 (^array-literal 3383 'u64 3384 (map (lambda (x) (^num-of-type 'u64 x)) 3385 (u64vect->list obj))))))) 3386 3387 ((s8vect? obj) 3388 (univ-obj-use 3389 ctx 3390 obj 3391 force-var? 3392 (lambda () 3393 (^s8vector-box 3394 (^array-literal 3395 's8 3396 (map (lambda (x) (^num-of-type 's8 x)) 3397 (s8vect->list obj))))))) 3398 3399 ((s16vect? obj) 3400 (univ-obj-use 3401 ctx 3402 obj 3403 force-var? 3404 (lambda () 3405 (^s16vector-box 3406 (^array-literal 3407 's16 3408 (map (lambda (x) (^num-of-type 's16 x)) 3409 (s16vect->list obj))))))) 3410 3411 ((s32vect? obj) 3412 (univ-obj-use 3413 ctx 3414 obj 3415 force-var? 3416 (lambda () 3417 (^s32vector-box 3418 (^array-literal 3419 's32 3420 (map (lambda (x) (^num-of-type 's32 x)) 3421 (s32vect->list obj))))))) 3422 3423 ((s64vect? obj) 3424 (univ-obj-use 3425 ctx 3426 obj 3427 force-var? 3428 (lambda () 3429 (^s64vector-box 3430 (^array-literal 3431 's64 3432 (map (lambda (x) (^num-of-type 's64 x)) 3433 (s64vect->list obj))))))) 3434 3435 ((f32vect? obj) 3436 (univ-obj-use 3437 ctx 3438 obj 3439 force-var? 3440 (lambda () 3441 (^f32vector-box 3442 (^array-literal 3443 'f32 3444 (map (lambda (x) (^num-of-type 'f32 x)) 3445 (f32vect->list obj))))))) 3446 3447 ((f64vect? obj) 3448 (univ-obj-use 3449 ctx 3450 obj 3451 force-var? 3452 (lambda () 3453 (^f64vector-box 3454 (^array-literal 3455 'f64 3456 (map (lambda (x) (^num-of-type 'f64 x)) 3457 (f64vect->list obj))))))) 3458 3459 ((structure-object? obj) 3460 (univ-obj-use 3461 ctx 3462 obj 3463 force-var? 3464 (lambda () 3465 (let* ((slots 3466 (##vector-copy obj)) ;;TODO: replace call of ##vector-copy 3467 (cyclic? 3468 (eq? (vector-ref slots 0) obj))) 3469 (^structure-box 3470 (^array-literal 3471 'scmobj 3472 (cons (if cyclic? ;; the root type descriptor is cyclic 3473 (^null) ;; handle this specially 3474 (univ-emit-obj* ctx (vector-ref slots 0) #f)) 3475 (map (lambda (x) (univ-emit-obj* ctx x #f)) 3476 (cdr (vector->list slots)))))))))) 3477 3478 (else 3479 (compiler-user-warning #f "UNIMPLEMENTED OBJECT:" obj) 3480 (^str 3481 (string-append 3482 "UNIMPLEMENTED OBJECT: " 3483 (object->string obj)))))) 3484 3485(define (univ-emit-obj ctx obj) 3486 (univ-emit-obj* ctx obj #t)) 3487 3488(define (univ-obj-type obj) 3489 3490 (cond ((or (false-object? obj) 3491 (boolean? obj)) 3492 'boolean) 3493 3494 ((number? obj) 3495 (cond ((not (real? obj)) ;; non-real complex number 3496 'cpxnum) 3497 3498 ((not (exact? obj)) ;; floating-point number 3499 'flonum) 3500 3501 ((not (integer? obj)) ;; non-integer rational number 3502 'ratnum) 3503 3504 (else ;; exact integer 3505 (if (and (>= obj univ-fixnum-min) 3506 (<= obj univ-fixnum-max)) 3507 'fixnum 3508 'bignum)))) 3509 3510 ((char? obj) 3511 'char) 3512 3513 ((string? obj) 3514 'string) 3515 3516 ((symbol-object? obj) 3517 'symbol) 3518 3519 ((keyword-object? obj) 3520 'keyword) 3521 3522 ((null? obj) 3523 'null) 3524 3525 ((void-object? obj) 3526 'void) 3527 3528 ((end-of-file-object? obj) 3529 'eof) 3530 3531 ((absent-object? obj) 3532 'absent) 3533 3534 ((deleted-object? obj) 3535 'deleted) 3536 3537 ((unused-object? obj) 3538 'unused) 3539 3540 ((or (unbound1-object? obj) 3541 (unbound2-object? obj)) 3542 'unbound) 3543 3544 ((optional-object? obj) 3545 'optional) 3546 3547 ((key-object? obj) 3548 'key) 3549 3550 ((rest-object? obj) 3551 'rest) 3552 3553 ((proc-obj? obj) 3554 (if (proc-obj-code obj) ;; procedure defined in this module? 3555 'jumpable 3556 'parententrypoint)) 3557 3558 ((pair? obj) 3559 'pair) 3560 3561 ((vector-object? obj) 3562 'vector) 3563 3564 ((u8vect? obj) 3565 'u8vector) 3566 3567 ((u16vect? obj) 3568 'u16vector) 3569 3570 ((u32vect? obj) 3571 'u32vector) 3572 3573 ((u64vect? obj) 3574 'u64vector) 3575 3576 ((s8vect? obj) 3577 's8vector) 3578 3579 ((s16vect? obj) 3580 's16vector) 3581 3582 ((s32vect? obj) 3583 's32vector) 3584 3585 ((s64vect? obj) 3586 's64vector) 3587 3588 ((f32vect? obj) 3589 'f32vector) 3590 3591 ((f64vect? obj) 3592 'f64vector) 3593 3594 ((structure-object? obj) 3595 'structure) 3596 3597 (else 3598 ;;TODO: handle these types better 3599 ;; box 3600 ;; closure 3601 ;; continuation 3602 ;; foreign 3603 ;; promise 3604 ;; values 3605 ;; will 3606 'scmobj))) 3607 3608(define univ-mdigit-width 14) 3609(define univ-mdigit-base (expt 2 univ-mdigit-width)) 3610(define univ-mdigit-base-minus-1 (- univ-mdigit-base 1)) 3611 3612(define (univ-bignum->digits obj) 3613 3614 (define (dig n len rest) 3615 (cond ((= len 1) 3616 (cons n rest)) 3617 (else 3618 (let* ((hi-len (quotient len 2)) 3619 (lo-len (- len hi-len)) 3620 (lo-len-bits (* univ-mdigit-width lo-len))) 3621 (let* ((hi (arithmetic-shift n (- lo-len-bits))) 3622 (lo (- n (arithmetic-shift hi lo-len-bits)))) 3623 (dig lo 3624 lo-len 3625 (dig hi 3626 hi-len 3627 rest))))))) 3628 3629 (let* ((width (integer-length obj)) 3630 (len (+ (quotient width univ-mdigit-width) 1))) 3631 (dig (if (< obj 0) 3632 (+ (arithmetic-shift 1 (* univ-mdigit-width len)) obj) 3633 obj) 3634 len 3635 '()))) 3636 3637(define (univ-js-typed-array-constructor ctx type) 3638 (case type 3639 ((s8) "Int8Array") 3640 ((u8) "Uint8Array") 3641 ((s16) "Int16Array") 3642 ((u16) "Uint16Array") 3643 ((s32) "Int32Array") 3644 ((u32) "Uint32Array") 3645 ((f32) "Float32Array") 3646 ((f64) "Float64Array") 3647 (else #f))) 3648 3649(define (univ-array-constructor ctx type) 3650 (case (target-name (ctx-target ctx)) 3651 3652 ((js) 3653 (or (univ-js-typed-array-constructor ctx type) 3654 "Array")) 3655 3656 (else 3657 #f))) 3658 3659(define (univ-emit-array-literal ctx type elems) 3660 (case (target-name (ctx-target ctx)) 3661 3662 ((js) 3663 (let ((array (^ "[" (univ-separated-list "," elems) "]")) 3664 (typed-array-constructor (univ-js-typed-array-constructor ctx type))) 3665 (if typed-array-constructor 3666 (^new typed-array-constructor array) 3667 array))) 3668 3669 ((python ruby) 3670 (^ "[" (univ-separated-list "," elems) "]")) 3671 3672 ((php) 3673 (^apply "array" elems)) 3674 3675 ((java) 3676 (^ "new " (^type (list 'array type)) "{" (univ-separated-list "," elems) "}")) 3677 3678 (else 3679 (compiler-internal-error 3680 "univ-emit-array-literal, unknown target")))) 3681 3682(define (univ-emit-extensible-array-literal ctx type elems) 3683 (case (target-name (ctx-target ctx)) 3684 3685 ((python) 3686 (let ((key-vals 3687 (let loop ((i 0) (lst elems) (rev-kv '())) 3688 (if (pair? lst) 3689 (loop (+ i 1) 3690 (cdr lst) 3691 (cons (^ i ":" (car lst)) rev-kv)) 3692 (reverse rev-kv))))) 3693 (^ "{" (univ-separated-list "," key-vals) "}"))) 3694 3695 (else 3696 (univ-emit-array-literal ctx type elems)))) 3697 3698(define (univ-emit-make-stack ctx) 3699 (case (target-name (ctx-target ctx)) 3700 3701 ((js php python ruby) 3702 (^extensible-array-literal 'scmobj '())) 3703 3704 ((java) 3705 (^new-array 'scmobj 10000));;TODO: fix size 3706 3707 (else 3708 (compiler-internal-error 3709 "univ-emit-make-stack, unknown target")))) 3710 3711(define (univ-emit-new-array ctx type len) 3712 (case (target-name (ctx-target ctx)) 3713 3714 ((js) 3715 (^new (^type (list 'array type)) len)) 3716 3717 ((php) 3718 (^if-expr (^= len (^int 0)) ;; array_fill does not like len=0 3719 (^array-literal type '()) 3720 (^call-prim 3721 "array_fill" 3722 (^int 0) 3723 len 3724 (^int 0)))) 3725 3726 ((python) 3727 (^* (^ "[" (^int 0) "]") len)) 3728 3729 ((ruby) 3730 (^call-prim (^member "Array" 'new) len)) 3731 3732 ((java) 3733 (^ "new " (^type type) "[" len "]")) 3734 3735 (else 3736 (compiler-internal-error 3737 "univ-emit-new-array, unknown target")))) 3738 3739(define (univ-emit-make-array ctx type return len init) 3740 (case (target-name (ctx-target ctx)) 3741 3742 ((js) 3743 ;; TODO: add for loop constructor 3744 (let ((elems (^local-var 'elems))) 3745 (^ (^var-declaration 3746 (list 'array type) 3747 elems 3748 (^new-array type len)) 3749 " 3750 for (var i=0; i<" len "; i++) { 3751 " elems "[i] = " init "; 3752 } 3753 " 3754 (return elems)))) 3755 3756 ((php) 3757 (return 3758 (^if-expr (^= len (^int 0)) ;; array_fill does not like len=0 3759 (^array-literal type '()) 3760 (^call-prim 3761 "array_fill" 3762 (^int 0) 3763 len 3764 init)))) 3765 3766 ((python) 3767 ;; TODO: add literal array constructor 3768 (return 3769 (^* (^ "[" init "]") len))) 3770 3771 ((ruby) 3772 (return 3773 (^call-prim (^member "Array" 'new) len init))) 3774 3775 ((java) 3776 ;; TODO: add for loop constructor 3777 (let ((elems (^local-var 'elems))) 3778 (^ (^var-declaration 3779 (list 'array type) 3780 elems 3781 (^new-array type len)) 3782 " 3783 for (int i=0; i<" len "; i++) { 3784 " elems "[i] = " init "; 3785 } 3786 " 3787 (return elems)))) 3788 3789 (else 3790 (compiler-internal-error 3791 "univ-emit-make-array, unknown target")))) 3792 3793;; ============================================================================= 3794 3795(define (gvm-lbl-use ctx lbl) 3796 (^this-mod-jumpable (gvm-lbl-use-aux ctx lbl))) 3797 3798(define (gvm-lbl-use-aux ctx lbl) 3799 (gvm-bb-use ctx (lbl-num lbl) (ctx-ns ctx))) 3800 3801(define (gvm-proc-use ctx name) 3802 (gvm-bb-use ctx 1 (scheme-id->c-id name))) 3803 3804(define (gvm-bb-use ctx num ns) 3805 (let ((id (lbl->id ctx num ns))) 3806 ;;TODO: remove? 3807 ;;(use-global ctx (^mod-field "AAA" id)) 3808 id)) 3809 3810(define (lbl->id ctx num ns) 3811 (^ univ-bb-prefix num "_" ns)) 3812 3813(define univ-bb-prefix "bb") 3814(define univ-capitalized-bb-prefix "Bb") 3815 3816(define (univ-foldr-range lo hi rest fn) 3817 (if (<= lo hi) 3818 (univ-foldr-range 3819 lo 3820 (- hi 1) 3821 (fn hi rest) 3822 fn) 3823 rest)) 3824 3825(define (univ-pop-args-to-vars ctx nb-args) 3826 (let ((nb-stacked (max 0 (- nb-args (univ-nb-arg-regs ctx))))) 3827 (univ-foldr-range 3828 1 3829 nb-args 3830 (^) 3831 (lambda (i rest) 3832 (^ rest 3833 (let ((x (- i nb-stacked))) 3834 (if (>= x 1) 3835 (^var-declaration 3836 'scmobj 3837 (^local-var (^ 'arg i)) 3838 (^getreg x)) 3839 (^pop (lambda (expr) 3840 (^var-declaration 3841 'scmobj 3842 (^local-var (^ 'arg i)) 3843 expr)))))))))) 3844 3845(define (univ-push-args ctx) 3846 (univ-foldr-range 3847 0 3848 (- (univ-nb-arg-regs ctx) 1) 3849 (^) 3850 (lambda (i rest) 3851 (^if (^> (^getnargs) i) 3852 (^ (^push (^getreg (+ i 1))) 3853 rest))))) 3854 3855(define (univ-pop-args-to-regs ctx lo) 3856 (univ-foldr-range 3857 0 3858 (- (univ-nb-arg-regs ctx) 1) 3859 (^) 3860 (lambda (i rest) 3861 (let ((x 3862 (^ rest 3863 (^pop (lambda (expr) 3864 (^setreg (+ i 1) expr)))))) 3865 (if (< i lo) 3866 x 3867 (^if (^> (^getnargs) (- i lo)) 3868 x)))))) 3869 3870(define (univ-min-memoized-fixnum ctx) 0) 3871(define (univ-max-memoized-fixnum ctx) 256) 3872 3873;;;============================================================================ 3874