1;; lib/vm.scm 2#!core 3;; dummy 4(define *toplevel-variable* '()) 5(define *expand-phase* 0) 6(define (vm-r6rs-mode?) #f) 7;; in case 8(define (vm-slice-let-syntax?) #f) 9(define (vm-noinline-locals?) #f) 10(define (vm-nolambda-lifting?) #f) 11(define (vm-nolibrary-inlining?) #f) 12(define (vm-noconstant-inlining?) #f) 13(define (vm-macro-expand-phase?) 14 (positive? *expand-phase*)) 15 16(define (set-toplevel-variable! sym val) 17 (set! *toplevel-variable* (acons sym val *toplevel-variable*))) 18(define (gloc-ref g) g) 19(define (gloc-bound? g) #t) 20(define (gloc-const? g) 21 ;; not so good, but for booting we don't do global set! so, it's ok. 22 (or (string? g) 23 (number? g) 24 ;; vector can not be const for boot code. 25 #;(vector? g))) 26;; on boot code we don't have set! or redefine ... I assume 27(define (gloc-library g) #f) 28 29(define (cachable? o) 30 (or (string? o) (number? o) (symbol? o))) 31 32(define (vm-warn msg) 33 ;; it was too much to see... 34 #;(format (current-error-port) "WARNING: ~a~%" msg)) 35 36;; for declare-procedure 37(define (parse-type type) 38 (if (and (pair? type) 39 (= (length type) 2)) 40 (cadr type) 41 #f)) 42 43;; this file is the collection of vm procedure. 44;; these procedure must be written in C++ 45(define (insn-name insn) 46 (let ((info (lookup-insn-name insn))) 47 (car info))) 48 49;; for better performance. 50;; this will be called so many times in compiler.scm 51(define p1env-lookup 52 (lambda (p1env name lookup-as) 53 (let ((name-ident? (identifier? name)) 54 (frames (vector-ref p1env 1)) 55 (oname name) 56 (ret #f)) 57 (let loop ((fp frames)) 58 (cond ((pair? fp) 59 (when (and name-ident? (eq? (id-envs name) fp)) 60 (set! name-ident? #f) ;; given name is no longer identifier 61 (set! name (id-name name))) 62 (if (> (caar fp) lookup-as) 63 (loop (cdr fp)) 64 (let loop2 ((tmp (cdar fp))) 65 (if (pair? tmp) 66 (let ((vp (car tmp))) 67 (if (eq? name (car vp)) 68 (cdr vp) 69 (loop2 (cdr tmp)))) 70 (loop (cdr fp)))))) 71 (else 72 (if (symbol? name) 73 (make-identifier name '() (vector-ref p1env 0)) 74 name))))))) 75 76(define p1env-pvar-lookup 77 (lambda (p1env name) 78 (let ((name-ident? (identifier? name)) 79 (frames (vector-ref p1env 1)) 80 (ret #f) 81 (dummy #f)) 82 (when name-ident? 83 (set! dummy `#(,(id-library name) ,(id-envs name)))) 84 (let loop ((fp frames)) 85 (cond ((pair? fp) 86 (when (> (caar fp) 2) 87 (loop (cdr fp))) 88 (let loop2 ((tmp (cdar fp))) 89 (if (pair? tmp) 90 (let ((vp (car tmp))) 91 (if (and name-ident? 92 (identifier=? p1env name dummy (car vp))) 93 (cdr vp) 94 (loop2 (cdr tmp)))) 95 (loop (cdr fp))))) 96 (else 97 (if (symbol? name) 98 (make-identifier name '() (vector-ref p1env 0)) 99 name))))))) 100 101(define p1env-toplevel? 102 (lambda (p1env) 103 (not (any (lambda (frame) (eqv? (car frame) LEXICAL)) 104 (vector-ref p1env 1))))) 105 106;;========================================================================== 107;; Identifiers: 108;; 109;; <name> ::= <symbol> 110;; <envs> ::= (<env> ...) 111;; <library> ::= (<symbol> ...) | #f 112;; <rename?> ::= #f | #t 113;; 114;; where 115;; <name> : The symbolic name of the identifier in the source. 116;; <envs> : p1env frames 117;; <library> : Library name. 118;; <rename?> : only appears in macro expansion 119(define make-identifier 120 (lambda (name envs library) 121 (vector '.identifier 122 name 123 (if (null? envs) 124 '() 125 (get-binding-frame name envs)) 126 (find-library library #f) 127 ;; for bound-id->symbol 128 (gensym) 129 #f 130 #f))) 131 132(define (rename-pending-identifier! id) id) 133 134(define (rename-id id) 135 (if (identifier? id) 136 (let ((new-id (make-identifier (id-name id) (id-envs id) (id-library id)))) 137 (id-renamed?-set! new-id) 138 (id-transformers-env-set! new-id (current-usage-env)) 139 new-id) 140 (let ((new-id (make-identifier id '() (vm-current-library)))) 141 (id-renamed?-set! new-id) 142 (id-transformers-env-set! new-id (current-usage-env)) 143 new-id))) 144 145(define (id-name id) 146 (vector-ref id 1)) 147(define (id-name-set! id v) 148 (vector-set! id 1 v)) 149(define (id-envs id) 150 (vector-ref id 2)) 151(define (id-envs-set! id v) 152 (vector-set! id 2 v)) 153(define (id-library id) 154 (vector-ref id 3)) 155(define (id-library-set! id v) 156 (vector-set! id 3 v)) 157(define (id-renamed? id) 158 (vector-ref id 5)) 159(define (id-renamed?-set! id) 160 (vector-set! id 5 #t)) 161 162(define (id-transformers-env id) 163 (vector-ref id 6)) 164(define (id-transformers-env-set! id e) 165 (vector-set! id 6 e)) 166 167(define (renamed-id? id) 168 (and (identifier? id) 169 (id-renamed? id))) 170 171(define (bound-id->symbol id) 172 (let ((n (format "~a~a" 173 (id-name id) 174 (vector-ref id 4)))) 175 (string->symbol n))) 176 177(define copy-identifier 178 (lambda (id) 179 (make-identifier (id-name id) 180 (id-envs id) 181 (id-library id)))) 182 183(define get-binding-frame 184 (lambda (var env) 185 (let loop ((frame env)) 186 (if (pair? frame) 187 (if (pair? (car frame)) 188 (let loop2 ((fp (cdar frame))) 189 (if (pair? fp) 190 (if (eq? (caar fp) var) 191 frame 192 (loop2 (cdr fp))) 193 (loop (cdr frame)))) 194 (loop (cdr frame))) 195 '())))) 196(define identifier-binding-eqv? 197 (lambda (id sym env) 198 (let ((bf (get-binding-frame sym env))) 199 (eq? bf (id-envs id))))) 200 201;; Sagittarius library systam 202;; Top libraries 203;; Just a hashtable: <key> = library name 204;; <value> = library 205;; Each library 206;; - name : this library's name 207;; - imported : imported symbols for this library 208;; - exported : exported symbols from whis library 209;; - binding table : binding table. 210;; - transient : #t not import after converted to c 211;; - defined : temporary storage for macro expansion 212;; this contains all defined variables in this library. 213 214;; libraries 215;; this might be like this 216;; hashtable -> ((version) . library instance) 217;; ((lib1 => (((1) . <library>) 218;; ((2) . <library>)) 219;; but on scheme VM it's just hashtable to be simple. 220(define *libraries* (make-hashtable equal-hash equal?)) 221(define (make-library library) 222 (let ((lib (vector '.library library '() #f (make-eq-hashtable) #f '()))) 223 (hashtable-set! *libraries* library lib) 224 lib)) 225 226(define (library? lib) 227 (and (vector? lib) 228 (> (vector-length lib) 1) 229 (eq? (vector-ref lib 0) '.library))) 230(define (library-name lib) 231 (vector-ref lib 1)) 232(define (library-imported lib) 233 (vector-ref lib 2)) 234(define (library-imported-set! lib spec) 235 (vector-set! lib 2 spec)) 236(define (library-exported lib) 237 (vector-ref lib 3)) 238(define (library-exported-set! lib spec) 239 (vector-set! lib 3 spec)) 240(define (library-table lib) 241 (vector-ref lib 4)) 242(define (library-transient lib) 243 (vector-ref lib 5)) 244(define (library-transient-set! lib val) 245 (vector-set! lib 5 val)) 246(define (library-defined lib) 247 (vector-ref lib 6)) 248(define (library-defined-add! lib val) 249 (let ((r (cons (if (identifier? val) (id-name val) val) 250 (vector-ref lib 6)))) 251 (vector-set! lib 6 r))) 252 253(define (%set-library lib) 254 (or (library? lib) 255 (error "library required but got " lib)) 256 (hashtable-set! #;(vm-libraries) *libraries* (library-name lib) lib)) 257;; TODO version number... 258(define (find-library name create?) 259 (if (library? name) 260 name 261 (let ((l (hashtable-ref #;(vm-libraries) *libraries* name #f))) 262 (or l 263 (if create? 264 (make-library name) 265 l))))) 266 267(define (%insert-binding library name value) 268 (define (add-export lib name) 269 (if (library-exported lib) 270 (library-exported-set! lib (cons name (library-exported lib))) 271 (library-exported-set! lib (list name)))) 272 273 (cond ((library? library) 274 (hashtable-set! (library-table library) name value)) 275 ((hashtable-ref #;(vm-libraries) *libraries* library #f) ;; maybe just a name? 276 => (lambda (v) 277 (hashtable-set! (library-table v) name value))) 278 ((not library) 279 (%insert-binding (vm-current-library) name value)) 280 (else 281 (let ((lib (make-library library))) 282 (hashtable-set! (library-table lib) name value))))) 283 284(define (find-binding lib name callback) 285 (cond ((library? lib) 286 (let ((r (hashtable-ref (library-table lib) name #f))) 287 (if r 288 r 289 (cond ((assq name *toplevel-variable*) 290 => cdr) 291 (else callback))))) 292 ((hashtable-ref *libraries* lib callback) ;; maybe just a name? 293 => (lambda (lib) 294 (let ((r (hashtable-ref (library-table lib) name #f))) 295 (if r 296 r 297 (cond ((assq name *toplevel-variable*) 298 => cdr) 299 (else callback)))))) 300 ((not lib) 301 (find-binding (vm-current-library) name callback)) 302 (else callback))) 303 304;(define *compiler-library* '(sagittarius compiler)) 305(define *current-library* 'user) 306(define vm-current-library 307 (lambda name 308 (if (null? name) 309 *current-library* 310 (set! *current-library* (car name))))) 311 312;; just stub 313(define (import-library to from resolved-spec trans?) 314 (if trans? 315 (library-transient-set! from #t) 316 (library-transient-set! from #f)) 317 (let* ((lib (if (library? from) 318 from 319 (find-library from #f))) 320 (export-spec (library-exported lib))) 321 (when (and lib 322 #;(not (assq lib (library-imported to)))) 323 (unless (assq lib (library-imported to)) 324 (library-imported-set! to 325 (acons lib 326 export-spec 327 (library-imported to)))) 328 (if (and export-spec (memq :all (car export-spec))) 329 (hashtable-for-each 330 (lambda (k v) (hashtable-set! (library-table to) k v)) 331 (library-table lib)) 332 (hashtable-for-each 333 (lambda (k v) 334 (cond ((not export-spec) 335 ;; maybe null or user library 336 (hashtable-set! (library-table to) k v)) 337 ((memq k (car export-spec)) 338 ;; no rename just put 339 (hashtable-set! (library-table to) k v)) 340 ((assq k (cdr export-spec)) => 341 (lambda (spec) 342 (hashtable-set! (library-table to) (cdr spec) v))))) 343 (library-table lib)))))) 344;; for vm.scm 345(define (load-library to . from) 346 (let loop ((from from)) 347 (if (null? from) 348 #t 349 (let ((name (car from))) 350 (let* ((lib (if (library? name) 351 name 352 (find-library name #f))) 353 (export-spec (library-exported lib))) 354 (when (and lib 355 #;(not (assq lib (library-imported to)))) 356 (unless (assq lib (library-imported to)) 357 (library-imported-set! to 358 (acons lib 359 export-spec 360 (library-imported to)))) 361 (hashtable-for-each 362 (lambda (k v) 363 (cond ((not export-spec) 364 ;; maybe null or user library 365 (hashtable-set! (library-table to) k v)) 366 ((memq k (car export-spec)) 367 ;; no rename just put 368 (hashtable-set! (library-table to) k v)) 369 ((assq k (cdr export-spec)) => 370 (lambda (spec) 371 (hashtable-set! (library-table to) (cdr spec) v))))) 372 (library-table lib))) 373 (loop (cdr from))))))) 374 375#;(define (import-only to from symbols) 376 (library-imported-set! to 377 (acons from symbols (library-imported to))) 378 (for-each (lambda (sym) 379 (hashtable-set! (library-table to) 380 sym 381 (hashtable-ref (library-table from) 382 sym))) 383 symbols)) 384 385#;(define (import-rename to from rename prefix?) 386 (define (add-prefix prefix) 387 (let ((keys (hashtable-keys (library-table from)))) 388 (let loop ((keys keys) 389 (r '())) 390 (cond ((null? keys) r) 391 (else 392 (let ((renamed (string->symbol 393 (string-append (symbol->string prefix) 394 (symbol->string (car keys)))))) 395 (loop (cdr keys) (cons (list (car keys) renamed) r)))))))) 396 (let ((renames rename)) 397 (if prefix? 398 (set! renames (add-prefix rename))) 399 (let loop ((renames renames)) 400 (unless (null? renames) 401 (unless (= (length (car renames)) 2) 402 (error "syntax-error: malformed rename spec in import clause:" rename)) 403 (let ((org (caar renames)) 404 (renamed (cadar renames))) 405 (hashtable-set! (library-table to) renamed 406 (hashtable-ref (library-table from) org))) 407 (loop (cdr renames)))))) 408 409(define (make-syntax name proc . user-defined?) 410 (if (null? user-defined?) 411 (vector 'type:syntax name proc #f) 412 (vector 'type:syntax name proc #t))) 413 414(define (syntax? s) 415 (and (vector? s) 416 (eq? (vector-ref s 0) 'type:syntax))) 417(define (syntax-name s) 418 (vector-ref s 1)) 419(define (syntax-proc s) 420 (vector-ref s 2)) 421(define (builtin-syntax? s) 422 (and (syntax? s) 423 (not (vector-ref s 3)))) 424(define (user-defined-syntax? s) 425 (and (syntax? s) 426 (vector-ref s 3))) 427 428(define (call-syntax-handler s expr p1env) 429 (cond ((builtin-syntax? s) 430 ((syntax-proc s) expr p1env)) 431 (else 432 (error 'call-syntax-handler "bug?")))) 433 434(define (unwrap-syntax form . only-global?) 435 (define rec 436 (lambda (form history) 437 (cond ((or (fixnum? form) 438 (char? form) 439 (boolean? form)) form) 440 ((memq form history) form) 441 ((pair? form) 442 (let* ((newh (cons form history)) 443 (ca (rec (car form) newh)) 444 (cd (rec (cdr form) newh))) 445 (if (and (eq? ca (car form)) 446 (eq? cd (cdr form))) 447 form 448 (cons ca cd)))) 449 ((identifier? form) 450 (id-name form)) 451 ((and (vector? form) 452 (> (vector-length form) 1) 453 (eq? (vector-ref form 0) '.closure)) 454 'closure) 455 ((library? form) 456 (library-name form)) 457 ((vector? form) 458 (let ((len (vector-length form)) 459 (newh (cons form history))) 460 (let loop ((i 0)) 461 (cond ((= i len) form) 462 (else 463 (let* ((pe (vector-ref form i)) 464 (e (rec pe newh))) 465 (cond ((eq? e pe) 466 (loop (+ i 1))) 467 (else 468 (let ((v (make-vector len #f))) 469 (let vcopy ((j 0)) 470 (unless (= j i) 471 (vector-set! v j (vector-ref form j)) 472 (vcopy (+ j 1)))) 473 (vector-set! v i e) 474 (let vcopy ((j i)) 475 (unless (= j len) 476 (vector-set! v j (vector-ref form j)) 477 (vcopy (+ j 1)))) 478 v))))))))) 479 (else form)))) 480 (if (null? only-global?) 481 (rec form '()) 482 form)) ; for scheme VM we don't do any thing 483 484(define (unwrap-syntax-with-reverse form) (unwrap-syntax form)) 485 486(define wrap-syntax 487 (lambda (form p1env . opts) 488 (define env-lookup 489 (lambda (form p1env) 490 (let loop ((frames (vector-ref p1env 1))) 491 (cond ((null? frames) frames) 492 (else 493 (let lp ((vtmp (cdar frames))) 494 (cond ((null? vtmp) 495 (loop (cdr frames))) 496 ((eq? form (caar vtmp)) frames) 497 (else (lp (cdr vtmp)))))))))) 498 499 (define rec 500 (lambda (form p1env seen partial?) 501 (cond ((null? form) form) 502 ((pair? form) (cons (rec (car form) p1env seen partial?) 503 (rec (cdr form) p1env seen partial?))) 504 ((identifier? form) form) 505 #;((closure? form) form) 506 ((procedure? form) form) 507 ((vector? form) 508 (list->vector (rec (vector->list form) p1env seen partial?))) 509 ((symbol? form) 510 (let ((id (hashtable-ref seen form #f))) 511 (if id 512 id 513 (let ((env (env-lookup form p1env))) 514 (cond ((and (null? env) 515 (not partial?)) 516 (set! id (make-identifier form 517 (vector-ref p1env 1) 518 (vector-ref p1env 0))) 519 (hashtable-set! seen form id) 520 id) 521 ((not (null? env)) 522 (set! id (make-identifier form 523 env 524 (vector-ref p1env 0))) 525 (hashtable-set! seen form id) 526 id) 527 (else form)))))) 528 (else form)))) 529 (let ((seen (if (null? opts) (make-eq-hashtable) (car opts))) 530 (partial? (if (or (null? opts) 531 (null? (cdr opts))) 532 #f 533 (cadr opts)))) 534 (rec form p1env seen partial?)))) 535 536(define (make-macro name transformer data env . maybe-library) 537 (vector 'type:macro name transformer data env 538 (if (null? maybe-library) 539 #f 540 (car maybe-library)))) 541 542(define (variable-transformer? o) 543 (and (macro? o) (null? (macro-data o)))) 544 545(define (macro-name m) 546 (vector-ref m 1)) 547(define (macro-transformer m) 548 (vector-ref m 2)) 549(define (macro-data m) 550 (vector-ref m 3)) 551(define (macro-env m) 552 (vector-ref m 4)) 553(define (macro-library m) 554 (vector-ref m 5)) 555(define (macro? m) 556 (and (vector? m) (eq? (vector-ref m 0) 'type:macro))) 557(define (call-macro-expander macro expr p1env) 558 ((macro-transformer macro) macro expr p1env (macro-data macro))) 559(define (unbound) (if #f #f)) 560 561(define (make-toplevel-closure cb) 562 (make-closure cb 0)) 563 564;; for er-macro-transformer 565(define macro-transform 566 (lambda (self form p1env data) 567 (let ((expander (apply-proc data '())) 568 (mac-env (macro-env self)) 569 (uenv-save (current-usage-env)) 570 (menv-save (current-macro-env))) 571 (current-usage-env-set! p1env) 572 (current-macro-env-set! mac-env) 573 (if (macro? expander) 574 (let ((r (apply-proc (macro-transformer expander) (list expander form p1env (macro-data expander))))) 575 (current-usage-env-set! uenv-save) 576 (current-macro-env-set! menv-save) 577 r) 578 (let ((r (apply-proc expander (list form)))) 579 (current-usage-env-set! uenv-save) 580 (current-macro-env-set! menv-save) 581 r)) 582 #;(if (macro? expander) 583 ((macro-transformer expander) expander form p1env (macro-data expander)) 584 (apply-proc expander (list (cons form p1env))))))) 585 586(define make-macro-transformer 587 (lambda (name proc env library) 588 (make-macro name macro-transform proc env library))) 589 590(define %internal-macro-expand 591 (lambda (expr p1env once?) 592 (let loop ((expr expr)) 593 (cond ((null? expr) '()) 594 ((not (pair? expr)) expr) 595 ;; ((xx ...) ...) 596 ((pair? (car expr)) 597 (cons (loop (car expr)) 598 (loop (cdr expr)))) 599 (else 600 (let ((g #f) 601 (mac #f) 602 (sym (car expr))) 603 (cond ((identifier? sym) 604 (set! g (find-binding (id-library sym) 605 (id-name sym) 606 #f))) 607 ((symbol? sym) 608 (set! g (find-binding (vector-ref p1env 0) 609 sym 610 #f)))) 611 (if (macro? g) 612 (set! mac g) 613 ;; try local macro 614 (let ((g (p1env-lookup p1env sym SYNTAX))) 615 (if (macro? g) 616 (set! mac g)))) 617 (if mac 618 ;; expand and continue 619 (if once? 620 (call-macro-expander mac expr p1env) 621 (loop (call-macro-expander mac expr p1env))) 622 ;; symbol 623 (cons (car expr) (loop (cdr expr)))))))))) 624 625 626(define (%map-cons l1 l2) (map cons l1 l2)) 627;(define LEXICAL 0) 628;(define SYNTAX 1) 629;(define PATTERN 2) 630 631;; this needs to be in C++. I don't want to double manage these values. 632;;(define (pass3/let-frame-size) 2) 633(define (vm-frame-size) *frame-size*) 634 635;; also need to be c++ 636;; code builder 637 638;; TODO: this must be cpp. 639;; ---> start 640;; actual code builder 641(define (make-array) 642 (vector '.array (make-vector 2) 0)) 643(define (array-data a) 644 (vector-ref a 1)) 645(define (array-data-set! a v) 646 (vector-set! a 1 v)) 647(define (array-length a) 648 (vector-ref a 2)) 649(define (array-length-set! a v) 650 (vector-set! a 2 v)) 651 652(define array? 653 (lambda (a) 654 (and (vector? a) 655 (eq? (vector-ref a 0) '.array)))) 656(define array-data-length 657 (lambda (array) 658 (vector-length (array-data array)))) 659(define array-data-copy 660 (lambda (src dst length) 661 (do ((i 0 (+ i 1))) 662 ((>= i length) #f) 663 (vector-set! dst i (vector-ref src i))))) 664 665(define set-array-length! 666 (lambda (array length) 667 (array-length-set! array length) 668 (if (>= length (array-data-length array)) 669 (let ((next-data (make-vector (* length 2)))) 670 (array-data-copy (array-data array) next-data length) 671 (array-data-set! array next-data))))) 672 673(define array-push! 674 (lambda (array obj) 675 (let* ((data (array-data array)) 676 (length (array-length array))) 677 (vector-set! data length obj) 678 ;; extend array for next use 679 (set-array-length! array (+ length 1))))) 680 681(define array->list 682 (lambda (array) 683 (let ((data (array-data array)) 684 (length (array-length array))) 685 (let loop ((i 0) 686 (ret '())) 687 (if (>= i length) 688 (reverse ret) 689 (loop (+ i 1) (cons (vector-ref data i) ret))))))) 690 691;; code builder 692;; code builder 693;; properties: 694;; code - for now just an array 695;; <below this is for closure> 696;; name - closure name or #f 697;; argc - argument count 698;; optional? - #t it has optional arg, #f it has no optional arg 699;; freec - free variable count 700;; maxStack - estimated stack size 701;; src - src info 702;; <below is for combine> 703;; packet - previous instruction data. 704;; label-defs - alist of (name . offset) 705;; label-refs - alist of (name . offset-to-fill) 706 707;; code-packet 708;; insn - vm instruction 709;; type - packet type 710;; arg0 - instruction value 711;; arg1 - instruction value 712;; obj - object 713(define-constant EMPTY 0) 714(define-constant ARGUMENT0 1) 715(define-constant ARGUMENT1 2) 716 717(define undef (if #f #f)) 718(define (make-code-packet) 719 (vector -1 EMPTY 0 0 undef)) 720 721(define (init-packet packet insn type arg0 arg1 o) 722 (when (or (null? arg0) (null? arg1)) 723 (raise 'error)) 724 (vector-set! packet 0 insn) 725 (vector-set! packet 1 type) 726 (vector-set! packet 2 arg0) 727 (vector-set! packet 3 arg1) 728 (vector-set! packet 4 o) 729 packet) 730 731(define (packet-insn packet) (vector-ref packet 0)) 732(define (packet-insn-set! packet insn) (vector-set! packet 0 insn)) 733(define (packet-type packet) (vector-ref packet 1)) 734(define (packet-type-set! packet type) (vector-set! packet 1 type)) 735(define (packet-arg0 packet) (vector-ref packet 2)) 736(define (packet-arg0-set! packet o) (vector-set! packet 2 o)) 737(define (packet-arg1 packet) (vector-ref packet 3)) 738(define (packet-arg1-set! packet o) (vector-set! packet 3 o)) 739(define (packet-obj packet) (vector-ref packet 4)) 740(define (packet-obj-set! packet o) (vector-set! packet 4 o)) 741 742(define (make-code-builder) 743 (vector '.code-builder (make-array) #f 0 #f 0 0 '() 744 (make-code-packet) '() '())) 745(define (code-builder-code cb) 746 (vector-ref cb 1)) 747(define (code-builder-code-set! cb o) 748 (array-data-set! (vector-ref cb 1) o) 749 (array-length-set! (vector-ref cb 1) (vector-length o))) 750(define (code-builder-name cb) (vector-ref cb 2)) 751(define (code-builder-name-set! cb argc) (vector-set! cb 2 argc)) 752(define (code-builder-argc cb) (vector-ref cb 3)) 753(define (code-builder-argc-set! cb argc) (vector-set! cb 3 argc)) 754(define (code-builder-optional? cb) (vector-ref cb 4)) 755(define (code-builder-optional-set! cb o) (vector-set! cb 4 o)) 756(define (code-builder-freec cb) (vector-ref cb 5)) 757(define (code-builder-freec-set! cb o) (vector-set! cb 5 o)) 758(define (code-builder-maxstack cb) (vector-ref cb 6)) 759(define (code-builder-maxstack-set! cb o) (vector-set! cb 6 o)) 760(define (code-builder-src cb) (vector-ref cb 7)) 761(define (code-builder-src-set! cb o) (vector-set! cb 7 o)) 762(define (code-builder-add-src cb src) 763 (let ((index (array-length (code-builder-code cb))) 764 (old-src (code-builder-src cb))) 765 (code-builder-src-set! cb (append old-src (list (cons index src)))))) 766(define (code-builder-packet cb) (vector-ref cb 8)) 767(define (code-builder-packet-set! cb o) (vector-set! cb 8 o)) 768(define (code-builder-label-defs cb) (vector-ref cb 9)) 769(define (code-builder-label-defs-set! cb l) (vector-set! cb 9 l)) 770(define (code-builder-label-refs cb) (vector-ref cb 10)) 771(define (code-builder-label-refs-set! cb l) (vector-set! cb 10 l)) 772 773(define (code-builder? cb) 774 (and (vector? cb) 775 (eq? (vector-ref cb 0) '.code-builder))) 776 777(define (label? l) 778 (and (vector? l) 779 (> (vector-length l) 0) 780 (eqv? (vector-ref l 0) 11 #;$LABEL 781 ))) 782 783(define (cb-flush cb) 784 (if (= (packet-type (code-builder-packet cb)) EMPTY) 785 #t 786 (let ((insn (merge-insn2 (packet-insn (code-builder-packet cb)) 787 (packet-arg0 (code-builder-packet cb)) 788 (packet-arg1 (code-builder-packet cb))))) 789 (cond ((= (packet-type (code-builder-packet cb)) ARGUMENT0) 790 (array-push! (code-builder-code cb) insn)) 791 ((= (packet-type (code-builder-packet cb)) ARGUMENT1) 792 (let ((obj (packet-obj (code-builder-packet cb)))) 793 (array-push! (code-builder-code cb) insn) 794 (if (label? obj) 795 (begin 796 (code-builder-label-refs-set! 797 cb 798 (acons obj 799 (array-length (code-builder-code cb)) 800 (code-builder-label-refs cb))) 801 (array-push! (code-builder-code cb) 0)) ; dummy 802 (array-push! (code-builder-code cb) obj))))) 803 (code-builder-packet-set! cb (make-code-packet)) 804 #;(packet-type-set! (code-builder-packet cb) EMPTY) 805 ))) 806 807 808(define (cb-put cb packet) 809 (cond ((= (packet-type packet) ARGUMENT0) 810 (combine-insn-arg0 cb packet)) 811 ((= (packet-type packet) ARGUMENT1) 812 (combine-insn-arg1 cb packet)) 813 ((= (packet-type packet) ARGUMENT2) 814 (combine-insn-arg2 cb packet)) 815 (else (error 'cb-put "[internal] code-builder failed to emit code.")))) 816 817(define (combine-insn-arg0 cb packet) 818 (cond ((= (packet-insn packet) PUSH) 819 (cond ((= (packet-insn (code-builder-packet cb)) LREF) 820 (packet-insn-set! (code-builder-packet cb) LREF_PUSH)) 821 ((= (packet-insn (code-builder-packet cb)) FREF) 822 (packet-insn-set! (code-builder-packet cb) FREF_PUSH)) 823 ((= (packet-insn (code-builder-packet cb)) GREF) 824 (packet-insn-set! (code-builder-packet cb) GREF_PUSH)) 825 ((= (packet-insn (code-builder-packet cb)) CONST) 826 (packet-insn-set! (code-builder-packet cb) CONST_PUSH)) 827 ((= (packet-insn (code-builder-packet cb)) CONSTI) 828 (packet-insn-set! (code-builder-packet cb) CONSTI_PUSH)) 829 ((= (packet-insn (code-builder-packet cb)) CAR) 830 (packet-insn-set! (code-builder-packet cb) CAR_PUSH)) 831 ((= (packet-insn (code-builder-packet cb)) CDR) 832 (packet-insn-set! (code-builder-packet cb) CDR_PUSH)) 833 ((= (packet-insn (code-builder-packet cb)) CONS) 834 (packet-insn-set! (code-builder-packet cb) CONS_PUSH)) 835 ((= (packet-insn (code-builder-packet cb)) LREF_CAR) 836 (packet-insn-set! (code-builder-packet cb) LREF_CAR_PUSH)) 837 ((= (packet-insn (code-builder-packet cb)) FREF_CAR) 838 (packet-insn-set! (code-builder-packet cb) FREF_CAR_PUSH)) 839 ((= (packet-insn (code-builder-packet cb)) GREF_CAR) 840 (packet-insn-set! (code-builder-packet cb) GREF_CAR_PUSH)) 841 ((= (packet-insn (code-builder-packet cb)) LREF_CDR) 842 (packet-insn-set! (code-builder-packet cb) LREF_CDR_PUSH)) 843 ((= (packet-insn (code-builder-packet cb)) FREF_CDR) 844 (packet-insn-set! (code-builder-packet cb) FREF_CDR_PUSH)) 845 ((= (packet-insn (code-builder-packet cb)) GREF_CDR) 846 (packet-insn-set! (code-builder-packet cb) GREF_CDR_PUSH)) 847 (else 848 (cb-flush cb) 849 (code-builder-packet-set! cb packet)))) 850 ((= (packet-insn packet) RET) 851 (cond ((= (packet-insn (code-builder-packet cb)) CONST) 852 (packet-insn-set! (code-builder-packet cb) CONST_RET)) 853 (else 854 (cb-flush cb) 855 (code-builder-packet-set! cb packet)))) 856 ((= (packet-insn packet) CAR) 857 (cond ((= (packet-insn (code-builder-packet cb)) LREF) 858 (packet-insn-set! (code-builder-packet cb) LREF_CAR)) 859 ((= (packet-insn (code-builder-packet cb)) FREF) 860 (packet-insn-set! (code-builder-packet cb) FREF_CAR)) 861 ((= (packet-insn (code-builder-packet cb)) GREF) 862 (packet-insn-set! (code-builder-packet cb) GREF_CAR)) 863 ((= (packet-insn (code-builder-packet cb)) CAR) 864 (packet-insn-set! (code-builder-packet cb) CAAR)) 865 ((= (packet-insn (code-builder-packet cb)) CDR) 866 (packet-insn-set! (code-builder-packet cb) CADR)) 867 (else 868 (cb-flush cb) 869 (code-builder-packet-set! cb packet)))) 870 ((= (packet-insn packet) CDR) 871 (cond ((= (packet-insn (code-builder-packet cb)) LREF) 872 (packet-insn-set! (code-builder-packet cb) LREF_CDR)) 873 ((= (packet-insn (code-builder-packet cb)) FREF) 874 (packet-insn-set! (code-builder-packet cb) FREF_CDR)) 875 ((= (packet-insn (code-builder-packet cb)) GREF) 876 (packet-insn-set! (code-builder-packet cb) GREF_CDR)) 877 ((= (packet-insn (code-builder-packet cb)) CAR) 878 (packet-insn-set! (code-builder-packet cb) CDAR)) 879 ((= (packet-insn (code-builder-packet cb)) CDR) 880 (packet-insn-set! (code-builder-packet cb) CDDR)) 881 (else 882 (cb-flush cb) 883 (code-builder-packet-set! cb packet)))) 884 ((= (packet-insn packet) UNDEF) 885 ;; i don't want undef undef undef thing. 886 (cond ((= (packet-insn (code-builder-packet cb)) UNDEF) 887 #t) 888 (else 889 (cb-flush cb) 890 (code-builder-packet-set! cb packet)))) 891 ((= (packet-insn packet) CALL) 892 (cond ((= (packet-insn (code-builder-packet cb)) GREF) 893 (packet-insn-set! (code-builder-packet cb) GREF_CALL) 894 (packet-type-set! (code-builder-packet cb) ARGUMENT1) 895 (packet-arg0-set! (code-builder-packet cb) (packet-arg0 packet))) 896 (else 897 (cb-flush cb) 898 (code-builder-packet-set! cb packet)))) 899 ((= (packet-insn packet) TAIL_CALL) 900 (cond ((= (packet-insn (code-builder-packet cb)) GREF) 901 (packet-insn-set! (code-builder-packet cb) GREF_TAIL_CALL) 902 (packet-type-set! (code-builder-packet cb) ARGUMENT1) 903 (packet-arg0-set! (code-builder-packet cb) (packet-arg0 packet))) 904 (else 905 (cb-flush cb) 906 (code-builder-packet-set! cb packet)))) 907 (else 908 (cb-flush cb) 909 (code-builder-packet-set! cb packet)))) 910 911(define (combine-insn-arg1 cb packet) 912 (cond ((= (packet-insn packet) CONST) 913 (let ((obj (packet-obj packet))) 914 (cond ((and (integer? obj) 915 (exact? obj) 916 (<= #x-7ffff obj #x7ffff)) 917 (cb-flush cb) 918 (packet-insn-set! packet CONSTI) 919 (packet-type-set! packet ARGUMENT0) 920 (packet-arg0-set! packet obj) 921 (code-builder-packet-set! cb packet)) 922 (else 923 (cb-flush cb) 924 (code-builder-packet-set! cb packet))))) 925 #;((= (packet-insn packet) JUMP) 926 (cond ((= (packet-insn (code-builder-packet cb)) SHIFTJ) 927 (packet-insn-set! (code-builder-packet cb) SHIFTJ_JUMP) 928 (packet-obj-set! (code-builder-packet cb) (packet-obj packet))) 929 (else 930 (cb-flush cb) 931 (code-builder-packet-set! cb packet)))) 932 (else 933 (cb-flush cb) 934 (code-builder-packet-set! cb packet)))) 935 936;; insn value map 937;; mmmmmmmm mmmmnnnn nnnnnnnn iiiiiiii 938;; m = arg2 (if it's required) 939;; n = arg1 940;; i = instruction 941;; insn must be under 255 (1 byte) 942(define (merge-insn1 insn arg1) 943 (bitwise-ior insn (bitwise-arithmetic-shift-left arg1 8))) 944 945;; arg1 and arg2 must be under 12 bit 946;; but on scheme vm, i'm not gonna check it 947(define (merge-insn2 insn arg1 arg2) 948 (bitwise-ior insn 949 (bitwise-ior (bitwise-arithmetic-shift-left arg1 8) 950 (bitwise-arithmetic-shift-left arg2 20)))) 951 952(define (get-insn-value insn num index) 953 (cond ((= num 1) 954 (bitwise-arithmetic-shift insn -8)) 955 ((= num 2) 956 (cond ((= index 0) 957 (bitwise-and (bitwise-arithmetic-shift insn -8) #xfff)) 958 ((= index 1) 959 (bitwise-arithmetic-shift insn -20)))))) 960 961(define (get-insn insn) 962 (bitwise-and insn #xff)) 963 964;(merge-insn2 insn arg0 arg1) 965;; only insn values 966(define (cb-emit2! cb insn arg0 arg1) 967 (cb-put cb (init-packet (make-code-packet) insn ARGUMENT0 arg0 arg1 undef))) 968(define (cb-emit1! cb insn arg0) 969 (cb-put cb (init-packet (make-code-packet) insn ARGUMENT0 arg0 0 undef))) 970(define (cb-emit0! cb insn) 971 (cb-put cb (init-packet (make-code-packet) insn ARGUMENT0 0 0 undef))) 972 973;; insn value with src info 974(define (cb-emit2i! cb insn arg0 arg1 src) 975 (code-builder-add-src cb src) 976 (cb-put cb (init-packet (make-code-packet) insn ARGUMENT0 arg0 arg1 undef))) 977(define (cb-emit1i! cb insn arg0 src) 978 (code-builder-add-src cb src) 979 (cb-put cb (init-packet (make-code-packet) insn ARGUMENT0 arg0 0 undef))) 980(define (cb-emit0i! cb insn src) 981 (code-builder-add-src cb src) 982 (cb-put cb (init-packet (make-code-packet) insn ARGUMENT0 0 0 undef))) 983 984;; with object 985(define (cb-emit0o! cb insn o) 986 (cb-put cb (init-packet (make-code-packet) insn ARGUMENT1 0 0 o))) 987(define (cb-emit0oi! cb insn o src) 988 (code-builder-add-src cb src) 989 (cb-put cb (init-packet (make-code-packet) insn ARGUMENT1 0 0 o))) 990(define (cb-emit1oi! cb insn arg0 o src) 991 (code-builder-add-src cb src) 992 (cb-put cb (init-packet (make-code-packet) insn ARGUMENT1 arg0 0 o))) 993 994(define cb-label-set! 995 (lambda (cb label) 996 (cb-flush cb) 997 (code-builder-label-defs-set! cb 998 (acons label (array-length (code-builder-code cb)) 999 (code-builder-label-defs cb))))) 1000 1001(define (cb-emit-closure! cb insn lambda-cb name argc opt? freec max-stack src) 1002 (code-builder-name-set! lambda-cb name) 1003 (code-builder-argc-set! lambda-cb argc) 1004 (code-builder-optional-set! lambda-cb opt?) 1005 (code-builder-freec-set! lambda-cb freec) 1006 (code-builder-maxstack-set! lambda-cb max-stack) 1007 (code-builder-add-src lambda-cb src) 1008 (cb-flush lambda-cb) 1009 (cb-emit0o! cb insn lambda-cb)) 1010 1011;; this needs to be moved to C++ 1012(define (code-builder-finish-builder cb last) 1013 (define (builder-label-def label-defs label) 1014 (cond ((assq label label-defs) 1015 => cdr) 1016 (else 1017 (error 'builder-label-def "a label was refered but not defined.") 1018 -1))) 1019 1020 (define (rec cb) 1021 (let* ((size (array-length (code-builder-code cb))) 1022 (code (array-data (code-builder-code cb))) 1023 (label-defs (code-builder-label-defs cb)) 1024 (label-refs (code-builder-label-refs cb)) 1025 (v (make-vector size NOP))) 1026 (for-each (lambda (l) 1027 (let ((dest (builder-label-def label-defs (car l))) 1028 (operand (cdr l))) 1029 (vector-set! code operand (- dest operand)))) 1030 label-refs) 1031 (let loop ((i 0)) 1032 (if (= i size) 1033 (begin 1034 (array-length-set! (code-builder-code cb) size) 1035 (array-data-set! (code-builder-code cb) v)) 1036 (let ((o (vector-ref code i))) 1037 (vector-set! v i o) 1038 (if (code-builder? (vector-ref code i)) 1039 (rec (vector-ref code i))) 1040 (loop (+ i 1))))))) 1041 (unless (= last NOP) 1042 (cb-emit0! cb last)) 1043 (cb-flush cb) 1044 (rec cb) 1045 cb) 1046;;;; end of file 1047;; Local Variables: 1048;; coding: utf-8-unix 1049;; End: 1050