~ chicken-core (master) /tests/compiler.scm
Trap1(define compiler-iters 300)23(define (fatal-error . args)4 (for-each display args)5 (newline)6 (exit 1))78 (define (call-with-output-file/truncate filename proc)9 (call-with-output-file filename proc))1011(define (run-bench name count ok? run)12 (let loop ((i count) (result '(undefined)))13 (if (< 0 i)14 (loop (- i 1) (run))15 result)))1617(define (run-benchmark name count ok? run-maker . args)18 (newline)19 (let* ((run (apply run-maker args))20 (result (run-bench name count ok? run)))21 (if (not (ok? result))22 (begin23 (display "*** wrong result ***")24 (newline)25 (display "*** got: ")26 (pp result)27 (newline))))28 (exit 0))29;(define integer->char ascii->char)30;(define char->integer char->ascii)3132(define open-input-file* open-input-file)33(define (pp-expression expr port) (write expr port) (newline port))34(define (write-returning-len obj port) (write obj port) 1)35(define (display-returning-len obj port) (display obj port) 1)36(define (write-word w port)37 (write-char (integer->char (quotient w 256)) port)38 (write-char (integer->char (modulo w 256)) port))39(define char-nul (integer->char 0))40(define char-tab (integer->char 9))41(define char-newline (integer->char 10))42(define character-encoding char->integer)43(define max-character-encoding 255)44(define (fatal-err msg arg) (fatal-error msg arg))45(define (scheme-global-var name) name)46(define (scheme-global-var-ref var) (scheme-global-eval var fatal-err))47(define (scheme-global-var-set! var val)48 (scheme-global-eval (list 'set! var (list 'quote val)) fatal-err))49(define (scheme-global-eval expr err) `(eval ,expr)) ;; eval not needed for test50(define (pinpoint-error filename line char) #t)51(define file-path-sep #\:)52(define file-ext-sep #\.)53(define (path-absolute? x)54 (and (> (string-length x) 0)55 (let ((c (string-ref x 0))) (or (char=? c #\/) (char=? c #\~)))))56(define (file-path x)57 (let loop1 ((i (string-length x)))58 (if (and (> i 0) (not (char=? (string-ref x (- i 1)) file-path-sep)))59 (loop1 (- i 1))60 (let ((result (make-string i)))61 (let loop2 ((j (- i 1)))62 (if (< j 0)63 result64 (begin65 (string-set! result j (string-ref x j))66 (loop2 (- j 1)))))))))67(define (file-name x)68 (let loop1 ((i (string-length x)))69 (if (and (> i 0) (not (char=? (string-ref x (- i 1)) file-path-sep)))70 (loop1 (- i 1))71 (let ((result (make-string (- (string-length x) i))))72 (let loop2 ((j (- (string-length x) 1)))73 (if (< j i)74 result75 (begin76 (string-set! result (- j i) (string-ref x j))77 (loop2 (- j 1)))))))))78(define (file-ext x)79 (let loop1 ((i (string-length x)))80 (if (or (= i 0) (char=? (string-ref x (- i 1)) file-path-sep))81 #f82 (if (not (char=? (string-ref x (- i 1)) file-ext-sep))83 (loop1 (- i 1))84 (let ((result (make-string (- (string-length x) i))))85 (let loop2 ((j (- (string-length x) 1)))86 (if (< j i)87 result88 (begin89 (string-set! result (- j i) (string-ref x j))90 (loop2 (- j 1))))))))))91(define (file-root x)92 (let loop1 ((i (string-length x)))93 (if (or (= i 0) (char=? (string-ref x (- i 1)) file-path-sep))94 x95 (if (not (char=? (string-ref x (- i 1)) file-ext-sep))96 (loop1 (- i 1))97 (let ((result (make-string (- i 1))))98 (let loop2 ((j (- i 2)))99 (if (< j 0)100 result101 (begin102 (string-set! result j (string-ref x j))103 (loop2 (- j 1))))))))))104(define (make-counter next limit limit-error)105 (lambda ()106 (if (< next limit)107 (let ((result next)) (set! next (+ next 1)) result)108 (limit-error))))109(define (pos-in-list x l)110 (let loop ((l l) (i 0))111 (cond ((not (pair? l)) #f)112 ((eq? (car l) x) i)113 (else (loop (cdr l) (+ i 1))))))114(define (string-pos-in-list x l)115 (let loop ((l l) (i 0))116 (cond ((not (pair? l)) #f)117 ((string=? (car l) x) i)118 (else (loop (cdr l) (+ i 1))))))119(define (nth-after l n)120 (let loop ((l l) (n n)) (if (> n 0) (loop (cdr l) (- n 1)) l)))121(define (pair-up l1 l2)122 (define (pair l1 l2)123 (if (pair? l1)124 (cons (cons (car l1) (car l2)) (pair (cdr l1) (cdr l2)))125 '()))126 (pair l1 l2))127(define (my-last-pair l)128 (let loop ((l l)) (if (pair? (cdr l)) (loop (cdr l)) l)))129(define (sort-list l <?)130 (define (mergesort l)131 (define (merge l1 l2)132 (cond ((null? l1) l2)133 ((null? l2) l1)134 (else135 (let ((e1 (car l1)) (e2 (car l2)))136 (if (<? e1 e2)137 (cons e1 (merge (cdr l1) l2))138 (cons e2 (merge l1 (cdr l2))))))))139 (define (split l)140 (if (or (null? l) (null? (cdr l))) l (cons (car l) (split (cddr l)))))141 (if (or (null? l) (null? (cdr l)))142 l143 (let* ((l1 (mergesort (split l))) (l2 (mergesort (split (cdr l)))))144 (merge l1 l2))))145 (mergesort l))146(define (lst->vector l)147 (let* ((n (length l)) (v (make-vector n)))148 (let loop ((l l) (i 0))149 (if (pair? l)150 (begin (vector-set! v i (car l)) (loop (cdr l) (+ i 1)))151 v))))152(define (vector->lst v)153 (let loop ((l '()) (i (- (vector-length v) 1)))154 (if (< i 0) l (loop (cons (vector-ref v i) l) (- i 1)))))155(define (lst->string l)156 (let* ((n (length l)) (s (make-string n)))157 (let loop ((l l) (i 0))158 (if (pair? l)159 (begin (string-set! s i (car l)) (loop (cdr l) (+ i 1)))160 s))))161(define (string->lst s)162 (let loop ((l '()) (i (- (string-length s) 1)))163 (if (< i 0) l (loop (cons (string-ref s i) l) (- i 1)))))164(define (with-exception-handling proc)165 (let ((old-exception-handler throw-to-exception-handler))166 (let ((val (call-with-current-continuation167 (lambda (cont)168 (set! throw-to-exception-handler cont)169 (proc)))))170 (set! throw-to-exception-handler old-exception-handler)171 val)))172(define (throw-to-exception-handler val)173 (fatal-err "Internal error, no exception handler at this point" val))174(define (compiler-error msg . args)175 (newline)176 (display "*** ERROR -- ")177 (display msg)178 (for-each (lambda (x) (display " ") (write x)) args)179 (newline)180 (compiler-abort))181(define (compiler-user-error loc msg . args)182 (newline)183 (display "*** ERROR -- In ")184 (locat-show loc)185 (newline)186 (display "*** ")187 (display msg)188 (for-each (lambda (x) (display " ") (write x)) args)189 (newline)190 (compiler-abort))191(define (compiler-internal-error msg . args)192 (newline)193 (display "*** ERROR -- Compiler internal error detected")194 (newline)195 (display "*** in procedure ")196 (display msg)197 (for-each (lambda (x) (display " ") (write x)) args)198 (newline)199 (compiler-abort))200(define (compiler-limitation-error msg . args)201 (newline)202 (display "*** ERROR -- Compiler limit reached")203 (newline)204 (display "*** ")205 (display msg)206 (for-each (lambda (x) (display " ") (write x)) args)207 (newline)208 (compiler-abort))209(define (compiler-abort) (throw-to-exception-handler #f))210(define (make-gnode label edges) (vector label edges))211(define (gnode-label x) (vector-ref x 0))212(define (gnode-edges x) (vector-ref x 1))213(define (transitive-closure graph)214 (define changed? #f)215 (define (closure edges)216 (list->set217 (set-union218 edges219 (apply set-union220 (map (lambda (label) (gnode-edges (gnode-find label graph)))221 (set->list edges))))))222 (let ((new-graph223 (set-map (lambda (x)224 (let ((new-edges (closure (gnode-edges x))))225 (if (not (set-equal? new-edges (gnode-edges x)))226 (set! changed? #t))227 (make-gnode (gnode-label x) new-edges)))228 graph)))229 (if changed? (transitive-closure new-graph) new-graph)))230(define (gnode-find label graph)231 (define (find label l)232 (cond ((null? l) #f)233 ((eq? (gnode-label (car l)) label) (car l))234 (else (find label (cdr l)))))235 (find label (set->list graph)))236(define (topological-sort graph)237 (if (set-empty? graph)238 '()239 (let ((to-remove (or (remove-no-edges graph) (remove-cycle graph))))240 (let ((labels (set-map gnode-label to-remove)))241 (cons labels242 (topological-sort243 (set-map (lambda (x)244 (make-gnode245 (gnode-label x)246 (set-difference (gnode-edges x) labels)))247 (set-difference graph to-remove))))))))248(define (remove-no-edges graph)249 (let ((nodes-with-no-edges250 (set-keep (lambda (x) (set-empty? (gnode-edges x))) graph)))251 (if (set-empty? nodes-with-no-edges) #f nodes-with-no-edges)))252(define (remove-cycle graph)253 (define (remove l)254 (let ((edges (gnode-edges (car l))))255 (define (equal-edges? x) (set-equal? (gnode-edges x) edges))256 (define (member-edges? x) (set-member? (gnode-label x) edges))257 (if (set-member? (gnode-label (car l)) edges)258 (let ((edge-graph (set-keep member-edges? graph)))259 (if (set-every? equal-edges? edge-graph)260 edge-graph261 (remove (cdr l))))262 (remove (cdr l)))))263 (remove (set->list graph)))264(define (list->set list) list)265(define (set->list set) set)266(define (set-empty) '())267(define (set-empty? set) (null? set))268(define (set-member? x set) (memq x set))269(define (set-singleton x) (list x))270(define (set-adjoin set x) (if (memq x set) set (cons x set)))271(define (set-remove set x)272 (cond ((null? set) '())273 ((eq? (car set) x) (cdr set))274 (else (cons (car set) (set-remove (cdr set) x)))))275(define (set-equal? s1 s2)276 (cond ((null? s1) (null? s2))277 ((memq (car s1) s2) (set-equal? (cdr s1) (set-remove s2 (car s1))))278 (else #f)))279(define (set-difference set . other-sets)280 (define (difference s1 s2)281 (cond ((null? s1) '())282 ((memq (car s1) s2) (difference (cdr s1) s2))283 (else (cons (car s1) (difference (cdr s1) s2)))))284 (n-ary difference set other-sets))285(define (set-union . sets)286 (define (union s1 s2)287 (cond ((null? s1) s2)288 ((memq (car s1) s2) (union (cdr s1) s2))289 (else (cons (car s1) (union (cdr s1) s2)))))290 (n-ary union '() sets))291(define (set-intersection set . other-sets)292 (define (intersection s1 s2)293 (cond ((null? s1) '())294 ((memq (car s1) s2) (cons (car s1) (intersection (cdr s1) s2)))295 (else (intersection (cdr s1) s2))))296 (n-ary intersection set other-sets))297(define (n-ary function first rest)298 (if (null? rest)299 first300 (n-ary function (function first (car rest)) (cdr rest))))301(define (set-keep keep? set)302 (cond ((null? set) '())303 ((keep? (car set)) (cons (car set) (set-keep keep? (cdr set))))304 (else (set-keep keep? (cdr set)))))305(define (set-every? pred? set)306 (or (null? set) (and (pred? (car set)) (set-every? pred? (cdr set)))))307(define (set-map proc set)308 (if (null? set) '() (cons (proc (car set)) (set-map proc (cdr set)))))309(define (list->queue list)310 (cons list (if (pair? list) (my-last-pair list) '())))311(define (queue->list queue) (car queue))312(define (queue-empty) (cons '() '()))313(define (queue-empty? queue) (null? (car queue)))314(define (queue-get! queue)315 (if (null? (car queue))316 (compiler-internal-error "queue-get!, queue is empty")317 (let ((x (caar queue)))318 (set-car! queue (cdar queue))319 (if (null? (car queue)) (set-cdr! queue '()))320 x)))321(define (queue-put! queue x)322 (let ((entry (cons x '())))323 (if (null? (car queue))324 (set-car! queue entry)325 (set-cdr! (cdr queue) entry))326 (set-cdr! queue entry)327 x))328(define (string->canonical-symbol str)329 (let ((len (string-length str)))330 (let loop ((str str) (s (make-string len)) (i (- len 1)))331 (if (>= i 0)332 (begin333 (string-set! s i (char-downcase (string-ref str i)))334 (loop str s (- i 1)))335 (string->symbol s)))))336(define quote-sym (string->canonical-symbol "QUOTE"))337(define quasiquote-sym (string->canonical-symbol "QUASIQUOTE"))338(define unquote-sym (string->canonical-symbol "UNQUOTE"))339(define unquote-splicing-sym (string->canonical-symbol "UNQUOTE-SPLICING"))340(define lambda-sym (string->canonical-symbol "LAMBDA"))341(define if-sym (string->canonical-symbol "IF"))342(define set!-sym (string->canonical-symbol "SET!"))343(define cond-sym (string->canonical-symbol "COND"))344(define =>-sym (string->canonical-symbol "=>"))345(define else-sym (string->canonical-symbol "ELSE"))346(define and-sym (string->canonical-symbol "AND"))347(define or-sym (string->canonical-symbol "OR"))348(define case-sym (string->canonical-symbol "CASE"))349(define let-sym (string->canonical-symbol "LET"))350(define let*-sym (string->canonical-symbol "LET*"))351(define letrec-sym (string->canonical-symbol "LETREC"))352(define begin-sym (string->canonical-symbol "BEGIN"))353(define do-sym (string->canonical-symbol "DO"))354(define define-sym (string->canonical-symbol "DEFINE"))355(define delay-sym (string->canonical-symbol "DELAY"))356(define future-sym (string->canonical-symbol "FUTURE"))357(define **define-macro-sym (string->canonical-symbol "DEFINE-MACRO"))358(define **declare-sym (string->canonical-symbol "DECLARE"))359(define **include-sym (string->canonical-symbol "INCLUDE"))360(define not-sym (string->canonical-symbol "NOT"))361(define **c-declaration-sym (string->canonical-symbol "C-DECLARATION"))362(define **c-init-sym (string->canonical-symbol "C-INIT"))363(define **c-procedure-sym (string->canonical-symbol "C-PROCEDURE"))364(define void-sym (string->canonical-symbol "VOID"))365(define char-sym (string->canonical-symbol "CHAR"))366(define signed-char-sym (string->canonical-symbol "SIGNED-CHAR"))367(define unsigned-char-sym (string->canonical-symbol "UNSIGNED-CHAR"))368(define short-sym (string->canonical-symbol "SHORT"))369(define unsigned-short-sym (string->canonical-symbol "UNSIGNED-SHORT"))370(define int-sym (string->canonical-symbol "INT"))371(define unsigned-int-sym (string->canonical-symbol "UNSIGNED-INT"))372(define long-sym (string->canonical-symbol "LONG"))373(define unsigned-long-sym (string->canonical-symbol "UNSIGNED-LONG"))374(define float-sym (string->canonical-symbol "FLOAT"))375(define double-sym (string->canonical-symbol "DOUBLE"))376(define pointer-sym (string->canonical-symbol "POINTER"))377(define boolean-sym (string->canonical-symbol "BOOLEAN"))378(define string-sym (string->canonical-symbol "STRING"))379(define scheme-object-sym (string->canonical-symbol "SCHEME-OBJECT"))380(define c-id-prefix "___")381(define false-object (if (eq? '() #f) (string->symbol "#f") #f))382(define (false-object? obj) (eq? obj false-object))383(define undef-object (string->symbol "#[undefined]"))384(define (undef-object? obj) (eq? obj undef-object))385(define (symbol-object? obj)386 (and (not (false-object? obj)) (not (undef-object? obj)) (symbol? obj)))387(define scm-file-exts '("scm" #f))388(define compiler-version "2.2.2")389(define (open-sf filename)390 (define (open-err) (compiler-error "Can't find file" filename))391 (if (not (file-ext filename))392 (let loop ((exts scm-file-exts))393 (if (pair? exts)394 (let* ((ext (car exts))395 (full-name396 (if ext (string-append filename "." ext) filename))397 (port (open-input-file* full-name)))398 (if port (vector port full-name 0 1 0) (loop (cdr exts))))399 (open-err)))400 (let ((port (open-input-file* filename)))401 (if port (vector port filename 0 1 0) (open-err)))))402(define (close-sf sf) (close-input-port (vector-ref sf 0)))403(define (sf-read-char sf)404 (let ((c (read-char (vector-ref sf 0))))405 (cond ((eof-object? c))406 ((char=? c char-newline)407 (vector-set! sf 3 (+ (vector-ref sf 3) 1))408 (vector-set! sf 4 0))409 (else (vector-set! sf 4 (+ (vector-ref sf 4) 1))))410 c))411(define (sf-peek-char sf) (peek-char (vector-ref sf 0)))412(define (sf-read-error sf msg . args)413 (apply compiler-user-error414 (cons (sf->locat sf)415 (cons (string-append "Read error -- " msg) args))))416(define (sf->locat sf)417 (vector 'file418 (vector-ref sf 1)419 (vector-ref sf 2)420 (vector-ref sf 3)421 (vector-ref sf 4)))422(define (expr->locat expr source) (vector 'expr expr source))423(define (locat-show loc)424 (if loc425 (case (vector-ref loc 0)426 ((file)427 (if (pinpoint-error428 (vector-ref loc 1)429 (vector-ref loc 3)430 (vector-ref loc 4))431 (begin432 (display "file \"")433 (display (vector-ref loc 1))434 (display "\", line ")435 (display (vector-ref loc 3))436 (display ", character ")437 (display (vector-ref loc 4)))))438 ((expr)439 (display "expression ")440 (write (vector-ref loc 1))441 (if (vector-ref loc 2)442 (begin443 (display " ")444 (locat-show (source-locat (vector-ref loc 2))))))445 (else (compiler-internal-error "locat-show, unknown location tag")))446 (display "unknown location")))447(define (locat-filename loc)448 (if loc449 (case (vector-ref loc 0)450 ((file) (vector-ref loc 1))451 ((expr)452 (let ((source (vector-ref loc 2)))453 (if source (locat-filename (source-locat source)) "")))454 (else455 (compiler-internal-error "locat-filename, unknown location tag")))456 ""))457(define (make-source code locat) (vector code locat))458(define (source-code x) (vector-ref x 0))459(define (source-code-set! x y) (vector-set! x 0 y) x)460(define (source-locat x) (vector-ref x 1))461(define (expression->source expr source)462 (define (expr->source x)463 (make-source464 (cond ((pair? x) (list->source x))465 ((vector? x) (vector->source x))466 ((symbol-object? x) (string->canonical-symbol (symbol->string x)))467 (else x))468 (expr->locat x source)))469 (define (list->source l)470 (cond ((pair? l) (cons (expr->source (car l)) (list->source (cdr l))))471 ((null? l) '())472 (else (expr->source l))))473 (define (vector->source v)474 (let* ((len (vector-length v)) (x (make-vector len)))475 (let loop ((i (- len 1)))476 (if (>= i 0)477 (begin478 (vector-set! x i (expr->source (vector-ref v i)))479 (loop (- i 1)))))480 x))481 (expr->source expr))482(define (source->expression source)483 (define (list->expression l)484 (cond ((pair? l)485 (cons (source->expression (car l)) (list->expression (cdr l))))486 ((null? l) '())487 (else (source->expression l))))488 (define (vector->expression v)489 (let* ((len (vector-length v)) (x (make-vector len)))490 (let loop ((i (- len 1)))491 (if (>= i 0)492 (begin493 (vector-set! x i (source->expression (vector-ref v i)))494 (loop (- i 1)))))495 x))496 (let ((code (source-code source)))497 (cond ((pair? code) (list->expression code))498 ((vector? code) (vector->expression code))499 (else code))))500(define (file->sources filename info-port)501 (if info-port502 (begin503 (display "(reading \"" info-port)504 (display filename info-port)505 (display "\"" info-port)))506 (let ((sf (open-sf filename)))507 (define (read-sources)508 (let ((source (read-source sf)))509 (if (not (eof-object? source))510 (begin511 (if info-port (display "." info-port))512 (cons source (read-sources)))513 '())))514 (let ((sources (read-sources)))515 (if info-port (display ")" info-port))516 (close-sf sf)517 sources)))518(define (file->sources* filename info-port loc)519 (file->sources520 (if (path-absolute? filename)521 filename522 (string-append (file-path (locat-filename loc)) filename))523 info-port))524(define (read-source sf)525 (define (read-char*)526 (let ((c (sf-read-char sf)))527 (if (eof-object? c)528 (sf-read-error sf "Premature end of file encountered")529 c)))530 (define (read-non-whitespace-char)531 (let ((c (read-char*)))532 (cond ((< 0 (vector-ref read-table (char->integer c)))533 (read-non-whitespace-char))534 ((char=? c #\;)535 (let loop ()536 (if (not (char=? (read-char*) char-newline))537 (loop)538 (read-non-whitespace-char))))539 (else c))))540 (define (delimiter? c)541 (or (eof-object? c) (not (= (vector-ref read-table (char->integer c)) 0))))542 (define (read-list first)543 (let ((result (cons first '())))544 (let loop ((end result))545 (let ((c (read-non-whitespace-char)))546 (cond ((char=? c #\)))547 ((and (char=? c #\.) (delimiter? (sf-peek-char sf)))548 (let ((x (read-source sf)))549 (if (char=? (read-non-whitespace-char) #\))550 (set-cdr! end x)551 (sf-read-error sf "')' expected"))))552 (else553 (let ((tail (cons (rd* c) '())))554 (set-cdr! end tail)555 (loop tail))))))556 result))557 (define (read-vector)558 (define (loop i)559 (let ((c (read-non-whitespace-char)))560 (if (char=? c #\))561 (make-vector i '())562 (let* ((x (rd* c)) (v (loop (+ i 1)))) (vector-set! v i x) v))))563 (loop 0))564 (define (read-string)565 (define (loop i)566 (let ((c (read-char*)))567 (cond ((char=? c #\") (make-string i #\space))568 ((char=? c #\\)569 (let* ((c (read-char*)) (s (loop (+ i 1))))570 (string-set! s i c)571 s))572 (else (let ((s (loop (+ i 1)))) (string-set! s i c) s)))))573 (loop 0))574 (define (read-symbol/number-string i)575 (if (delimiter? (sf-peek-char sf))576 (make-string i #\space)577 (let* ((c (sf-read-char sf)) (s (read-symbol/number-string (+ i 1))))578 (string-set! s i (char-downcase c))579 s)))580 (define (read-symbol/number c)581 (let ((s (read-symbol/number-string 1)))582 (string-set! s 0 (char-downcase c))583 (or (string->number s 10) (string->canonical-symbol s))))584 (define (read-prefixed-number c)585 (let ((s (read-symbol/number-string 2)))586 (string-set! s 0 #\#)587 (string-set! s 1 c)588 (string->number s 10)))589 (define (read-special-symbol)590 (let ((s (read-symbol/number-string 2)))591 (string-set! s 0 #\#)592 (string-set! s 1 #\#)593 (string->canonical-symbol s)))594 (define (rd c)595 (cond ((eof-object? c) c)596 ((< 0 (vector-ref read-table (char->integer c)))597 (rd (sf-read-char sf)))598 ((char=? c #\;)599 (let loop ()600 (let ((c (sf-read-char sf)))601 (cond ((eof-object? c) c)602 ((char=? c char-newline) (rd (sf-read-char sf)))603 (else (loop))))))604 (else (rd* c))))605 (define (rd* c)606 (let ((source (make-source #f (sf->locat sf))))607 (source-code-set!608 source609 (cond ((char=? c #\()610 (let ((x (read-non-whitespace-char)))611 (if (char=? x #\)) '() (read-list (rd* x)))))612 ((char=? c #\#)613 (let ((c (char-downcase (sf-read-char sf))))614 (cond ((char=? c #\() (read-vector))615 ((char=? c #\f) false-object)616 ((char=? c #\t) #t)617 ((char=? c #\\)618 (let ((c (read-char*)))619 (if (or (not (char-alphabetic? c))620 (delimiter? (sf-peek-char sf)))621 c622 (let ((name (read-symbol/number c)))623 (let ((x (assq name named-char-table)))624 (if x625 (cdr x)626 (sf-read-error627 sf628 "Unknown character name"629 name)))))))630 ((char=? c #\#) (read-special-symbol))631 (else632 (let ((num (read-prefixed-number c)))633 (or num634 (sf-read-error635 sf636 "Unknown '#' read macro"637 c)))))))638 ((char=? c #\") (read-string))639 ((char=? c #\')640 (list (make-source quote-sym (sf->locat sf)) (read-source sf)))641 ((char=? c #\`)642 (list (make-source quasiquote-sym (sf->locat sf))643 (read-source sf)))644 ((char=? c #\,)645 (if (char=? (sf-peek-char sf) #\@)646 (let ((x (make-source unquote-splicing-sym (sf->locat sf))))647 (sf-read-char sf)648 (list x (read-source sf)))649 (list (make-source unquote-sym (sf->locat sf))650 (read-source sf))))651 ((char=? c #\)) (sf-read-error sf "Misplaced ')'"))652 ((or (char=? c #\[) (char=? c #\]) (char=? c #\{) (char=? c #\}))653 (sf-read-error sf "Illegal character" c))654 (else655 (if (char=? c #\.)656 (if (delimiter? (sf-peek-char sf))657 (sf-read-error sf "Misplaced '.'")))658 (read-symbol/number c))))))659 (rd (sf-read-char sf)))660(define named-char-table661 (list (cons (string->canonical-symbol "NUL") char-nul)662 (cons (string->canonical-symbol "TAB") char-tab)663 (cons (string->canonical-symbol "NEWLINE") char-newline)664 (cons (string->canonical-symbol "SPACE") #\space)))665(define read-table666 (let ((rt (make-vector (+ max-character-encoding 1) 0)))667 (vector-set! rt (char->integer char-tab) 1)668 (vector-set! rt (char->integer char-newline) 1)669 (vector-set! rt (char->integer #\space) 1)670 (vector-set! rt (char->integer #\;) -1)671 (vector-set! rt (char->integer #\() -1)672 (vector-set! rt (char->integer #\)) -1)673 (vector-set! rt (char->integer #\") -1)674 (vector-set! rt (char->integer #\') -1)675 (vector-set! rt (char->integer #\`) -1)676 rt))677(define (make-var name bound refs sets source)678 (vector var-tag name bound refs sets source #f))679(define (var? x)680 (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) var-tag)))681(define (var-name x) (vector-ref x 1))682(define (var-bound x) (vector-ref x 2))683(define (var-refs x) (vector-ref x 3))684(define (var-sets x) (vector-ref x 4))685(define (var-source x) (vector-ref x 5))686(define (var-info x) (vector-ref x 6))687(define (var-name-set! x y) (vector-set! x 1 y))688(define (var-bound-set! x y) (vector-set! x 2 y))689(define (var-refs-set! x y) (vector-set! x 3 y))690(define (var-sets-set! x y) (vector-set! x 4 y))691(define (var-source-set! x y) (vector-set! x 5 y))692(define (var-info-set! x y) (vector-set! x 6 y))693(define var-tag (list 'var-tag))694(define (var-copy var)695 (make-var (var-name var) #t (set-empty) (set-empty) (var-source var)))696(define (make-temp-var name) (make-var name #t (set-empty) (set-empty) #f))697(define (temp-var? var) (eq? (var-bound var) #t))698(define ret-var (make-temp-var 'ret))699(define ret-var-set (set-singleton ret-var))700(define closure-env-var (make-temp-var 'closure-env))701(define empty-var (make-temp-var #f))702(define make-global-environment #f)703(set! make-global-environment (lambda () (env-frame #f '())))704(define (env-frame env vars) (vector (cons vars #f) '() '() env))705(define (env-new-var! env name source)706 (let* ((glob (not (env-parent-ref env)))707 (var (make-var name (not glob) (set-empty) (set-empty) source)))708 (env-vars-set! env (cons var (env-vars-ref env)))709 var))710(define (env-macro env name def)711 (let ((name* (if (full-name? name)712 name713 (let ((prefix (env-namespace-prefix env name)))714 (if prefix (make-full-name prefix name) name)))))715 (vector (vector-ref env 0)716 (cons (cons name* def) (env-macros-ref env))717 (env-decls-ref env)718 (env-parent-ref env))))719(define (env-declare env decl)720 (vector (vector-ref env 0)721 (env-macros-ref env)722 (cons decl (env-decls-ref env))723 (env-parent-ref env)))724(define (env-vars-ref env) (car (vector-ref env 0)))725(define (env-vars-set! env vars) (set-car! (vector-ref env 0) vars))726(define (env-macros-ref env) (vector-ref env 1))727(define (env-decls-ref env) (vector-ref env 2))728(define (env-parent-ref env) (vector-ref env 3))729(define (env-namespace-prefix env name)730 (let loop ((decls (env-decls-ref env)))731 (if (pair? decls)732 (let ((decl (car decls)))733 (if (eq? (car decl) namespace-sym)734 (let ((syms (cddr decl)))735 (if (or (null? syms) (memq name syms))736 (cadr decl)737 (loop (cdr decls))))738 (loop (cdr decls))))739 #f)))740(define (env-lookup env name stop-at-first-frame? proc)741 (define (search env name full?)742 (if full?743 (search* env name full?)744 (let ((prefix (env-namespace-prefix env name)))745 (if prefix746 (search* env (make-full-name prefix name) #t)747 (search* env name full?)))))748 (define (search* env name full?)749 (define (search-macros macros)750 (if (pair? macros)751 (let ((m (car macros)))752 (if (eq? (car m) name)753 (proc env name (cdr m))754 (search-macros (cdr macros))))755 (search-vars (env-vars-ref env))))756 (define (search-vars vars)757 (if (pair? vars)758 (let ((v (car vars)))759 (if (eq? (var-name v) name)760 (proc env name v)761 (search-vars (cdr vars))))762 (let ((env* (env-parent-ref env)))763 (if (or stop-at-first-frame? (not env*))764 (proc env name #f)765 (search env* name full?)))))766 (search-macros (env-macros-ref env)))767 (search env name (full-name? name)))768(define (valid-prefix? str)769 (let ((l (string-length str)))770 (or (= l 0) (and (>= l 2) (char=? (string-ref str (- l 1)) #\#)))))771(define (full-name? sym)772 (let ((str (symbol->string sym)))773 (let loop ((i (- (string-length str) 1)))774 (if (< i 0) #f (if (char=? (string-ref str i) #\#) #t (loop (- i 1)))))))775(define (make-full-name prefix sym)776 (if (= (string-length prefix) 0)777 sym778 (string->canonical-symbol (string-append prefix (symbol->string sym)))))779(define (env-lookup-var env name source)780 (env-lookup781 env782 name783 #f784 (lambda (env name x)785 (if x786 (if (var? x)787 x788 (compiler-internal-error789 "env-lookup-var, name is that of a macro"790 name))791 (env-new-var! env name source)))))792(define (env-define-var env name source)793 (env-lookup794 env795 name796 #t797 (lambda (env name x)798 (if x799 (if (var? x)800 (pt-syntax-error source "Duplicate definition of a variable")801 (compiler-internal-error802 "env-define-var, name is that of a macro"803 name))804 (env-new-var! env name source)))))805(define (env-lookup-global-var env name)806 (let ((env* (env-global-env env)))807 (define (search-vars vars)808 (if (pair? vars)809 (let ((v (car vars)))810 (if (eq? (var-name v) name) v (search-vars (cdr vars))))811 (env-new-var! env* name #f)))812 (search-vars (env-vars-ref env*))))813(define (env-global-variables env) (env-vars-ref (env-global-env env)))814(define (env-global-env env)815 (let loop ((env env))816 (let ((env* (env-parent-ref env))) (if env* (loop env*) env))))817(define (env-lookup-macro env name)818 (env-lookup819 env820 name821 #f822 (lambda (env name x) (if (or (not x) (var? x)) #f x))))823(define (env-declarations env) env)824(define flag-declarations '())825(define parameterized-declarations '())826(define boolean-declarations '())827(define namable-declarations '())828(define namable-boolean-declarations '())829(define namable-string-declarations '())830(define (define-flag-decl name type)831 (set! flag-declarations (cons (cons name type) flag-declarations))832 '())833(define (define-parameterized-decl name)834 (set! parameterized-declarations (cons name parameterized-declarations))835 '())836(define (define-boolean-decl name)837 (set! boolean-declarations (cons name boolean-declarations))838 '())839(define (define-namable-decl name type)840 (set! namable-declarations (cons (cons name type) namable-declarations))841 '())842(define (define-namable-boolean-decl name)843 (set! namable-boolean-declarations (cons name namable-boolean-declarations))844 '())845(define (define-namable-string-decl name)846 (set! namable-string-declarations (cons name namable-string-declarations))847 '())848(define (flag-decl source type val) (list type val))849(define (parameterized-decl source id parm) (list id parm))850(define (boolean-decl source id pos) (list id pos))851(define (namable-decl source type val names) (cons type (cons val names)))852(define (namable-boolean-decl source id pos names) (cons id (cons pos names)))853(define (namable-string-decl source id str names)854 (if (and (eq? id namespace-sym) (not (valid-prefix? str)))855 (pt-syntax-error source "Illegal namespace"))856 (cons id (cons str names)))857(define (declaration-value name element default decls)858 (if (not decls)859 default860 (let loop ((l (env-decls-ref decls)))861 (if (pair? l)862 (let ((d (car l)))863 (if (and (eq? (car d) name)864 (or (null? (cddr d)) (memq element (cddr d))))865 (cadr d)866 (loop (cdr l))))867 (declaration-value name element default (env-parent-ref decls))))))868(define namespace-sym (string->canonical-symbol "NAMESPACE"))869(define-namable-string-decl namespace-sym)870(define (node-parent x) (vector-ref x 1))871(define (node-children x) (vector-ref x 2))872(define (node-fv x) (vector-ref x 3))873(define (node-decl x) (vector-ref x 4))874(define (node-source x) (vector-ref x 5))875(define (node-parent-set! x y) (vector-set! x 1 y))876(define (node-fv-set! x y) (vector-set! x 3 y))877(define (node-decl-set! x y) (vector-set! x 4 y))878(define (node-source-set! x y) (vector-set! x 5 y))879(define (node-children-set! x y)880 (vector-set! x 2 y)881 (for-each (lambda (child) (node-parent-set! child x)) y)882 (node-fv-invalidate! x))883(define (node-fv-invalidate! x)884 (let loop ((node x))885 (if node (begin (node-fv-set! node #t) (loop (node-parent node))))))886(define (make-cst parent children fv decl source val)887 (vector cst-tag parent children fv decl source val))888(define (cst? x)889 (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) cst-tag)))890(define (cst-val x) (vector-ref x 6))891(define (cst-val-set! x y) (vector-set! x 6 y))892(define cst-tag (list 'cst-tag))893(define (make-ref parent children fv decl source var)894 (vector ref-tag parent children fv decl source var))895(define (ref? x)896 (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) ref-tag)))897(define (ref-var x) (vector-ref x 6))898(define (ref-var-set! x y) (vector-set! x 6 y))899(define ref-tag (list 'ref-tag))900(define (make-set parent children fv decl source var)901 (vector set-tag parent children fv decl source var))902(define (set? x)903 (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) set-tag)))904(define (set-var x) (vector-ref x 6))905(define (set-var-set! x y) (vector-set! x 6 y))906(define set-tag (list 'set-tag))907(define (make-def parent children fv decl source var)908 (vector def-tag parent children fv decl source var))909(define (def? x)910 (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) def-tag)))911(define (def-var x) (vector-ref x 6))912(define (def-var-set! x y) (vector-set! x 6 y))913(define def-tag (list 'def-tag))914(define (make-tst parent children fv decl source)915 (vector tst-tag parent children fv decl source))916(define (tst? x)917 (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) tst-tag)))918(define tst-tag (list 'tst-tag))919(define (make-conj parent children fv decl source)920 (vector conj-tag parent children fv decl source))921(define (conj? x)922 (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) conj-tag)))923(define conj-tag (list 'conj-tag))924(define (make-disj parent children fv decl source)925 (vector disj-tag parent children fv decl source))926(define (disj? x)927 (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) disj-tag)))928(define disj-tag (list 'disj-tag))929(define (make-prc parent children fv decl source name min rest parms)930 (vector prc-tag parent children fv decl source name min rest parms))931(define (prc? x)932 (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) prc-tag)))933(define (prc-name x) (vector-ref x 6))934(define (prc-min x) (vector-ref x 7))935(define (prc-rest x) (vector-ref x 8))936(define (prc-parms x) (vector-ref x 9))937(define (prc-name-set! x y) (vector-set! x 6 y))938(define (prc-min-set! x y) (vector-set! x 7 y))939(define (prc-rest-set! x y) (vector-set! x 8 y))940(define (prc-parms-set! x y) (vector-set! x 9 y))941(define prc-tag (list 'prc-tag))942(define (make-app parent children fv decl source)943 (vector app-tag parent children fv decl source))944(define (app? x)945 (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) app-tag)))946(define app-tag (list 'app-tag))947(define (make-fut parent children fv decl source)948 (vector fut-tag parent children fv decl source))949(define (fut? x)950 (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) fut-tag)))951(define fut-tag (list 'fut-tag))952(define (new-cst source decl val) (make-cst #f '() #t decl source val))953(define (new-ref source decl var)954 (let ((node (make-ref #f '() #t decl source var)))955 (var-refs-set! var (set-adjoin (var-refs var) node))956 node))957(define (new-ref-extended-bindings source name env)958 (new-ref source959 (add-extended-bindings (env-declarations env))960 (env-lookup-global-var env name)))961(define (new-set source decl var val)962 (let ((node (make-set #f (list val) #t decl source var)))963 (var-sets-set! var (set-adjoin (var-sets var) node))964 (node-parent-set! val node)965 node))966(define (set-val x)967 (if (set? x)968 (car (node-children x))969 (compiler-internal-error "set-val, 'set' node expected" x)))970(define (new-def source decl var val)971 (let ((node (make-def #f (list val) #t decl source var)))972 (var-sets-set! var (set-adjoin (var-sets var) node))973 (node-parent-set! val node)974 node))975(define (def-val x)976 (if (def? x)977 (car (node-children x))978 (compiler-internal-error "def-val, 'def' node expected" x)))979(define (new-tst source decl pre con alt)980 (let ((node (make-tst #f (list pre con alt) #t decl source)))981 (node-parent-set! pre node)982 (node-parent-set! con node)983 (node-parent-set! alt node)984 node))985(define (tst-pre x)986 (if (tst? x)987 (car (node-children x))988 (compiler-internal-error "tst-pre, 'tst' node expected" x)))989(define (tst-con x)990 (if (tst? x)991 (cadr (node-children x))992 (compiler-internal-error "tst-con, 'tst' node expected" x)))993(define (tst-alt x)994 (if (tst? x)995 (caddr (node-children x))996 (compiler-internal-error "tst-alt, 'tst' node expected" x)))997(define (new-conj source decl pre alt)998 (let ((node (make-conj #f (list pre alt) #t decl source)))999 (node-parent-set! pre node)1000 (node-parent-set! alt node)1001 node))1002(define (conj-pre x)1003 (if (conj? x)1004 (car (node-children x))1005 (compiler-internal-error "conj-pre, 'conj' node expected" x)))1006(define (conj-alt x)1007 (if (conj? x)1008 (cadr (node-children x))1009 (compiler-internal-error "conj-alt, 'conj' node expected" x)))1010(define (new-disj source decl pre alt)1011 (let ((node (make-disj #f (list pre alt) #t decl source)))1012 (node-parent-set! pre node)1013 (node-parent-set! alt node)1014 node))1015(define (disj-pre x)1016 (if (disj? x)1017 (car (node-children x))1018 (compiler-internal-error "disj-pre, 'disj' node expected" x)))1019(define (disj-alt x)1020 (if (disj? x)1021 (cadr (node-children x))1022 (compiler-internal-error "disj-alt, 'disj' node expected" x)))1023(define (new-prc source decl name min rest parms body)1024 (let ((node (make-prc #f (list body) #t decl source name min rest parms)))1025 (for-each (lambda (x) (var-bound-set! x node)) parms)1026 (node-parent-set! body node)1027 node))1028(define (prc-body x)1029 (if (prc? x)1030 (car (node-children x))1031 (compiler-internal-error "prc-body, 'proc' node expected" x)))1032(define (new-call source decl oper args)1033 (let ((node (make-app #f (cons oper args) #t decl source)))1034 (node-parent-set! oper node)1035 (for-each (lambda (x) (node-parent-set! x node)) args)1036 node))1037(define (new-call* source decl oper args)1038 (if *ptree-port*1039 (if (ref? oper)1040 (let ((var (ref-var oper)))1041 (if (global? var)1042 (let ((proc (standard-procedure1043 (var-name var)1044 (node-decl oper))))1045 (if (and proc1046 (not (nb-args-conforms?1047 (length args)1048 (standard-procedure-call-pattern proc))))1049 (begin1050 (display "*** WARNING -- \"" *ptree-port*)1051 (display (var-name var) *ptree-port*)1052 (display "\" is called with " *ptree-port*)1053 (display (length args) *ptree-port*)1054 (display " argument(s)." *ptree-port*)1055 (newline *ptree-port*))))))))1056 (new-call source decl oper args))1057(define (app-oper x)1058 (if (app? x)1059 (car (node-children x))1060 (compiler-internal-error "app-oper, 'call' node expected" x)))1061(define (app-args x)1062 (if (app? x)1063 (cdr (node-children x))1064 (compiler-internal-error "app-args, 'call' node expected" x)))1065(define (oper-pos? node)1066 (let ((parent (node-parent node)))1067 (if parent (and (app? parent) (eq? (app-oper parent) node)) #f)))1068(define (new-fut source decl val)1069 (let ((node (make-fut #f (list val) #t decl source)))1070 (node-parent-set! val node)1071 node))1072(define (fut-val x)1073 (if (fut? x)1074 (car (node-children x))1075 (compiler-internal-error "fut-val, 'fut' node expected" x)))1076(define (new-disj-call source decl pre oper alt)1077 (new-call*1078 source1079 decl1080 (let* ((parms (new-temps source '(temp))) (temp (car parms)))1081 (new-prc source1082 decl1083 #f1084 11085 #f1086 parms1087 (new-tst source1088 decl1089 (new-ref source decl temp)1090 (new-call*1091 source1092 decl1093 oper1094 (list (new-ref source decl temp)))1095 alt)))1096 (list pre)))1097(define (new-seq source decl before after)1098 (new-call*1099 source1100 decl1101 (new-prc source decl #f 1 #f (new-temps source '(temp)) after)1102 (list before)))1103(define (new-let ptree proc vars vals body)1104 (if (pair? vars)1105 (new-call1106 (node-source ptree)1107 (node-decl ptree)1108 (new-prc (node-source proc)1109 (node-decl proc)1110 (prc-name proc)1111 (length vars)1112 #f1113 (reverse vars)1114 body)1115 (reverse vals))1116 body))1117(define (new-temps source names)1118 (if (null? names)1119 '()1120 (cons (make-var (car names) #t (set-empty) (set-empty) source)1121 (new-temps source (cdr names)))))1122(define (new-variables vars)1123 (if (null? vars)1124 '()1125 (cons (make-var1126 (source-code (car vars))1127 #t1128 (set-empty)1129 (set-empty)1130 (car vars))1131 (new-variables (cdr vars)))))1132(define (set-prc-names! vars vals)1133 (let loop ((vars vars) (vals vals))1134 (if (not (null? vars))1135 (let ((var (car vars)) (val (car vals)))1136 (if (prc? val) (prc-name-set! val (symbol->string (var-name var))))1137 (loop (cdr vars) (cdr vals))))))1138(define (free-variables node)1139 (if (eq? (node-fv node) #t)1140 (let ((x (apply set-union (map free-variables (node-children node)))))1141 (node-fv-set!1142 node1143 (cond ((ref? node)1144 (if (global? (ref-var node)) x (set-adjoin x (ref-var node))))1145 ((set? node)1146 (if (global? (set-var node)) x (set-adjoin x (set-var node))))1147 ((prc? node) (set-difference x (list->set (prc-parms node))))1148 ((and (app? node) (prc? (app-oper node)))1149 (set-difference x (list->set (prc-parms (app-oper node)))))1150 (else x)))))1151 (node-fv node))1152(define (bound-variables node) (list->set (prc-parms node)))1153(define (not-mutable? var) (set-empty? (var-sets var)))1154(define (mutable? var) (not (not-mutable? var)))1155(define (bound? var) (var-bound var))1156(define (global? var) (not (bound? var)))1157(define (global-val var)1158 (and (global? var)1159 (let ((sets (set->list (var-sets var))))1160 (and (pair? sets)1161 (null? (cdr sets))1162 (def? (car sets))1163 (eq? (compilation-strategy (node-decl (car sets))) block-sym)1164 (def-val (car sets))))))1165(define **not-sym (string->canonical-symbol "##NOT"))1166(define **quasi-append-sym (string->canonical-symbol "##QUASI-APPEND"))1167(define **quasi-list-sym (string->canonical-symbol "##QUASI-LIST"))1168(define **quasi-cons-sym (string->canonical-symbol "##QUASI-CONS"))1169(define **quasi-list->vector-sym1170 (string->canonical-symbol "##QUASI-LIST->VECTOR"))1171(define **case-memv-sym (string->canonical-symbol "##CASE-MEMV"))1172(define **unassigned?-sym (string->canonical-symbol "##UNASSIGNED?"))1173(define **make-cell-sym (string->canonical-symbol "##MAKE-CELL"))1174(define **cell-ref-sym (string->canonical-symbol "##CELL-REF"))1175(define **cell-set!-sym (string->canonical-symbol "##CELL-SET!"))1176(define **make-placeholder-sym (string->canonical-symbol "##MAKE-PLACEHOLDER"))1177(define ieee-scheme-sym (string->canonical-symbol "IEEE-SCHEME"))1178(define r4rs-scheme-sym (string->canonical-symbol "R4RS-SCHEME"))1179(define multilisp-sym (string->canonical-symbol "MULTILISP"))1180(define lambda-lift-sym (string->canonical-symbol "LAMBDA-LIFT"))1181(define block-sym (string->canonical-symbol "BLOCK"))1182(define separate-sym (string->canonical-symbol "SEPARATE"))1183(define standard-bindings-sym (string->canonical-symbol "STANDARD-BINDINGS"))1184(define extended-bindings-sym (string->canonical-symbol "EXTENDED-BINDINGS"))1185(define safe-sym (string->canonical-symbol "SAFE"))1186(define interrupts-enabled-sym (string->canonical-symbol "INTERRUPTS-ENABLED"))1187(define-flag-decl ieee-scheme-sym 'dialect)1188(define-flag-decl r4rs-scheme-sym 'dialect)1189(define-flag-decl multilisp-sym 'dialect)1190(define-boolean-decl lambda-lift-sym)1191(define-flag-decl block-sym 'compilation-strategy)1192(define-flag-decl separate-sym 'compilation-strategy)1193(define-namable-boolean-decl standard-bindings-sym)1194(define-namable-boolean-decl extended-bindings-sym)1195(define-boolean-decl safe-sym)1196(define-boolean-decl interrupts-enabled-sym)1197(define (scheme-dialect decl)1198 (declaration-value 'dialect #f ieee-scheme-sym decl))1199(define (lambda-lift? decl) (declaration-value lambda-lift-sym #f #t decl))1200(define (compilation-strategy decl)1201 (declaration-value 'compilation-strategy #f separate-sym decl))1202(define (standard-binding? name decl)1203 (declaration-value standard-bindings-sym name #f decl))1204(define (extended-binding? name decl)1205 (declaration-value extended-bindings-sym name #f decl))1206(define (add-extended-bindings decl)1207 (add-decl (list extended-bindings-sym #t) decl))1208(define (intrs-enabled? decl)1209 (declaration-value interrupts-enabled-sym #f #t decl))1210(define (add-not-interrupts-enabled decl)1211 (add-decl (list interrupts-enabled-sym #f) decl))1212(define (safe? decl) (declaration-value safe-sym #f #f decl))1213(define (add-not-safe decl) (add-decl (list safe-sym #f) decl))1214(define (dialect-specific-keywords dialect)1215 (cond ((eq? dialect ieee-scheme-sym) ieee-scheme-specific-keywords)1216 ((eq? dialect r4rs-scheme-sym) r4rs-scheme-specific-keywords)1217 ((eq? dialect multilisp-sym) multilisp-specific-keywords)1218 (else1219 (compiler-internal-error1220 "dialect-specific-keywords, unknown dialect"1221 dialect))))1222(define (dialect-specific-procedures dialect)1223 (cond ((eq? dialect ieee-scheme-sym) ieee-scheme-specific-procedures)1224 ((eq? dialect r4rs-scheme-sym) r4rs-scheme-specific-procedures)1225 ((eq? dialect multilisp-sym) multilisp-specific-procedures)1226 (else1227 (compiler-internal-error1228 "dialect-specific-procedures, unknown dialect"1229 dialect))))1230(define (make-standard-procedure x)1231 (cons (string->canonical-symbol (car x)) (cdr x)))1232(define (standard-procedure name decl)1233 (or (assq name (dialect-specific-procedures (scheme-dialect decl)))1234 (assq name common-procedures)))1235(define (standard-procedure-call-pattern proc) (cdr proc))1236(define ieee-scheme-specific-keywords '())1237(define ieee-scheme-specific-procedures (map make-standard-procedure '()))1238(define r4rs-scheme-specific-keywords (list delay-sym))1239(define r4rs-scheme-specific-procedures1240 (map make-standard-procedure1241 '(("LIST-TAIL" 2)1242 ("-" . 1)1243 ("/" . 1)1244 ("STRING->LIST" 1)1245 ("LIST->STRING" 1)1246 ("STRING-COPY" 1)1247 ("STRING-FILL!" 2)1248 ("VECTOR->LIST" 1)1249 ("LIST->VECTOR" 1)1250 ("VECTOR-FILL!" 2)1251 ("FORCE" 1)1252 ("WITH-INPUT-FROM-FILE" 2)1253 ("WITH-OUTPUT-TO-FILE" 2)1254 ("CHAR-READY?" 0 1)1255 ("LOAD" 1)1256 ("TRANSCRIPT-ON" 1)1257 ("TRANSCRIPT-OFF" 0))))1258(define multilisp-specific-keywords (list delay-sym future-sym))1259(define multilisp-specific-procedures1260 (map make-standard-procedure '(("FORCE" 1) ("TOUCH" 1))))1261(define common-keywords1262 (list quote-sym1263 quasiquote-sym1264 unquote-sym1265 unquote-splicing-sym1266 lambda-sym1267 if-sym1268 set!-sym1269 cond-sym1270 =>-sym1271 else-sym1272 and-sym1273 or-sym1274 case-sym1275 let-sym1276 let*-sym1277 letrec-sym1278 begin-sym1279 do-sym1280 define-sym1281 **define-macro-sym1282 **declare-sym1283 **include-sym))1284(define common-procedures1285 (map make-standard-procedure1286 '(("NOT" 1)1287 ("BOOLEAN?" 1)1288 ("EQV?" 2)1289 ("EQ?" 2)1290 ("EQUAL?" 2)1291 ("PAIR?" 1)1292 ("CONS" 2)1293 ("CAR" 1)1294 ("CDR" 1)1295 ("SET-CAR!" 2)1296 ("SET-CDR!" 2)1297 ("CAAR" 1)1298 ("CADR" 1)1299 ("CDAR" 1)1300 ("CDDR" 1)1301 ("CAAAR" 1)1302 ("CAADR" 1)1303 ("CADAR" 1)1304 ("CADDR" 1)1305 ("CDAAR" 1)1306 ("CDADR" 1)1307 ("CDDAR" 1)1308 ("CDDDR" 1)1309 ("CAAAAR" 1)1310 ("CAAADR" 1)1311 ("CAADAR" 1)1312 ("CAADDR" 1)1313 ("CADAAR" 1)1314 ("CADADR" 1)1315 ("CADDAR" 1)1316 ("CADDDR" 1)1317 ("CDAAAR" 1)1318 ("CDAADR" 1)1319 ("CDADAR" 1)1320 ("CDADDR" 1)1321 ("CDDAAR" 1)1322 ("CDDADR" 1)1323 ("CDDDAR" 1)1324 ("CDDDDR" 1)1325 ("NULL?" 1)1326 ("LIST?" 1)1327 ("LIST" . 0)1328 ("LENGTH" 1)1329 ("APPEND" . 0)1330 ("REVERSE" 1)1331 ("LIST-REF" 2)1332 ("MEMQ" 2)1333 ("MEMV" 2)1334 ("MEMBER" 2)1335 ("ASSQ" 2)1336 ("ASSV" 2)1337 ("ASSOC" 2)1338 ("SYMBOL?" 1)1339 ("SYMBOL->STRING" 1)1340 ("STRING->SYMBOL" 1)1341 ("NUMBER?" 1)1342 ("COMPLEX?" 1)1343 ("REAL?" 1)1344 ("RATIONAL?" 1)1345 ("INTEGER?" 1)1346 ("EXACT?" 1)1347 ("INEXACT?" 1)1348 ("=" . 2)1349 ("<" . 2)1350 (">" . 2)1351 ("<=" . 2)1352 (">=" . 2)1353 ("ZERO?" 1)1354 ("POSITIVE?" 1)1355 ("NEGATIVE?" 1)1356 ("ODD?" 1)1357 ("EVEN?" 1)1358 ("MAX" . 1)1359 ("MIN" . 1)1360 ("+" . 0)1361 ("*" . 0)1362 ("-" 1 2)1363 ("/" 1 2)1364 ("ABS" 1)1365 ("QUOTIENT" 2)1366 ("REMAINDER" 2)1367 ("MODULO" 2)1368 ("GCD" . 0)1369 ("LCM" . 0)1370 ("NUMERATOR" 1)1371 ("DENOMINATOR" 1)1372 ("FLOOR" 1)1373 ("CEILING" 1)1374 ("TRUNCATE" 1)1375 ("ROUND" 1)1376 ("RATIONALIZE" 2)1377 ("EXP" 1)1378 ("LOG" 1)1379 ("SIN" 1)1380 ("COS" 1)1381 ("TAN" 1)1382 ("ASIN" 1)1383 ("ACOS" 1)1384 ("ATAN" 1 2)1385 ("SQRT" 1)1386 ("EXPT" 2)1387 ("MAKE-RECTANGULAR" 2)1388 ("MAKE-POLAR" 2)1389 ("REAL-PART" 1)1390 ("IMAG-PART" 1)1391 ("MAGNITUDE" 1)1392 ("ANGLE" 1)1393 ("EXACT->INEXACT" 1)1394 ("INEXACT->EXACT" 1)1395 ("NUMBER->STRING" 1 2)1396 ("STRING->NUMBER" 1 2)1397 ("CHAR?" 1)1398 ("CHAR=?" 2)1399 ("CHAR<?" 2)1400 ("CHAR>?" 2)1401 ("CHAR<=?" 2)1402 ("CHAR>=?" 2)1403 ("CHAR-CI=?" 2)1404 ("CHAR-CI<?" 2)1405 ("CHAR-CI>?" 2)1406 ("CHAR-CI<=?" 2)1407 ("CHAR-CI>=?" 2)1408 ("CHAR-ALPHABETIC?" 1)1409 ("CHAR-NUMERIC?" 1)1410 ("CHAR-WHITESPACE?" 1)1411 ("CHAR-UPPER-CASE?" 1)1412 ("CHAR-LOWER-CASE?" 1)1413 ("CHAR->INTEGER" 1)1414 ("INTEGER->CHAR" 1)1415 ("CHAR-UPCASE" 1)1416 ("CHAR-DOWNCASE" 1)1417 ("STRING?" 1)1418 ("MAKE-STRING" 1 2)1419 ("STRING" . 0)1420 ("STRING-LENGTH" 1)1421 ("STRING-REF" 2)1422 ("STRING-SET!" 3)1423 ("STRING=?" 2)1424 ("STRING<?" 2)1425 ("STRING>?" 2)1426 ("STRING<=?" 2)1427 ("STRING>=?" 2)1428 ("STRING-CI=?" 2)1429 ("STRING-CI<?" 2)1430 ("STRING-CI>?" 2)1431 ("STRING-CI<=?" 2)1432 ("STRING-CI>=?" 2)1433 ("SUBSTRING" 3)1434 ("STRING-APPEND" . 0)1435 ("VECTOR?" 1)1436 ("MAKE-VECTOR" 1 2)1437 ("VECTOR" . 0)1438 ("VECTOR-LENGTH" 1)1439 ("VECTOR-REF" 2)1440 ("VECTOR-SET!" 3)1441 ("PROCEDURE?" 1)1442 ("APPLY" . 2)1443 ("MAP" . 2)1444 ("FOR-EACH" . 2)1445 ("CALL-WITH-CURRENT-CONTINUATION" 1)1446 ("CALL-WITH-INPUT-FILE" 2)1447 ("CALL-WITH-OUTPUT-FILE" 2)1448 ("INPUT-PORT?" 1)1449 ("OUTPUT-PORT?" 1)1450 ("CURRENT-INPUT-PORT" 0)1451 ("CURRENT-OUTPUT-PORT" 0)1452 ("OPEN-INPUT-FILE" 1)1453 ("OPEN-OUTPUT-FILE" 1)1454 ("CLOSE-INPUT-PORT" 1)1455 ("CLOSE-OUTPUT-PORT" 1)1456 ("EOF-OBJECT?" 1)1457 ("READ" 0 1)1458 ("READ-CHAR" 0 1)1459 ("PEEK-CHAR" 0 1)1460 ("WRITE" 1 2)1461 ("DISPLAY" 1 2)1462 ("NEWLINE" 0 1)1463 ("WRITE-CHAR" 1 2))))1464(define (parse-program program env module-name proc)1465 (define (parse-prog program env lst proc)1466 (if (null? program)1467 (proc (reverse lst) env)1468 (let ((source (car program)))1469 (cond ((macro-expr? source env)1470 (parse-prog1471 (cons (macro-expand source env) (cdr program))1472 env1473 lst1474 proc))1475 ((begin-defs-expr? source)1476 (parse-prog1477 (append (begin-defs-body source) (cdr program))1478 env1479 lst1480 proc))1481 ((include-expr? source)1482 (if *ptree-port* (display " " *ptree-port*))1483 (let ((x (file->sources*1484 (include-filename source)1485 *ptree-port*1486 (source-locat source))))1487 (if *ptree-port* (newline *ptree-port*))1488 (parse-prog (append x (cdr program)) env lst proc)))1489 ((define-macro-expr? source env)1490 (if *ptree-port*1491 (begin1492 (display " \"macro\"" *ptree-port*)1493 (newline *ptree-port*)))1494 (parse-prog (cdr program) (add-macro source env) lst proc))1495 ((declare-expr? source)1496 (if *ptree-port*1497 (begin1498 (display " \"decl\"" *ptree-port*)1499 (newline *ptree-port*)))1500 (parse-prog1501 (cdr program)1502 (add-declarations source env)1503 lst1504 proc))1505 ((define-expr? source env)1506 (let* ((var** (definition-variable source))1507 (var* (source-code var**))1508 (var (env-lookup-var env var* var**)))1509 (if *ptree-port*1510 (begin1511 (display " " *ptree-port*)1512 (display (var-name var) *ptree-port*)1513 (newline *ptree-port*)))1514 (let ((node (pt (definition-value source) env 'true)))1515 (set-prc-names! (list var) (list node))1516 (parse-prog1517 (cdr program)1518 env1519 (cons (cons (new-def source1520 (env-declarations env)1521 var1522 node)1523 env)1524 lst)1525 proc))))1526 ((c-declaration-expr? source)1527 (if *ptree-port*1528 (begin1529 (display " \"c-decl\"" *ptree-port*)1530 (newline *ptree-port*)))1531 (add-c-declaration (source-code (cadr (source-code source))))1532 (parse-prog (cdr program) env lst proc))1533 ((c-init-expr? source)1534 (if *ptree-port*1535 (begin1536 (display " \"c-init\"" *ptree-port*)1537 (newline *ptree-port*)))1538 (add-c-init (source-code (cadr (source-code source))))1539 (parse-prog (cdr program) env lst proc))1540 (else1541 (if *ptree-port*1542 (begin1543 (display " \"expr\"" *ptree-port*)1544 (newline *ptree-port*)))1545 (parse-prog1546 (cdr program)1547 env1548 (cons (cons (pt source env 'true) env) lst)1549 proc))))))1550 (if *ptree-port*1551 (begin (display "Parsing:" *ptree-port*) (newline *ptree-port*)))1552 (c-interface-begin module-name)1553 (parse-prog1554 program1555 env1556 '()1557 (lambda (lst env)1558 (if *ptree-port* (newline *ptree-port*))1559 (proc lst env (c-interface-end)))))1560(define (c-interface-begin module-name)1561 (set! c-interface-module-name module-name)1562 (set! c-interface-proc-count 0)1563 (set! c-interface-decls '())1564 (set! c-interface-procs '())1565 (set! c-interface-inits '())1566 #f)1567(define (c-interface-end)1568 (let ((i (make-c-intf1569 (reverse c-interface-decls)1570 (reverse c-interface-procs)1571 (reverse c-interface-inits))))1572 (set! c-interface-module-name #f)1573 (set! c-interface-proc-count #f)1574 (set! c-interface-decls #f)1575 (set! c-interface-procs #f)1576 (set! c-interface-inits #f)1577 i))1578(define c-interface-module-name #f)1579(define c-interface-proc-count #f)1580(define c-interface-decls #f)1581(define c-interface-procs #f)1582(define c-interface-inits #f)1583(define (make-c-intf decls procs inits) (vector decls procs inits))1584(define (c-intf-decls c-intf) (vector-ref c-intf 0))1585(define (c-intf-decls-set! c-intf x) (vector-set! c-intf 0 x))1586(define (c-intf-procs c-intf) (vector-ref c-intf 1))1587(define (c-intf-procs-set! c-intf x) (vector-set! c-intf 1 x))1588(define (c-intf-inits c-intf) (vector-ref c-intf 2))1589(define (c-intf-inits-set! c-intf x) (vector-set! c-intf 2 x))1590(define (c-declaration-expr? source)1591 (and (mymatch **c-declaration-sym 1 source)1592 (let ((code (source-code source)))1593 (or (string? (source-code (cadr code)))1594 (pt-syntax-error1595 source1596 "Argument to '##c-declaration' must be a string")))))1597(define (c-init-expr? source)1598 (and (mymatch **c-init-sym 1 source)1599 (let ((code (source-code source)))1600 (or (string? (source-code (cadr code)))1601 (pt-syntax-error1602 source1603 "Argument to '##c-init' must be a string")))))1604(define (c-procedure-expr? source)1605 (and (mymatch **c-procedure-sym 3 source)1606 (let ((code (source-code source)))1607 (if (not (string? (source-code (cadddr code))))1608 (pt-syntax-error1609 source1610 "Last argument to '##c-procedure' must be a string")1611 (check-arg-and-result-types source (cadr code) (caddr code))))))1612(define scheme-to-c-notation1613 (list (list void-sym "VOID" "void")1614 (list char-sym "CHAR" "char")1615 (list signed-char-sym "SCHAR" "signed char")1616 (list unsigned-char-sym "UCHAR" "unsigned char")1617 (list short-sym "SHORT" "short")1618 (list unsigned-short-sym "USHORT" "unsigned short")1619 (list int-sym "INT" "int")1620 (list unsigned-int-sym "UINT" "unsigned int")1621 (list long-sym "LONG" "long")1622 (list unsigned-long-sym "ULONG" "unsigned long")1623 (list float-sym "FLOAT" "float")1624 (list double-sym "DOUBLE" "double")1625 (list pointer-sym "POINTER" "void*")1626 (list boolean-sym "BOOLEAN" "int")1627 (list string-sym "STRING" "char*")1628 (list scheme-object-sym "SCMOBJ" "long")))1629(define (convert-type typ) (if (assq typ scheme-to-c-notation) typ #f))1630(define (check-arg-and-result-types source arg-typs-source res-typ-source)1631 (let ((arg-typs (source-code arg-typs-source))1632 (res-typ (source-code res-typ-source)))1633 (let ((res-type (convert-type res-typ)))1634 (if (not res-type)1635 (pt-syntax-error res-typ-source "Invalid result type")1636 (if (not (proper-length arg-typs))1637 (pt-syntax-error1638 arg-typs-source1639 "Ill-terminated argument type list")1640 (let loop ((lst arg-typs))1641 (if (pair? lst)1642 (let* ((arg-typ (source-code (car lst)))1643 (arg-type (convert-type arg-typ)))1644 (if (or (not arg-type) (eq? arg-type void-sym))1645 (pt-syntax-error (car lst) "Invalid argument type")1646 (loop (cdr lst))))1647 #t)))))))1648(define (add-c-declaration declaration-string)1649 (set! c-interface-decls (cons declaration-string c-interface-decls))1650 #f)1651(define (add-c-init initialization-code-string)1652 (set! c-interface-inits (cons initialization-code-string c-interface-inits))1653 #f)1654(define (add-c-proc scheme-name c-name arity def)1655 (set! c-interface-procs1656 (cons (vector scheme-name c-name arity def) c-interface-procs))1657 #f)1658(define (pt-c-procedure source env use)1659 (let* ((code (source-code source))1660 (name (build-c-procedure1661 (map source-code (source-code (cadr code)))1662 (source-code (caddr code))1663 (source-code (cadddr code))))1664 (decl (env-declarations env)))1665 (new-ref source decl (env-lookup-global-var env (string->symbol name)))))1666(define (build-c-procedure argument-types result-type proc-name-or-code)1667 (define proc-name?1668 (let loop ((i (- (string-length proc-name-or-code) 1)))1669 (if (>= i 0)1670 (let ((c (string-ref proc-name-or-code i)))1671 (if (or (char-alphabetic? c) (char=? c #\_)) (loop (- i 1)) #f))1672 #t)))1673 (define nl (string #\newline))1674 (define undefined-value "UND")1675 (define scheme-arg-prefix "ARG")1676 (define scheme-result-name "RESULT")1677 (define c-arg-prefix "arg")1678 (define c-result-name "result")1679 (define scheme-to-c-prefix "SCMOBJ_TO_")1680 (define c-to-scheme-suffix "_TO_SCMOBJ")1681 (define (c-type-name typ) (cadr (assq typ scheme-to-c-notation)))1682 (define (c-type-decl typ) (caddr (assq typ scheme-to-c-notation)))1683 (define (listify strings)1684 (if (null? strings)1685 ""1686 (string-append1687 (car strings)1688 (apply string-append1689 (map (lambda (s) (string-append "," s)) (cdr strings))))))1690 (define (scheme-arg-var t)1691 (string-append c-id-prefix scheme-arg-prefix (number->string (cdr t))))1692 (define (c-arg-var t)1693 (string-append c-id-prefix c-arg-prefix (number->string (cdr t))))1694 (define (make-c-procedure arg-types res-type)1695 (define (make-arg-decl)1696 (apply string-append1697 (map (lambda (t)1698 (string-append1699 (c-type-decl (car t))1700 " "1701 (c-arg-var t)1702 ";"1703 nl))1704 arg-types)))1705 (define (make-conversions)1706 (if (not (null? arg-types))1707 (let loop ((lst arg-types) (str (string-append "if (" nl)))1708 (if (null? lst)1709 (string-append str " )" nl)1710 (let ((t (car lst)) (rest (cdr lst)))1711 (loop rest1712 (string-append1713 str1714 " "1715 c-id-prefix1716 scheme-to-c-prefix1717 (c-type-name (car t))1718 "("1719 (scheme-arg-var t)1720 ","1721 (c-arg-var t)1722 ")"1723 (if (null? rest) "" " &&")1724 nl)))))1725 ""))1726 (define (make-body)1727 (if proc-name?1728 (let* ((param-list (listify (map c-arg-var arg-types)))1729 (call (string-append proc-name-or-code "(" param-list ")")))1730 (if (eq? res-type void-sym)1731 (string-append1732 "{"1733 nl1734 call1735 ";"1736 nl1737 c-id-prefix1738 scheme-result-name1739 " = "1740 c-id-prefix1741 undefined-value1742 ";"1743 nl1744 "}"1745 nl)1746 (string-append1747 c-id-prefix1748 (c-type-name res-type)1749 c-to-scheme-suffix1750 "("1751 call1752 ","1753 c-id-prefix1754 scheme-result-name1755 ");"1756 nl)))1757 (if (eq? res-type void-sym)1758 (string-append1759 "{"1760 nl1761 proc-name-or-code1762 nl1763 c-id-prefix1764 scheme-result-name1765 " = "1766 c-id-prefix1767 undefined-value1768 ";"1769 nl1770 "}"1771 nl)1772 (string-append1773 "{"1774 nl1775 proc-name-or-code1776 nl1777 c-id-prefix1778 (c-type-name res-type)1779 c-to-scheme-suffix1780 "("1781 c-id-prefix1782 c-result-name1783 ","1784 c-id-prefix1785 scheme-result-name1786 ");"1787 nl1788 "}"1789 nl))))1790 (let* ((index (number->string c-interface-proc-count))1791 (scheme-name (string-append "#!" c-interface-module-name "#" index))1792 (c-name (string-append c-id-prefix (scheme-id->c-id scheme-name)))1793 (arity (length argument-types))1794 (def (string-append1795 (if (or proc-name? (eq? res-type void-sym))1796 ""1797 (string-append1798 (c-type-decl res-type)1799 " "1800 c-id-prefix1801 c-result-name1802 ";"1803 nl))1804 (make-arg-decl)1805 (make-conversions)1806 (make-body))))1807 (set! c-interface-proc-count (+ c-interface-proc-count 1))1808 (add-c-proc scheme-name c-name arity def)1809 scheme-name))1810 (let loop ((i 1) (lst1 argument-types) (lst2 '()))1811 (if (pair? lst1)1812 (loop (+ i 1) (cdr lst1) (cons (cons (car lst1) i) lst2))1813 (make-c-procedure (reverse lst2) result-type))))1814(define (scheme-id->c-id s)1815 (define (hex->char i) (string-ref "0123456789abcdef" i))1816 (let loop ((i (- (string-length s) 1)) (l '()))1817 (if (>= i 0)1818 (let ((c (string-ref s i)))1819 (cond ((or (char-alphabetic? c) (char-numeric? c))1820 (loop (- i 1) (cons c l)))1821 ((char=? c #\_) (loop (- i 1) (cons c (cons c l))))1822 (else1823 (let ((n (character-encoding c)))1824 (loop (- i 1)1825 (cons #\_1826 (cons (hex->char (quotient n 16))1827 (cons (hex->char (modulo n 16)) l))))))))1828 (lst->string l))))1829(define (pt-syntax-error source msg . args)1830 (apply compiler-user-error1831 (cons (source-locat source)1832 (cons (string-append "Syntax error -- " msg) args))))1833(define (pt source env use)1834 (cond ((macro-expr? source env) (pt (macro-expand source env) env use))1835 ((self-eval-expr? source) (pt-self-eval source env use))1836 ((quote-expr? source) (pt-quote source env use))1837 ((quasiquote-expr? source) (pt-quasiquote source env use))1838 ((unquote-expr? source)1839 (pt-syntax-error source "Ill-placed 'unquote'"))1840 ((unquote-splicing-expr? source)1841 (pt-syntax-error source "Ill-placed 'unquote-splicing'"))1842 ((var-expr? source env) (pt-var source env use))1843 ((set!-expr? source env) (pt-set! source env use))1844 ((lambda-expr? source env) (pt-lambda source env use))1845 ((if-expr? source) (pt-if source env use))1846 ((cond-expr? source) (pt-cond source env use))1847 ((and-expr? source) (pt-and source env use))1848 ((or-expr? source) (pt-or source env use))1849 ((case-expr? source) (pt-case source env use))1850 ((let-expr? source env) (pt-let source env use))1851 ((let*-expr? source env) (pt-let* source env use))1852 ((letrec-expr? source env) (pt-letrec source env use))1853 ((begin-expr? source) (pt-begin source env use))1854 ((do-expr? source env) (pt-do source env use))1855 ((define-expr? source env)1856 (pt-syntax-error source "Ill-placed 'define'"))1857 ((delay-expr? source env) (pt-delay source env use))1858 ((future-expr? source env) (pt-future source env use))1859 ((define-macro-expr? source env)1860 (pt-syntax-error source "Ill-placed '##define-macro'"))1861 ((begin-defs-expr? source)1862 (pt-syntax-error source "Ill-placed 'begin' style definitions"))1863 ((declare-expr? source)1864 (pt-syntax-error source "Ill-placed '##declare'"))1865 ((c-declaration-expr? source)1866 (pt-syntax-error source "Ill-placed '##c-declaration'"))1867 ((c-init-expr? source)1868 (pt-syntax-error source "Ill-placed '##c-init'"))1869 ((c-procedure-expr? source) (pt-c-procedure source env use))1870 ((combination-expr? source) (pt-combination source env use))1871 (else (compiler-internal-error "pt, unknown expression type" source))))1872(define (macro-expand source env)1873 (let ((code (source-code source)))1874 (expression->source1875 (apply (cdr (env-lookup-macro env (source-code (car code))))1876 (cdr (source->expression source)))1877 source)))1878(define (pt-self-eval source env use)1879 (let ((val (source->expression source)))1880 (if (eq? use 'none)1881 (new-cst source (env-declarations env) undef-object)1882 (new-cst source (env-declarations env) val))))1883(define (pt-quote source env use)1884 (let ((code (source-code source)))1885 (if (eq? use 'none)1886 (new-cst source (env-declarations env) undef-object)1887 (new-cst source1888 (env-declarations env)1889 (source->expression (cadr code))))))1890(define (pt-quasiquote source env use)1891 (let ((code (source-code source))) (pt-quasiquotation (cadr code) 1 env)))1892(define (pt-quasiquotation form level env)1893 (cond ((= level 0) (pt form env 'true))1894 ((quasiquote-expr? form)1895 (pt-quasiquotation-list form (source-code form) (+ level 1) env))1896 ((unquote-expr? form)1897 (if (= level 1)1898 (pt (cadr (source-code form)) env 'true)1899 (pt-quasiquotation-list form (source-code form) (- level 1) env)))1900 ((unquote-splicing-expr? form)1901 (if (= level 1)1902 (pt-syntax-error form "Ill-placed 'unquote-splicing'")1903 (pt-quasiquotation-list form (source-code form) (- level 1) env)))1904 ((pair? (source-code form))1905 (pt-quasiquotation-list form (source-code form) level env))1906 ((vector? (source-code form))1907 (vector-form1908 form1909 (pt-quasiquotation-list1910 form1911 (vector->lst (source-code form))1912 level1913 env)1914 env))1915 (else1916 (new-cst form (env-declarations env) (source->expression form)))))1917(define (pt-quasiquotation-list form l level env)1918 (cond ((pair? l)1919 (if (and (unquote-splicing-expr? (car l)) (= level 1))1920 (let ((x (pt (cadr (source-code (car l))) env 'true)))1921 (if (null? (cdr l))1922 x1923 (append-form1924 (car l)1925 x1926 (pt-quasiquotation-list form (cdr l) 1 env)1927 env)))1928 (cons-form1929 form1930 (pt-quasiquotation (car l) level env)1931 (pt-quasiquotation-list form (cdr l) level env)1932 env)))1933 ((null? l) (new-cst form (env-declarations env) '()))1934 (else (pt-quasiquotation l level env))))1935(define (append-form source ptree1 ptree2 env)1936 (cond ((and (cst? ptree1) (cst? ptree2))1937 (new-cst source1938 (env-declarations env)1939 (append (cst-val ptree1) (cst-val ptree2))))1940 ((and (cst? ptree2) (null? (cst-val ptree2))) ptree1)1941 (else1942 (new-call*1943 source1944 (add-not-safe (env-declarations env))1945 (new-ref-extended-bindings source **quasi-append-sym env)1946 (list ptree1 ptree2)))))1947(define (cons-form source ptree1 ptree2 env)1948 (cond ((and (cst? ptree1) (cst? ptree2))1949 (new-cst source1950 (env-declarations env)1951 (cons (cst-val ptree1) (cst-val ptree2))))1952 ((and (cst? ptree2) (null? (cst-val ptree2)))1953 (new-call*1954 source1955 (add-not-safe (env-declarations env))1956 (new-ref-extended-bindings source **quasi-list-sym env)1957 (list ptree1)))1958 (else1959 (new-call*1960 source1961 (add-not-safe (env-declarations env))1962 (new-ref-extended-bindings source **quasi-cons-sym env)1963 (list ptree1 ptree2)))))1964(define (vector-form source ptree env)1965 (if (cst? ptree)1966 (new-cst source (env-declarations env) (lst->vector (cst-val ptree)))1967 (new-call*1968 source1969 (add-not-safe (env-declarations env))1970 (new-ref-extended-bindings source **quasi-list->vector-sym env)1971 (list ptree))))1972(define (pt-var source env use)1973 (if (eq? use 'none)1974 (new-cst source (env-declarations env) undef-object)1975 (new-ref source1976 (env-declarations env)1977 (env-lookup-var env (source-code source) source))))1978(define (pt-set! source env use)1979 (let ((code (source-code source)))1980 (new-set source1981 (env-declarations env)1982 (env-lookup-var env (source-code (cadr code)) (cadr code))1983 (pt (caddr code) env 'true))))1984(define (pt-lambda source env use)1985 (let ((code (source-code source)))1986 (define (new-params parms)1987 (cond ((pair? parms)1988 (let* ((parm* (car parms))1989 (parm (source-code parm*))1990 (p* (if (pair? parm) (car parm) parm*)))1991 (cons (make-var (source-code p*) #t (set-empty) (set-empty) p*)1992 (new-params (cdr parms)))))1993 ((null? parms) '())1994 (else1995 (list (make-var1996 (source-code parms)1997 #t1998 (set-empty)1999 (set-empty)2000 parms)))))2001 (define (min-params parms)2002 (let loop ((l parms) (n 0))2003 (if (pair? l)2004 (if (pair? (source-code (car l))) n (loop (cdr l) (+ n 1)))2005 n)))2006 (define (rest-param? parms)2007 (if (pair? parms) (rest-param? (cdr parms)) (not (null? parms))))2008 (define (optionals parms source body env)2009 (if (pair? parms)2010 (let* ((parm* (car parms)) (parm (source-code parm*)))2011 (if (and (pair? parm) (length? parm 2))2012 (let* ((var (car parm))2013 (vars (new-variables (list var)))2014 (decl (env-declarations env)))2015 (new-call*2016 parm*2017 decl2018 (new-prc parm*2019 decl2020 #f2021 12022 #f2023 vars2024 (optionals2025 (cdr parms)2026 source2027 body2028 (env-frame env vars)))2029 (list (new-tst parm*2030 decl2031 (new-call*2032 parm*2033 decl2034 (new-ref-extended-bindings2035 parm*2036 **unassigned?-sym2037 env)2038 (list (new-ref parm*2039 decl2040 (env-lookup-var2041 env2042 (source-code var)2043 var))))2044 (pt (cadr parm) env 'true)2045 (new-ref parm*2046 decl2047 (env-lookup-var2048 env2049 (source-code var)2050 var))))))2051 (optionals (cdr parms) source body env)))2052 (pt-body source body env 'true)))2053 (if (eq? use 'none)2054 (new-cst source (env-declarations env) undef-object)2055 (let* ((parms (source->parms (cadr code))) (frame (new-params parms)))2056 (new-prc source2057 (env-declarations env)2058 #f2059 (min-params parms)2060 (rest-param? parms)2061 frame2062 (optionals2063 parms2064 source2065 (cddr code)2066 (env-frame env frame)))))))2067(define (source->parms source)2068 (let ((x (source-code source))) (if (or (pair? x) (null? x)) x source)))2069(define (pt-body source body env use)2070 (define (letrec-defines vars vals envs body env)2071 (cond ((null? body)2072 (pt-syntax-error2073 source2074 "Body must contain at least one evaluable expression"))2075 ((macro-expr? (car body) env)2076 (letrec-defines2077 vars2078 vals2079 envs2080 (cons (macro-expand (car body) env) (cdr body))2081 env))2082 ((begin-defs-expr? (car body))2083 (letrec-defines2084 vars2085 vals2086 envs2087 (append (begin-defs-body (car body)) (cdr body))2088 env))2089 ((include-expr? (car body))2090 (if *ptree-port* (display " " *ptree-port*))2091 (let ((x (file->sources*2092 (include-filename (car body))2093 *ptree-port*2094 (source-locat (car body)))))2095 (if *ptree-port* (newline *ptree-port*))2096 (letrec-defines vars vals envs (append x (cdr body)) env)))2097 ((define-expr? (car body) env)2098 (let* ((var** (definition-variable (car body)))2099 (var* (source-code var**))2100 (var (env-define-var env var* var**)))2101 (letrec-defines2102 (cons var vars)2103 (cons (definition-value (car body)) vals)2104 (cons env envs)2105 (cdr body)2106 env)))2107 ((declare-expr? (car body))2108 (letrec-defines2109 vars2110 vals2111 envs2112 (cdr body)2113 (add-declarations (car body) env)))2114 ((define-macro-expr? (car body) env)2115 (letrec-defines2116 vars2117 vals2118 envs2119 (cdr body)2120 (add-macro (car body) env)))2121 ((c-declaration-expr? (car body))2122 (add-c-declaration (source-code (cadr (source-code (car body)))))2123 (letrec-defines vars vals envs (cdr body) env))2124 ((c-init-expr? (car body))2125 (add-c-init (source-code (cadr (source-code (car body)))))2126 (letrec-defines vars vals envs (cdr body) env))2127 ((null? vars) (pt-sequence source body env use))2128 (else2129 (let ((vars* (reverse vars)))2130 (let loop ((vals* '()) (l1 vals) (l2 envs))2131 (if (not (null? l1))2132 (loop (cons (pt (car l1) (car l2) 'true) vals*)2133 (cdr l1)2134 (cdr l2))2135 (pt-recursive-let source vars* vals* body env use)))))))2136 (letrec-defines '() '() '() body (env-frame env '())))2137(define (pt-sequence source seq env use)2138 (if (length? seq 1)2139 (pt (car seq) env use)2140 (new-seq source2141 (env-declarations env)2142 (pt (car seq) env 'none)2143 (pt-sequence source (cdr seq) env use))))2144(define (pt-if source env use)2145 (let ((code (source-code source)))2146 (new-tst source2147 (env-declarations env)2148 (pt (cadr code) env 'pred)2149 (pt (caddr code) env use)2150 (if (length? code 3)2151 (new-cst source (env-declarations env) undef-object)2152 (pt (cadddr code) env use)))))2153(define (pt-cond source env use)2154 (define (pt-clauses clauses)2155 (if (length? clauses 0)2156 (new-cst source (env-declarations env) undef-object)2157 (let* ((clause* (car clauses)) (clause (source-code clause*)))2158 (cond ((eq? (source-code (car clause)) else-sym)2159 (pt-sequence clause* (cdr clause) env use))2160 ((length? clause 1)2161 (new-disj2162 clause*2163 (env-declarations env)2164 (pt (car clause) env (if (eq? use 'true) 'true 'pred))2165 (pt-clauses (cdr clauses))))2166 ((eq? (source-code (cadr clause)) =>-sym)2167 (new-disj-call2168 clause*2169 (env-declarations env)2170 (pt (car clause) env 'true)2171 (pt (caddr clause) env 'true)2172 (pt-clauses (cdr clauses))))2173 (else2174 (new-tst clause*2175 (env-declarations env)2176 (pt (car clause) env 'pred)2177 (pt-sequence clause* (cdr clause) env use)2178 (pt-clauses (cdr clauses))))))))2179 (pt-clauses (cdr (source-code source))))2180(define (pt-and source env use)2181 (define (pt-exprs exprs)2182 (cond ((length? exprs 0) (new-cst source (env-declarations env) #t))2183 ((length? exprs 1) (pt (car exprs) env use))2184 (else2185 (new-conj2186 (car exprs)2187 (env-declarations env)2188 (pt (car exprs) env (if (eq? use 'true) 'true 'pred))2189 (pt-exprs (cdr exprs))))))2190 (pt-exprs (cdr (source-code source))))2191(define (pt-or source env use)2192 (define (pt-exprs exprs)2193 (cond ((length? exprs 0)2194 (new-cst source (env-declarations env) false-object))2195 ((length? exprs 1) (pt (car exprs) env use))2196 (else2197 (new-disj2198 (car exprs)2199 (env-declarations env)2200 (pt (car exprs) env (if (eq? use 'true) 'true 'pred))2201 (pt-exprs (cdr exprs))))))2202 (pt-exprs (cdr (source-code source))))2203(define (pt-case source env use)2204 (let ((code (source-code source)) (temp (new-temps source '(temp))))2205 (define (pt-clauses clauses)2206 (if (length? clauses 0)2207 (new-cst source (env-declarations env) undef-object)2208 (let* ((clause* (car clauses)) (clause (source-code clause*)))2209 (if (eq? (source-code (car clause)) else-sym)2210 (pt-sequence clause* (cdr clause) env use)2211 (new-tst clause*2212 (env-declarations env)2213 (new-call*2214 clause*2215 (add-not-safe (env-declarations env))2216 (new-ref-extended-bindings2217 clause*2218 **case-memv-sym2219 env)2220 (list (new-ref clause*2221 (env-declarations env)2222 (car temp))2223 (new-cst (car clause)2224 (env-declarations env)2225 (source->expression (car clause)))))2226 (pt-sequence clause* (cdr clause) env use)2227 (pt-clauses (cdr clauses)))))))2228 (new-call*2229 source2230 (env-declarations env)2231 (new-prc source2232 (env-declarations env)2233 #f2234 12235 #f2236 temp2237 (pt-clauses (cddr code)))2238 (list (pt (cadr code) env 'true)))))2239(define (pt-let source env use)2240 (let ((code (source-code source)))2241 (if (bindable-var? (cadr code) env)2242 (let* ((self (new-variables (list (cadr code))))2243 (bindings (map source-code (source-code (caddr code))))2244 (vars (new-variables (map car bindings)))2245 (vals (map (lambda (x) (pt (cadr x) env 'true)) bindings))2246 (env (env-frame (env-frame env vars) self))2247 (self-proc2248 (list (new-prc source2249 (env-declarations env)2250 #f2251 (length vars)2252 #f2253 vars2254 (pt-body source (cdddr code) env use)))))2255 (set-prc-names! self self-proc)2256 (set-prc-names! vars vals)2257 (new-call*2258 source2259 (env-declarations env)2260 (new-prc source2261 (env-declarations env)2262 #f2263 12264 #f2265 self2266 (new-call*2267 source2268 (env-declarations env)2269 (new-ref source (env-declarations env) (car self))2270 vals))2271 self-proc))2272 (if (null? (source-code (cadr code)))2273 (pt-body source (cddr code) env use)2274 (let* ((bindings (map source-code (source-code (cadr code))))2275 (vars (new-variables (map car bindings)))2276 (vals (map (lambda (x) (pt (cadr x) env 'true)) bindings))2277 (env (env-frame env vars)))2278 (set-prc-names! vars vals)2279 (new-call*2280 source2281 (env-declarations env)2282 (new-prc source2283 (env-declarations env)2284 #f2285 (length vars)2286 #f2287 vars2288 (pt-body source (cddr code) env use))2289 vals))))))2290(define (pt-let* source env use)2291 (let ((code (source-code source)))2292 (define (pt-bindings bindings env use)2293 (if (null? bindings)2294 (pt-body source (cddr code) env use)2295 (let* ((binding* (car bindings))2296 (binding (source-code binding*))2297 (vars (new-variables (list (car binding))))2298 (vals (list (pt (cadr binding) env 'true)))2299 (env (env-frame env vars)))2300 (set-prc-names! vars vals)2301 (new-call*2302 binding*2303 (env-declarations env)2304 (new-prc binding*2305 (env-declarations env)2306 #f2307 12308 #f2309 vars2310 (pt-bindings (cdr bindings) env use))2311 vals))))2312 (pt-bindings (source-code (cadr code)) env use)))2313(define (pt-letrec source env use)2314 (let* ((code (source-code source))2315 (bindings (map source-code (source-code (cadr code))))2316 (vars* (new-variables (map car bindings)))2317 (env* (env-frame env vars*)))2318 (pt-recursive-let2319 source2320 vars*2321 (map (lambda (x) (pt (cadr x) env* 'true)) bindings)2322 (cddr code)2323 env*2324 use)))2325(define (pt-recursive-let source vars vals body env use)2326 (define (dependency-graph vars vals)2327 (define (dgraph vars* vals*)2328 (if (null? vars*)2329 (set-empty)2330 (let ((var (car vars*)) (val (car vals*)))2331 (set-adjoin2332 (dgraph (cdr vars*) (cdr vals*))2333 (make-gnode2334 var2335 (set-intersection (list->set vars) (free-variables val)))))))2336 (dgraph vars vals))2337 (define (val-of var)2338 (list-ref vals (- (length vars) (length (memq var vars)))))2339 (define (bind-in-order order)2340 (if (null? order)2341 (pt-body source body env use)2342 (let* ((vars-set (car order)) (vars (set->list vars-set)))2343 (let loop1 ((l (reverse vars))2344 (vars-b '())2345 (vals-b '())2346 (vars-a '()))2347 (if (not (null? l))2348 (let* ((var (car l)) (val (val-of var)))2349 (if (or (prc? val)2350 (set-empty?2351 (set-intersection (free-variables val) vars-set)))2352 (loop1 (cdr l)2353 (cons var vars-b)2354 (cons val vals-b)2355 vars-a)2356 (loop1 (cdr l) vars-b vals-b (cons var vars-a))))2357 (let* ((result1 (let loop2 ((l vars-a))2358 (if (not (null? l))2359 (let* ((var (car l)) (val (val-of var)))2360 (new-seq source2361 (env-declarations env)2362 (new-set source2363 (env-declarations2364 env)2365 var2366 val)2367 (loop2 (cdr l))))2368 (bind-in-order (cdr order)))))2369 (result2 (if (null? vars-b)2370 result12371 (new-call*2372 source2373 (env-declarations env)2374 (new-prc source2375 (env-declarations env)2376 #f2377 (length vars-b)2378 #f2379 vars-b2380 result1)2381 vals-b)))2382 (result3 (if (null? vars-a)2383 result22384 (new-call*2385 source2386 (env-declarations env)2387 (new-prc source2388 (env-declarations env)2389 #f2390 (length vars-a)2391 #f2392 vars-a2393 result2)2394 (map (lambda (var)2395 (new-cst source2396 (env-declarations env)2397 undef-object))2398 vars-a)))))2399 result3))))))2400 (set-prc-names! vars vals)2401 (bind-in-order2402 (topological-sort (transitive-closure (dependency-graph vars vals)))))2403(define (pt-begin source env use)2404 (pt-sequence source (cdr (source-code source)) env use))2405(define (pt-do source env use)2406 (let* ((code (source-code source))2407 (loop (new-temps source '(loop)))2408 (bindings (map source-code (source-code (cadr code))))2409 (vars (new-variables (map car bindings)))2410 (init (map (lambda (x) (pt (cadr x) env 'true)) bindings))2411 (env (env-frame env vars))2412 (step (map (lambda (x)2413 (pt (if (length? x 2) (car x) (caddr x)) env 'true))2414 bindings))2415 (exit (source-code (caddr code))))2416 (set-prc-names! vars init)2417 (new-call*2418 source2419 (env-declarations env)2420 (new-prc source2421 (env-declarations env)2422 #f2423 12424 #f2425 loop2426 (new-call*2427 source2428 (env-declarations env)2429 (new-ref source (env-declarations env) (car loop))2430 init))2431 (list (new-prc source2432 (env-declarations env)2433 #f2434 (length vars)2435 #f2436 vars2437 (new-tst source2438 (env-declarations env)2439 (pt (car exit) env 'pred)2440 (if (length? exit 1)2441 (new-cst (caddr code)2442 (env-declarations env)2443 undef-object)2444 (pt-sequence (caddr code) (cdr exit) env use))2445 (if (length? code 3)2446 (new-call*2447 source2448 (env-declarations env)2449 (new-ref source2450 (env-declarations env)2451 (car loop))2452 step)2453 (new-seq source2454 (env-declarations env)2455 (pt-sequence2456 source2457 (cdddr code)2458 env2459 'none)2460 (new-call*2461 source2462 (env-declarations env)2463 (new-ref source2464 (env-declarations env)2465 (car loop))2466 step)))))))))2467(define (pt-combination source env use)2468 (let* ((code (source-code source))2469 (oper (pt (car code) env 'true))2470 (decl (node-decl oper)))2471 (new-call*2472 source2473 (env-declarations env)2474 oper2475 (map (lambda (x) (pt x env 'true)) (cdr code)))))2476(define (pt-delay source env use)2477 (let ((code (source-code source)))2478 (new-call*2479 source2480 (add-not-safe (env-declarations env))2481 (new-ref-extended-bindings source **make-placeholder-sym env)2482 (list (new-prc source2483 (env-declarations env)2484 #f2485 02486 #f2487 '()2488 (pt (cadr code) env 'true))))))2489(define (pt-future source env use)2490 (let ((decl (env-declarations env)) (code (source-code source)))2491 (new-fut source decl (pt (cadr code) env 'true))))2492(define (self-eval-expr? source)2493 (let ((code (source-code source)))2494 (and (not (pair? code)) (not (symbol-object? code)))))2495(define (quote-expr? source) (mymatch quote-sym 1 source))2496(define (quasiquote-expr? source) (mymatch quasiquote-sym 1 source))2497(define (unquote-expr? source) (mymatch unquote-sym 1 source))2498(define (unquote-splicing-expr? source)2499 (mymatch unquote-splicing-sym 1 source))2500(define (var-expr? source env)2501 (let ((code (source-code source)))2502 (and (symbol-object? code)2503 (not-keyword source env code)2504 (not-macro source env code))))2505(define (not-macro source env name)2506 (if (env-lookup-macro env name)2507 (pt-syntax-error source "Macro name can't be used as a variable:" name)2508 #t))2509(define (bindable-var? source env)2510 (let ((code (source-code source)))2511 (and (symbol-object? code) (not-keyword source env code))))2512(define (not-keyword source env name)2513 (if (or (memq name common-keywords)2514 (memq name2515 (dialect-specific-keywords2516 (scheme-dialect (env-declarations env)))))2517 (pt-syntax-error2518 source2519 "Predefined keyword can't be used as a variable:"2520 name)2521 #t))2522(define (set!-expr? source env)2523 (and (mymatch set!-sym 2 source)2524 (var-expr? (cadr (source-code source)) env)))2525(define (lambda-expr? source env)2526 (and (mymatch lambda-sym -2 source)2527 (proper-parms? (source->parms (cadr (source-code source))) env)))2528(define (if-expr? source)2529 (and (mymatch if-sym -2 source)2530 (or (<= (length (source-code source)) 4)2531 (pt-syntax-error source "Ill-formed special form" if-sym))))2532(define (cond-expr? source)2533 (and (mymatch cond-sym -1 source) (proper-clauses? source)))2534(define (and-expr? source) (mymatch and-sym 0 source))2535(define (or-expr? source) (mymatch or-sym 0 source))2536(define (case-expr? source)2537 (and (mymatch case-sym -2 source) (proper-case-clauses? source)))2538(define (let-expr? source env)2539 (and (mymatch let-sym -2 source)2540 (let ((code (source-code source)))2541 (if (bindable-var? (cadr code) env)2542 (and (proper-bindings? (caddr code) #t env)2543 (or (> (length code) 3)2544 (pt-syntax-error source "Ill-formed named 'let'")))2545 (proper-bindings? (cadr code) #t env)))))2546(define (let*-expr? source env)2547 (and (mymatch let*-sym -2 source)2548 (proper-bindings? (cadr (source-code source)) #f env)))2549(define (letrec-expr? source env)2550 (and (mymatch letrec-sym -2 source)2551 (proper-bindings? (cadr (source-code source)) #t env)))2552(define (begin-expr? source) (mymatch begin-sym -1 source))2553(define (do-expr? source env)2554 (and (mymatch do-sym -2 source)2555 (proper-do-bindings? source env)2556 (proper-do-exit? source)))2557(define (define-expr? source env)2558 (and (mymatch define-sym -1 source)2559 (proper-definition? source env)2560 (let ((v (definition-variable source)))2561 (not-macro v env (source-code v)))))2562(define (combination-expr? source)2563 (let ((length (proper-length (source-code source))))2564 (if length2565 (or (> length 0) (pt-syntax-error source "Ill-formed procedure call"))2566 (pt-syntax-error source "Ill-terminated procedure call"))))2567(define (delay-expr? source env)2568 (and (not (eq? (scheme-dialect (env-declarations env)) ieee-scheme-sym))2569 (mymatch delay-sym 1 source)))2570(define (future-expr? source env)2571 (and (eq? (scheme-dialect (env-declarations env)) multilisp-sym)2572 (mymatch future-sym 1 source)))2573(define (macro-expr? source env)2574 (let ((code (source-code source)))2575 (and (pair? code)2576 (symbol-object? (source-code (car code)))2577 (let ((macr (env-lookup-macro env (source-code (car code)))))2578 (and macr2579 (let ((len (proper-length (cdr code))))2580 (if len2581 (let ((len* (+ len 1)) (size (car macr)))2582 (or (if (> size 0) (= len* size) (>= len* (- size)))2583 (pt-syntax-error source "Ill-formed macro form")))2584 (pt-syntax-error2585 source2586 "Ill-terminated macro form"))))))))2587(define (define-macro-expr? source env)2588 (and (mymatch **define-macro-sym -1 source) (proper-definition? source env)))2589(define (declare-expr? source) (mymatch **declare-sym -1 source))2590(define (include-expr? source) (mymatch **include-sym 1 source))2591(define (begin-defs-expr? source) (mymatch begin-sym 0 source))2592(define (mymatch keyword size source)2593 (let ((code (source-code source)))2594 (and (pair? code)2595 (eq? (source-code (car code)) keyword)2596 (let ((length (proper-length (cdr code))))2597 (if length2598 (or (if (> size 0) (= length size) (>= length (- size)))2599 (pt-syntax-error source "Ill-formed special form" keyword))2600 (pt-syntax-error2601 source2602 "Ill-terminated special form"2603 keyword))))))2604(define (proper-length l)2605 (define (length l n)2606 (cond ((pair? l) (length (cdr l) (+ n 1))) ((null? l) n) (else #f)))2607 (length l 0))2608(define (proper-definition? source env)2609 (let* ((code (source-code source))2610 (pattern* (cadr code))2611 (pattern (source-code pattern*))2612 (body (cddr code)))2613 (cond ((bindable-var? pattern* env)2614 (cond ((length? body 0) #t)2615 ((length? body 1) #t)2616 (else (pt-syntax-error source "Ill-formed definition body"))))2617 ((pair? pattern)2618 (if (length? body 0)2619 (pt-syntax-error2620 source2621 "Body of a definition must have at least one expression"))2622 (if (bindable-var? (car pattern) env)2623 (proper-parms? (cdr pattern) env)2624 (pt-syntax-error2625 (car pattern)2626 "Procedure name must be an identifier")))2627 (else (pt-syntax-error pattern* "Ill-formed definition pattern")))))2628(define (definition-variable def)2629 (let* ((code (source-code def)) (pattern (cadr code)))2630 (if (pair? (source-code pattern)) (car (source-code pattern)) pattern)))2631(define (definition-value def)2632 (let ((code (source-code def)) (loc (source-locat def)))2633 (cond ((pair? (source-code (cadr code)))2634 (make-source2635 (cons (make-source lambda-sym loc)2636 (cons (parms->source (cdr (source-code (cadr code))) loc)2637 (cddr code)))2638 loc))2639 ((null? (cddr code))2640 (make-source2641 (list (make-source quote-sym loc) (make-source undef-object loc))2642 loc))2643 (else (caddr code)))))2644(define (parms->source parms loc)2645 (if (or (pair? parms) (null? parms)) (make-source parms loc) parms))2646(define (proper-parms? parms env)2647 (define (proper-parms parms seen optional-seen)2648 (cond ((pair? parms)2649 (let* ((parm* (car parms)) (parm (source-code parm*)))2650 (cond ((pair? parm)2651 (if (eq? (scheme-dialect (env-declarations env))2652 multilisp-sym)2653 (let ((length (proper-length parm)))2654 (if (or (eqv? length 1) (eqv? length 2))2655 (let ((var (car parm)))2656 (if (bindable-var? var env)2657 (if (memq (source-code var) seen)2658 (pt-syntax-error2659 var2660 "Duplicate parameter in parameter list")2661 (proper-parms2662 (cdr parms)2663 (cons (source-code var) seen)2664 #t))2665 (pt-syntax-error2666 var2667 "Parameter must be an identifier")))2668 (pt-syntax-error2669 parm*2670 "Ill-formed optional parameter")))2671 (pt-syntax-error2672 parm*2673 "optional parameters illegal in this dialect")))2674 (optional-seen2675 (pt-syntax-error parm* "Optional parameter expected"))2676 ((bindable-var? parm* env)2677 (if (memq parm seen)2678 (pt-syntax-error2679 parm*2680 "Duplicate parameter in parameter list"))2681 (proper-parms (cdr parms) (cons parm seen) #f))2682 (else2683 (pt-syntax-error2684 parm*2685 "Parameter must be an identifier")))))2686 ((null? parms) #t)2687 ((bindable-var? parms env)2688 (if (memq (source-code parms) seen)2689 (pt-syntax-error parms "Duplicate parameter in parameter list")2690 #t))2691 (else2692 (pt-syntax-error parms "Rest parameter must be an identifier"))))2693 (proper-parms parms '() #f))2694(define (proper-clauses? source)2695 (define (proper-clauses clauses)2696 (or (null? clauses)2697 (let* ((clause* (car clauses))2698 (clause (source-code clause*))2699 (length (proper-length clause)))2700 (if length2701 (if (>= length 1)2702 (if (eq? (source-code (car clause)) else-sym)2703 (cond ((= length 1)2704 (pt-syntax-error2705 clause*2706 "Else clause must have a body"))2707 ((not (null? (cdr clauses)))2708 (pt-syntax-error2709 clause*2710 "Else clause must be the last clause"))2711 (else (proper-clauses (cdr clauses))))2712 (if (and (>= length 2)2713 (eq? (source-code (cadr clause)) =>-sym)2714 (not (= length 3)))2715 (pt-syntax-error2716 (cadr clause)2717 "'=>' must be followed by a single expression")2718 (proper-clauses (cdr clauses))))2719 (pt-syntax-error clause* "Ill-formed 'cond' clause"))2720 (pt-syntax-error clause* "Ill-terminated 'cond' clause")))))2721 (proper-clauses (cdr (source-code source))))2722(define (proper-case-clauses? source)2723 (define (proper-case-clauses clauses)2724 (or (null? clauses)2725 (let* ((clause* (car clauses))2726 (clause (source-code clause*))2727 (length (proper-length clause)))2728 (if length2729 (if (>= length 2)2730 (if (eq? (source-code (car clause)) else-sym)2731 (if (not (null? (cdr clauses)))2732 (pt-syntax-error2733 clause*2734 "Else clause must be the last clause")2735 (proper-case-clauses (cdr clauses)))2736 (begin2737 (proper-selector-list? (car clause))2738 (proper-case-clauses (cdr clauses))))2739 (pt-syntax-error2740 clause*2741 "A 'case' clause must have a selector list and a body"))2742 (pt-syntax-error clause* "Ill-terminated 'case' clause")))))2743 (proper-case-clauses (cddr (source-code source))))2744(define (proper-selector-list? source)2745 (let* ((code (source-code source)) (length (proper-length code)))2746 (if length2747 (or (>= length 1)2748 (pt-syntax-error2749 source2750 "Selector list must contain at least one element"))2751 (pt-syntax-error source "Ill-terminated selector list"))))2752(define (proper-bindings? bindings check-dupl? env)2753 (define (proper-bindings l seen)2754 (cond ((pair? l)2755 (let* ((binding* (car l)) (binding (source-code binding*)))2756 (if (eqv? (proper-length binding) 2)2757 (let ((var (car binding)))2758 (if (bindable-var? var env)2759 (if (and check-dupl? (memq (source-code var) seen))2760 (pt-syntax-error2761 var2762 "Duplicate variable in bindings")2763 (proper-bindings2764 (cdr l)2765 (cons (source-code var) seen)))2766 (pt-syntax-error2767 var2768 "Binding variable must be an identifier")))2769 (pt-syntax-error binding* "Ill-formed binding"))))2770 ((null? l) #t)2771 (else (pt-syntax-error bindings "Ill-terminated binding list"))))2772 (proper-bindings (source-code bindings) '()))2773(define (proper-do-bindings? source env)2774 (let ((bindings (cadr (source-code source))))2775 (define (proper-bindings l seen)2776 (cond ((pair? l)2777 (let* ((binding* (car l))2778 (binding (source-code binding*))2779 (length (proper-length binding)))2780 (if (or (eqv? length 2) (eqv? length 3))2781 (let ((var (car binding)))2782 (if (bindable-var? var env)2783 (if (memq (source-code var) seen)2784 (pt-syntax-error2785 var2786 "Duplicate variable in bindings")2787 (proper-bindings2788 (cdr l)2789 (cons (source-code var) seen)))2790 (pt-syntax-error2791 var2792 "Binding variable must be an identifier")))2793 (pt-syntax-error binding* "Ill-formed binding"))))2794 ((null? l) #t)2795 (else (pt-syntax-error bindings "Ill-terminated binding list"))))2796 (proper-bindings (source-code bindings) '())))2797(define (proper-do-exit? source)2798 (let* ((code (source-code (caddr (source-code source))))2799 (length (proper-length code)))2800 (if length2801 (or (> length 0) (pt-syntax-error source "Ill-formed exit clause"))2802 (pt-syntax-error source "Ill-terminated exit clause"))))2803(define (include-filename source) (source-code (cadr (source-code source))))2804(define (begin-defs-body source) (cdr (source-code source)))2805(define (length? l n)2806 (cond ((null? l) (= n 0)) ((> n 0) (length? (cdr l) (- n 1))) (else #f)))2807(define (transform-declaration source)2808 (let ((code (source-code source)))2809 (if (not (pair? code))2810 (pt-syntax-error source "Ill-formed declaration")2811 (let* ((pos (not (eq? (source-code (car code)) not-sym)))2812 (x (if pos code (cdr code))))2813 (if (not (pair? x))2814 (pt-syntax-error source "Ill-formed declaration")2815 (let* ((id* (car x)) (id (source-code id*)))2816 (cond ((not (symbol-object? id))2817 (pt-syntax-error2818 id*2819 "Declaration name must be an identifier"))2820 ((assq id flag-declarations)2821 (cond ((not pos)2822 (pt-syntax-error2823 id*2824 "Declaration can't be negated"))2825 ((null? (cdr x))2826 (flag-decl2827 source2828 (cdr (assq id flag-declarations))2829 id))2830 (else2831 (pt-syntax-error2832 source2833 "Ill-formed declaration"))))2834 ((memq id parameterized-declarations)2835 (cond ((not pos)2836 (pt-syntax-error2837 id*2838 "Declaration can't be negated"))2839 ((eqv? (proper-length x) 2)2840 (parameterized-decl2841 source2842 id2843 (source->expression (cadr x))))2844 (else2845 (pt-syntax-error2846 source2847 "Ill-formed declaration"))))2848 ((memq id boolean-declarations)2849 (if (null? (cdr x))2850 (boolean-decl source id pos)2851 (pt-syntax-error source "Ill-formed declaration")))2852 ((assq id namable-declarations)2853 (cond ((not pos)2854 (pt-syntax-error2855 id*2856 "Declaration can't be negated"))2857 (else2858 (namable-decl2859 source2860 (cdr (assq id namable-declarations))2861 id2862 (map source->expression (cdr x))))))2863 ((memq id namable-boolean-declarations)2864 (namable-boolean-decl2865 source2866 id2867 pos2868 (map source->expression (cdr x))))2869 ((memq id namable-string-declarations)2870 (if (not (pair? (cdr x)))2871 (pt-syntax-error source "Ill-formed declaration")2872 (let* ((str* (cadr x)) (str (source-code str*)))2873 (cond ((not pos)2874 (pt-syntax-error2875 id*2876 "Declaration can't be negated"))2877 ((not (string? str))2878 (pt-syntax-error str* "String expected"))2879 (else2880 (namable-string-decl2881 source2882 id2883 str2884 (map source->expression (cddr x))))))))2885 (else (pt-syntax-error id* "Unknown declaration")))))))))2886(define (add-declarations source env)2887 (let loop ((l (cdr (source-code source))) (env env))2888 (if (pair? l)2889 (loop (cdr l) (env-declare env (transform-declaration (car l))))2890 env)))2891(define (add-decl d decl) (env-declare decl d))2892(define (add-macro source env)2893 (define (form-size parms)2894 (let loop ((l parms) (n 1))2895 (if (pair? l) (loop (cdr l) (+ n 1)) (if (null? l) n (- n)))))2896 (define (error-proc . msgs)2897 (apply compiler-user-error2898 (cons (source-locat source) (cons "(in macro body)" msgs))))2899 (let ((var (definition-variable source)) (proc (definition-value source)))2900 (if (lambda-expr? proc env)2901 (env-macro2902 env2903 (source-code var)2904 (cons (form-size (source->parms (cadr (source-code proc))))2905 (scheme-global-eval (source->expression proc) error-proc)))2906 (pt-syntax-error source "Macro value must be a lambda expression"))))2907(define (ptree.begin! info-port) (set! *ptree-port* info-port) '())2908(define (ptree.end!) '())2909(define *ptree-port* '())2910(define (normalize-parse-tree ptree env)2911 (define (normalize ptree)2912 (let ((tree (assignment-convert (partial-evaluate ptree) env)))2913 (lambda-lift! tree)2914 tree))2915 (if (def? ptree)2916 (begin2917 (node-children-set! ptree (list (normalize (def-val ptree))))2918 ptree)2919 (normalize ptree)))2920(define (partial-evaluate ptree) (pe ptree '()))2921(define (pe ptree consts)2922 (cond ((cst? ptree)2923 (new-cst (node-source ptree) (node-decl ptree) (cst-val ptree)))2924 ((ref? ptree)2925 (let ((var (ref-var ptree)))2926 (var-refs-set! var (set-remove (var-refs var) ptree))2927 (let ((x (assq var consts)))2928 (if x2929 (new-cst (node-source ptree) (node-decl ptree) (cdr x))2930 (let ((y (global-val var)))2931 (if (and y (cst? y))2932 (new-cst (node-source ptree)2933 (node-decl ptree)2934 (cst-val y))2935 (new-ref (node-source ptree)2936 (node-decl ptree)2937 var)))))))2938 ((set? ptree)2939 (let ((var (set-var ptree)) (val (pe (set-val ptree) consts)))2940 (var-sets-set! var (set-remove (var-sets var) ptree))2941 (new-set (node-source ptree) (node-decl ptree) var val)))2942 ((tst? ptree)2943 (let ((pre (pe (tst-pre ptree) consts)))2944 (if (cst? pre)2945 (let ((val (cst-val pre)))2946 (if (false-object? val)2947 (pe (tst-alt ptree) consts)2948 (pe (tst-con ptree) consts)))2949 (new-tst (node-source ptree)2950 (node-decl ptree)2951 pre2952 (pe (tst-con ptree) consts)2953 (pe (tst-alt ptree) consts)))))2954 ((conj? ptree)2955 (let ((pre (pe (conj-pre ptree) consts)))2956 (if (cst? pre)2957 (let ((val (cst-val pre)))2958 (if (false-object? val) pre (pe (conj-alt ptree) consts)))2959 (new-conj2960 (node-source ptree)2961 (node-decl ptree)2962 pre2963 (pe (conj-alt ptree) consts)))))2964 ((disj? ptree)2965 (let ((pre (pe (disj-pre ptree) consts)))2966 (if (cst? pre)2967 (let ((val (cst-val pre)))2968 (if (false-object? val) (pe (disj-alt ptree) consts) pre))2969 (new-disj2970 (node-source ptree)2971 (node-decl ptree)2972 pre2973 (pe (disj-alt ptree) consts)))))2974 ((prc? ptree)2975 (new-prc (node-source ptree)2976 (node-decl ptree)2977 (prc-name ptree)2978 (prc-min ptree)2979 (prc-rest ptree)2980 (prc-parms ptree)2981 (pe (prc-body ptree) consts)))2982 ((app? ptree)2983 (let ((oper (app-oper ptree)) (args (app-args ptree)))2984 (if (and (prc? oper)2985 (not (prc-rest oper))2986 (= (length (prc-parms oper)) (length args)))2987 (pe-let ptree consts)2988 (new-call2989 (node-source ptree)2990 (node-decl ptree)2991 (pe oper consts)2992 (map (lambda (x) (pe x consts)) args)))))2993 ((fut? ptree)2994 (new-fut (node-source ptree)2995 (node-decl ptree)2996 (pe (fut-val ptree) consts)))2997 (else (compiler-internal-error "pe, unknown parse tree node type"))))2998(define (pe-let ptree consts)2999 (let* ((proc (app-oper ptree))3000 (vals (app-args ptree))3001 (vars (prc-parms proc))3002 (non-mut-vars (set-keep not-mutable? (list->set vars))))3003 (for-each3004 (lambda (var)3005 (var-refs-set! var (set-empty))3006 (var-sets-set! var (set-empty)))3007 vars)3008 (let loop ((l vars)3009 (v vals)3010 (new-vars '())3011 (new-vals '())3012 (new-consts consts))3013 (if (null? l)3014 (if (null? new-vars)3015 (pe (prc-body proc) new-consts)3016 (new-call3017 (node-source ptree)3018 (node-decl ptree)3019 (new-prc (node-source proc)3020 (node-decl proc)3021 #f3022 (length new-vars)3023 #f3024 (reverse new-vars)3025 (pe (prc-body proc) new-consts))3026 (reverse new-vals)))3027 (let ((var (car l)) (val (pe (car v) consts)))3028 (if (and (set-member? var non-mut-vars) (cst? val))3029 (loop (cdr l)3030 (cdr v)3031 new-vars3032 new-vals3033 (cons (cons var (cst-val val)) new-consts))3034 (loop (cdr l)3035 (cdr v)3036 (cons var new-vars)3037 (cons val new-vals)3038 new-consts)))))))3039(define (assignment-convert ptree env)3040 (ac ptree (env-declare env (list safe-sym #f)) '()))3041(define (ac ptree env mut)3042 (cond ((cst? ptree) ptree)3043 ((ref? ptree)3044 (let ((var (ref-var ptree)))3045 (if (global? var)3046 ptree3047 (let ((x (assq var mut)))3048 (if x3049 (let ((source (node-source ptree)))3050 (var-refs-set! var (set-remove (var-refs var) ptree))3051 (new-call3052 source3053 (node-decl ptree)3054 (new-ref-extended-bindings source **cell-ref-sym env)3055 (list (new-ref source (node-decl ptree) (cdr x)))))3056 ptree)))))3057 ((set? ptree)3058 (let ((var (set-var ptree))3059 (source (node-source ptree))3060 (val (ac (set-val ptree) env mut)))3061 (var-sets-set! var (set-remove (var-sets var) ptree))3062 (if (global? var)3063 (new-set source (node-decl ptree) var val)3064 (new-call3065 source3066 (node-decl ptree)3067 (new-ref-extended-bindings source **cell-set!-sym env)3068 (list (new-ref source (node-decl ptree) (cdr (assq var mut)))3069 val)))))3070 ((tst? ptree)3071 (new-tst (node-source ptree)3072 (node-decl ptree)3073 (ac (tst-pre ptree) env mut)3074 (ac (tst-con ptree) env mut)3075 (ac (tst-alt ptree) env mut)))3076 ((conj? ptree)3077 (new-conj3078 (node-source ptree)3079 (node-decl ptree)3080 (ac (conj-pre ptree) env mut)3081 (ac (conj-alt ptree) env mut)))3082 ((disj? ptree)3083 (new-disj3084 (node-source ptree)3085 (node-decl ptree)3086 (ac (disj-pre ptree) env mut)3087 (ac (disj-alt ptree) env mut)))3088 ((prc? ptree) (ac-proc ptree env mut))3089 ((app? ptree)3090 (let ((oper (app-oper ptree)) (args (app-args ptree)))3091 (if (and (prc? oper)3092 (not (prc-rest oper))3093 (= (length (prc-parms oper)) (length args)))3094 (ac-let ptree env mut)3095 (new-call3096 (node-source ptree)3097 (node-decl ptree)3098 (ac oper env mut)3099 (map (lambda (x) (ac x env mut)) args)))))3100 ((fut? ptree)3101 (new-fut (node-source ptree)3102 (node-decl ptree)3103 (ac (fut-val ptree) env mut)))3104 (else (compiler-internal-error "ac, unknown parse tree node type"))))3105(define (ac-proc ptree env mut)3106 (let* ((mut-parms (ac-mutables (prc-parms ptree)))3107 (mut-parms-copies (map var-copy mut-parms))3108 (mut (append (pair-up mut-parms mut-parms-copies) mut))3109 (new-body (ac (prc-body ptree) env mut)))3110 (new-prc (node-source ptree)3111 (node-decl ptree)3112 (prc-name ptree)3113 (prc-min ptree)3114 (prc-rest ptree)3115 (prc-parms ptree)3116 (if (null? mut-parms)3117 new-body3118 (new-call3119 (node-source ptree)3120 (node-decl ptree)3121 (new-prc (node-source ptree)3122 (node-decl ptree)3123 #f3124 (length mut-parms-copies)3125 #f3126 mut-parms-copies3127 new-body)3128 (map (lambda (var)3129 (new-call3130 (var-source var)3131 (node-decl ptree)3132 (new-ref-extended-bindings3133 (var-source var)3134 **make-cell-sym3135 env)3136 (list (new-ref (var-source var)3137 (node-decl ptree)3138 var))))3139 mut-parms))))))3140(define (ac-let ptree env mut)3141 (let* ((proc (app-oper ptree))3142 (vals (app-args ptree))3143 (vars (prc-parms proc))3144 (vals-fv (apply set-union (map free-variables vals)))3145 (mut-parms (ac-mutables vars))3146 (mut-parms-copies (map var-copy mut-parms))3147 (mut (append (pair-up mut-parms mut-parms-copies) mut)))3148 (let loop ((l vars)3149 (v vals)3150 (new-vars '())3151 (new-vals '())3152 (new-body (ac (prc-body proc) env mut)))3153 (if (null? l)3154 (new-let ptree proc new-vars new-vals new-body)3155 (let ((var (car l)) (val (car v)))3156 (if (memq var mut-parms)3157 (let ((src (node-source val))3158 (decl (node-decl val))3159 (var* (cdr (assq var mut))))3160 (if (set-member? var vals-fv)3161 (loop (cdr l)3162 (cdr v)3163 (cons var* new-vars)3164 (cons (new-call3165 src3166 decl3167 (new-ref-extended-bindings3168 src3169 **make-cell-sym3170 env)3171 (list (new-cst src decl undef-object)))3172 new-vals)3173 (new-seq src3174 decl3175 (new-call3176 src3177 decl3178 (new-ref-extended-bindings3179 src3180 **cell-set!-sym3181 env)3182 (list (new-ref src decl var*)3183 (ac val env mut)))3184 new-body))3185 (loop (cdr l)3186 (cdr v)3187 (cons var* new-vars)3188 (cons (new-call3189 src3190 decl3191 (new-ref-extended-bindings3192 src3193 **make-cell-sym3194 env)3195 (list (ac val env mut)))3196 new-vals)3197 new-body)))3198 (loop (cdr l)3199 (cdr v)3200 (cons var new-vars)3201 (cons (ac val env mut) new-vals)3202 new-body)))))))3203(define (ac-mutables l)3204 (if (pair? l)3205 (let ((var (car l)) (rest (ac-mutables (cdr l))))3206 (if (mutable? var) (cons var rest) rest))3207 '()))3208(define (lambda-lift! ptree) (ll! ptree (set-empty) '()))3209(define (ll! ptree cst-procs env)3210 (define (new-env env vars)3211 (define (loop i l)3212 (if (pair? l)3213 (let ((var (car l)))3214 (cons (cons var (cons (length (set->list (var-refs var))) i))3215 (loop (+ i 1) (cdr l))))3216 env))3217 (loop (length env) vars))3218 (cond ((or (cst? ptree)3219 (ref? ptree)3220 (set? ptree)3221 (tst? ptree)3222 (conj? ptree)3223 (disj? ptree)3224 (fut? ptree))3225 (for-each3226 (lambda (child) (ll! child cst-procs env))3227 (node-children ptree)))3228 ((prc? ptree)3229 (ll! (prc-body ptree) cst-procs (new-env env (prc-parms ptree))))3230 ((app? ptree)3231 (let ((oper (app-oper ptree)) (args (app-args ptree)))3232 (if (and (prc? oper)3233 (not (prc-rest oper))3234 (= (length (prc-parms oper)) (length args)))3235 (ll!-let ptree cst-procs (new-env env (prc-parms oper)))3236 (for-each3237 (lambda (child) (ll! child cst-procs env))3238 (node-children ptree)))))3239 (else (compiler-internal-error "ll!, unknown parse tree node type"))))3240(define (ll!-let ptree cst-procs env)3241 (let* ((proc (app-oper ptree))3242 (vals (app-args ptree))3243 (vars (prc-parms proc))3244 (var-val-map (pair-up vars vals)))3245 (define (var->val var) (cdr (assq var var-val-map)))3246 (define (liftable-proc-vars vars)3247 (let loop ((cst-proc-vars3248 (set-keep3249 (lambda (var)3250 (let ((val (var->val var)))3251 (and (prc? val)3252 (lambda-lift? (node-decl val))3253 (set-every? oper-pos? (var-refs var)))))3254 (list->set vars))))3255 (let* ((non-cst-proc-vars3256 (set-keep3257 (lambda (var)3258 (let ((val (var->val var)))3259 (and (prc? val) (not (set-member? var cst-proc-vars)))))3260 (list->set vars)))3261 (cst-proc-vars*3262 (set-keep3263 (lambda (var)3264 (let ((val (var->val var)))3265 (set-empty?3266 (set-intersection3267 (free-variables val)3268 non-cst-proc-vars))))3269 cst-proc-vars)))3270 (if (set-equal? cst-proc-vars cst-proc-vars*)3271 cst-proc-vars3272 (loop cst-proc-vars*)))))3273 (define (transitively-closed-free-variables vars)3274 (let ((tcfv-map3275 (map (lambda (var) (cons var (free-variables (var->val var))))3276 vars)))3277 (let loop ((changed? #f))3278 (for-each3279 (lambda (var-tcfv)3280 (let loop2 ((l (set->list (cdr var-tcfv))) (fv (cdr var-tcfv)))3281 (if (null? l)3282 (if (not (set-equal? fv (cdr var-tcfv)))3283 (begin (set-cdr! var-tcfv fv) (set! changed? #t)))3284 (let ((x (assq (car l) tcfv-map)))3285 (loop2 (cdr l) (if x (set-union fv (cdr x)) fv))))))3286 tcfv-map)3287 (if changed? (loop #f) tcfv-map))))3288 (let* ((tcfv-map3289 (transitively-closed-free-variables (liftable-proc-vars vars)))3290 (cst-proc-vars-list (map car tcfv-map))3291 (cst-procs* (set-union (list->set cst-proc-vars-list) cst-procs)))3292 (define (var->tcfv var) (cdr (assq var tcfv-map)))3293 (define (order-vars vars)3294 (map car3295 (sort-list3296 (map (lambda (var) (assq var env)) vars)3297 (lambda (x y)3298 (if (= (cadr x) (cadr y))3299 (< (cddr x) (cddr y))3300 (< (cadr x) (cadr y)))))))3301 (define (lifted-vars var)3302 (order-vars (set->list (set-difference (var->tcfv var) cst-procs*))))3303 (define (lift-app! var)3304 (let* ((val (var->val var)) (vars (lifted-vars var)))3305 (define (new-ref* var)3306 (new-ref (var-source var) (node-decl val) var))3307 (if (not (null? vars))3308 (for-each3309 (lambda (oper)3310 (let ((node (node-parent oper)))3311 (node-children-set!3312 node3313 (cons (app-oper node)3314 (append (map new-ref* vars) (app-args node))))))3315 (set->list (var-refs var))))))3316 (define (lift-prc! var)3317 (let* ((val (var->val var)) (vars (lifted-vars var)))3318 (if (not (null? vars))3319 (let ((var-copies (map var-copy vars)))3320 (prc-parms-set! val (append var-copies (prc-parms val)))3321 (for-each (lambda (x) (var-bound-set! x val)) var-copies)3322 (node-fv-invalidate! val)3323 (prc-min-set! val (+ (prc-min val) (length vars)))3324 (ll-rename! val (pair-up vars var-copies))))))3325 (for-each lift-app! cst-proc-vars-list)3326 (for-each lift-prc! cst-proc-vars-list)3327 (for-each (lambda (node) (ll! node cst-procs* env)) vals)3328 (ll! (prc-body proc) cst-procs* env))))3329(define (ll-rename! ptree var-map)3330 (cond ((ref? ptree)3331 (let* ((var (ref-var ptree)) (x (assq var var-map)))3332 (if x3333 (begin3334 (var-refs-set! var (set-remove (var-refs var) ptree))3335 (var-refs-set! (cdr x) (set-adjoin (var-refs (cdr x)) ptree))3336 (ref-var-set! ptree (cdr x))))))3337 ((set? ptree)3338 (let* ((var (set-var ptree)) (x (assq var var-map)))3339 (if x3340 (begin3341 (var-sets-set! var (set-remove (var-sets var) ptree))3342 (var-sets-set! (cdr x) (set-adjoin (var-sets (cdr x)) ptree))3343 (set-var-set! ptree (cdr x)))))))3344 (node-fv-set! ptree #t)3345 (for-each (lambda (child) (ll-rename! child var-map)) (node-children ptree)))3346(define (parse-tree->expression ptree) (se ptree '() (list 0)))3347(define (se ptree env num)3348 (cond ((cst? ptree) (list quote-sym (cst-val ptree)))3349 ((ref? ptree)3350 (let ((x (assq (ref-var ptree) env)))3351 (if x (cdr x) (var-name (ref-var ptree)))))3352 ((set? ptree)3353 (list set!-sym3354 (let ((x (assq (set-var ptree) env)))3355 (if x (cdr x) (var-name (set-var ptree))))3356 (se (set-val ptree) env num)))3357 ((def? ptree)3358 (list define-sym3359 (let ((x (assq (def-var ptree) env)))3360 (if x (cdr x) (var-name (def-var ptree))))3361 (se (def-val ptree) env num)))3362 ((tst? ptree)3363 (list if-sym3364 (se (tst-pre ptree) env num)3365 (se (tst-con ptree) env num)3366 (se (tst-alt ptree) env num)))3367 ((conj? ptree)3368 (list and-sym3369 (se (conj-pre ptree) env num)3370 (se (conj-alt ptree) env num)))3371 ((disj? ptree)3372 (list or-sym3373 (se (disj-pre ptree) env num)3374 (se (disj-alt ptree) env num)))3375 ((prc? ptree)3376 (let ((new-env (se-rename (prc-parms ptree) env num)))3377 (list lambda-sym3378 (se-parameters3379 (prc-parms ptree)3380 (prc-rest ptree)3381 (prc-min ptree)3382 new-env)3383 (se (prc-body ptree) new-env num))))3384 ((app? ptree)3385 (let ((oper (app-oper ptree)) (args (app-args ptree)))3386 (if (and (prc? oper)3387 (not (prc-rest oper))3388 (= (length (prc-parms oper)) (length args)))3389 (let ((new-env (se-rename (prc-parms oper) env num)))3390 (list (if (set-empty?3391 (set-intersection3392 (list->set (prc-parms oper))3393 (apply set-union (map free-variables args))))3394 let-sym3395 letrec-sym)3396 (se-bindings (prc-parms oper) args new-env num)3397 (se (prc-body oper) new-env num)))3398 (map (lambda (x) (se x env num)) (cons oper args)))))3399 ((fut? ptree) (list future-sym (se (fut-val ptree) env num)))3400 (else (compiler-internal-error "se, unknown parse tree node type"))))3401(define (se-parameters parms rest min env)3402 (define (se-parms parms rest n env)3403 (cond ((null? parms) '())3404 ((and rest (null? (cdr parms))) (cdr (assq (car parms) env)))3405 (else3406 (let ((parm (cdr (assq (car parms) env))))3407 (cons (if (> n 0) parm (list parm))3408 (se-parms (cdr parms) rest (- n 1) env))))))3409 (se-parms parms rest min env))3410(define (se-bindings vars vals env num)3411 (if (null? vars)3412 '()3413 (cons (list (cdr (assq (car vars) env)) (se (car vals) env num))3414 (se-bindings (cdr vars) (cdr vals) env num))))3415(define (se-rename vars env num)3416 (define (rename vars)3417 (if (null? vars)3418 env3419 (cons (cons (car vars)3420 (string->canonical-symbol3421 (string-append3422 (symbol->string (var-name (car vars)))3423 "#"3424 (number->string (car num)))))3425 (rename (cdr vars)))))3426 (set-car! num (+ (car num) 1))3427 (rename vars))3428(define *opnd-table* '())3429(define *opnd-table-alloc* '())3430(define opnd-table-size 10000)3431(define (enter-opnd arg1 arg2)3432 (let loop ((i 0))3433 (if (< i *opnd-table-alloc*)3434 (let ((x (vector-ref *opnd-table* i)))3435 (if (and (eqv? (car x) arg1) (eqv? (cdr x) arg2)) i (loop (+ i 1))))3436 (if (< *opnd-table-alloc* opnd-table-size)3437 (begin3438 (set! *opnd-table-alloc* (+ *opnd-table-alloc* 1))3439 (vector-set! *opnd-table* i (cons arg1 arg2))3440 i)3441 (compiler-limitation-error3442 "program is too long [virtual machine operand table overflow]")))))3443(define (contains-opnd? opnd1 opnd2)3444 (cond ((eqv? opnd1 opnd2) #t)3445 ((clo? opnd2) (contains-opnd? opnd1 (clo-base opnd2)))3446 (else #f)))3447(define (any-contains-opnd? opnd opnds)3448 (if (null? opnds)3449 #f3450 (or (contains-opnd? opnd (car opnds))3451 (any-contains-opnd? opnd (cdr opnds)))))3452(define (make-reg num) num)3453(define (reg? x) (< x 10000))3454(define (reg-num x) (modulo x 10000))3455(define (make-stk num) (+ num 10000))3456(define (stk? x) (= (quotient x 10000) 1))3457(define (stk-num x) (modulo x 10000))3458(define (make-glo name) (+ (enter-opnd name #t) 30000))3459(define (glo? x) (= (quotient x 10000) 3))3460(define (glo-name x) (car (vector-ref *opnd-table* (modulo x 10000))))3461(define (make-clo base index) (+ (enter-opnd base index) 40000))3462(define (clo? x) (= (quotient x 10000) 4))3463(define (clo-base x) (car (vector-ref *opnd-table* (modulo x 10000))))3464(define (clo-index x) (cdr (vector-ref *opnd-table* (modulo x 10000))))3465(define (make-lbl num) (+ num 20000))3466(define (lbl? x) (= (quotient x 10000) 2))3467(define (lbl-num x) (modulo x 10000))3468(define label-limit 9999)3469(define (make-obj val) (+ (enter-opnd val #f) 50000))3470(define (obj? x) (= (quotient x 10000) 5))3471(define (obj-val x) (car (vector-ref *opnd-table* (modulo x 10000))))3472(define (make-pcontext fs map) (vector fs map))3473(define (pcontext-fs x) (vector-ref x 0))3474(define (pcontext-map x) (vector-ref x 1))3475(define (make-frame size slots regs closed live)3476 (vector size slots regs closed live))3477(define (frame-size x) (vector-ref x 0))3478(define (frame-slots x) (vector-ref x 1))3479(define (frame-regs x) (vector-ref x 2))3480(define (frame-closed x) (vector-ref x 3))3481(define (frame-live x) (vector-ref x 4))3482(define (frame-eq? x y) (= (frame-size x) (frame-size y)))3483(define (frame-truncate frame nb-slots)3484 (let ((fs (frame-size frame)))3485 (make-frame3486 nb-slots3487 (nth-after (frame-slots frame) (- fs nb-slots))3488 (frame-regs frame)3489 (frame-closed frame)3490 (frame-live frame))))3491(define (frame-live? var frame)3492 (let ((live (frame-live frame)))3493 (if (eq? var closure-env-var)3494 (let ((closed (frame-closed frame)))3495 (if (or (set-member? var live)3496 (not (set-empty?3497 (set-intersection live (list->set closed)))))3498 closed3499 #f))3500 (if (set-member? var live) var #f))))3501(define (frame-first-empty-slot frame)3502 (let loop ((i 1) (s (reverse (frame-slots frame))))3503 (if (pair? s)3504 (if (frame-live? (car s) frame) (loop (+ i 1) (cdr s)) i)3505 i)))3506(define (make-proc-obj3507 name3508 primitive?3509 code3510 call-pat3511 side-effects?3512 strict-pat3513 type)3514 (let ((proc-obj3515 (vector proc-obj-tag3516 name3517 primitive?3518 code3519 call-pat3520 #f3521 #f3522 #f3523 side-effects?3524 strict-pat3525 type)))3526 (proc-obj-specialize-set! proc-obj (lambda (decls) proc-obj))3527 proc-obj))3528(define proc-obj-tag (list 'proc-obj))3529(define (proc-obj? x)3530 (and (vector? x)3531 (> (vector-length x) 0)3532 (eq? (vector-ref x 0) proc-obj-tag)))3533(define (proc-obj-name obj) (vector-ref obj 1))3534(define (proc-obj-primitive? obj) (vector-ref obj 2))3535(define (proc-obj-code obj) (vector-ref obj 3))3536(define (proc-obj-call-pat obj) (vector-ref obj 4))3537(define (proc-obj-test obj) (vector-ref obj 5))3538(define (proc-obj-inlinable obj) (vector-ref obj 6))3539(define (proc-obj-specialize obj) (vector-ref obj 7))3540(define (proc-obj-side-effects? obj) (vector-ref obj 8))3541(define (proc-obj-strict-pat obj) (vector-ref obj 9))3542(define (proc-obj-type obj) (vector-ref obj 10))3543(define (proc-obj-code-set! obj x) (vector-set! obj 3 x))3544(define (proc-obj-test-set! obj x) (vector-set! obj 5 x))3545(define (proc-obj-inlinable-set! obj x) (vector-set! obj 6 x))3546(define (proc-obj-specialize-set! obj x) (vector-set! obj 7 x))3547(define (make-pattern min-args nb-parms rest?)3548 (let loop ((x (if rest? (- nb-parms 1) (list nb-parms)))3549 (y (if rest? (- nb-parms 1) nb-parms)))3550 (let ((z (- y 1))) (if (< z min-args) x (loop (cons z x) z)))))3551(define (pattern-member? n pat)3552 (cond ((pair? pat) (if (= (car pat) n) #t (pattern-member? n (cdr pat))))3553 ((null? pat) #f)3554 (else (<= pat n))))3555(define (type-name type) (if (pair? type) (car type) type))3556(define (type-pot-fut? type) (pair? type))3557(define (make-bbs)3558 (vector (make-counter 1 label-limit bbs-limit-err) (queue-empty) '()))3559(define (bbs-limit-err)3560 (compiler-limitation-error "procedure is too long [too many labels]"))3561(define (bbs-lbl-counter bbs) (vector-ref bbs 0))3562(define (bbs-lbl-counter-set! bbs cntr) (vector-set! bbs 0 cntr))3563(define (bbs-bb-queue bbs) (vector-ref bbs 1))3564(define (bbs-bb-queue-set! bbs bbq) (vector-set! bbs 1 bbq))3565(define (bbs-entry-lbl-num bbs) (vector-ref bbs 2))3566(define (bbs-entry-lbl-num-set! bbs lbl-num) (vector-set! bbs 2 lbl-num))3567(define (bbs-new-lbl! bbs) ((bbs-lbl-counter bbs)))3568(define (lbl-num->bb lbl-num bbs)3569 (let loop ((bb-list (queue->list (bbs-bb-queue bbs))))3570 (if (= (bb-lbl-num (car bb-list)) lbl-num)3571 (car bb-list)3572 (loop (cdr bb-list)))))3573(define (make-bb label-instr bbs)3574 (let ((bb (vector label-instr (queue-empty) '() '() '())))3575 (queue-put! (vector-ref bbs 1) bb)3576 bb))3577(define (bb-lbl-num bb) (label-lbl-num (vector-ref bb 0)))3578(define (bb-label-type bb) (label-type (vector-ref bb 0)))3579(define (bb-label-instr bb) (vector-ref bb 0))3580(define (bb-label-instr-set! bb l) (vector-set! bb 0 l))3581(define (bb-non-branch-instrs bb) (queue->list (vector-ref bb 1)))3582(define (bb-non-branch-instrs-set! bb l) (vector-set! bb 1 (list->queue l)))3583(define (bb-branch-instr bb) (vector-ref bb 2))3584(define (bb-branch-instr-set! bb b) (vector-set! bb 2 b))3585(define (bb-references bb) (vector-ref bb 3))3586(define (bb-references-set! bb l) (vector-set! bb 3 l))3587(define (bb-precedents bb) (vector-ref bb 4))3588(define (bb-precedents-set! bb l) (vector-set! bb 4 l))3589(define (bb-entry-frame-size bb)3590 (frame-size (gvm-instr-frame (bb-label-instr bb))))3591(define (bb-exit-frame-size bb)3592 (frame-size (gvm-instr-frame (bb-branch-instr bb))))3593(define (bb-slots-gained bb)3594 (- (bb-exit-frame-size bb) (bb-entry-frame-size bb)))3595(define (bb-put-non-branch! bb gvm-instr)3596 (queue-put! (vector-ref bb 1) gvm-instr))3597(define (bb-put-branch! bb gvm-instr) (vector-set! bb 2 gvm-instr))3598(define (bb-add-reference! bb ref)3599 (if (not (memq ref (vector-ref bb 3)))3600 (vector-set! bb 3 (cons ref (vector-ref bb 3)))))3601(define (bb-add-precedent! bb prec)3602 (if (not (memq prec (vector-ref bb 4)))3603 (vector-set! bb 4 (cons prec (vector-ref bb 4)))))3604(define (bb-last-non-branch-instr bb)3605 (let ((non-branch-instrs (bb-non-branch-instrs bb)))3606 (if (null? non-branch-instrs)3607 (bb-label-instr bb)3608 (let loop ((l non-branch-instrs))3609 (if (pair? (cdr l)) (loop (cdr l)) (car l))))))3610(define (gvm-instr-type gvm-instr) (vector-ref gvm-instr 0))3611(define (gvm-instr-frame gvm-instr) (vector-ref gvm-instr 1))3612(define (gvm-instr-comment gvm-instr) (vector-ref gvm-instr 2))3613(define (make-label-simple lbl-num frame comment)3614 (vector 'label frame comment lbl-num 'simple))3615(define (make-label-entry lbl-num nb-parms min rest? closed? frame comment)3616 (vector 'label frame comment lbl-num 'entry nb-parms min rest? closed?))3617(define (make-label-return lbl-num frame comment)3618 (vector 'label frame comment lbl-num 'return))3619(define (make-label-task-entry lbl-num frame comment)3620 (vector 'label frame comment lbl-num 'task-entry))3621(define (make-label-task-return lbl-num frame comment)3622 (vector 'label frame comment lbl-num 'task-return))3623(define (label-lbl-num gvm-instr) (vector-ref gvm-instr 3))3624(define (label-lbl-num-set! gvm-instr n) (vector-set! gvm-instr 3 n))3625(define (label-type gvm-instr) (vector-ref gvm-instr 4))3626(define (label-entry-nb-parms gvm-instr) (vector-ref gvm-instr 5))3627(define (label-entry-min gvm-instr) (vector-ref gvm-instr 6))3628(define (label-entry-rest? gvm-instr) (vector-ref gvm-instr 7))3629(define (label-entry-closed? gvm-instr) (vector-ref gvm-instr 8))3630(define (make-apply prim opnds loc frame comment)3631 (vector 'apply frame comment prim opnds loc))3632(define (apply-prim gvm-instr) (vector-ref gvm-instr 3))3633(define (apply-opnds gvm-instr) (vector-ref gvm-instr 4))3634(define (apply-loc gvm-instr) (vector-ref gvm-instr 5))3635(define (make-copy opnd loc frame comment)3636 (vector 'copy frame comment opnd loc))3637(define (copy-opnd gvm-instr) (vector-ref gvm-instr 3))3638(define (copy-loc gvm-instr) (vector-ref gvm-instr 4))3639(define (make-close parms frame comment) (vector 'close frame comment parms))3640(define (close-parms gvm-instr) (vector-ref gvm-instr 3))3641(define (make-closure-parms loc lbl opnds) (vector loc lbl opnds))3642(define (closure-parms-loc x) (vector-ref x 0))3643(define (closure-parms-lbl x) (vector-ref x 1))3644(define (closure-parms-opnds x) (vector-ref x 2))3645(define (make-ifjump test opnds true false poll? frame comment)3646 (vector 'ifjump frame comment test opnds true false poll?))3647(define (ifjump-test gvm-instr) (vector-ref gvm-instr 3))3648(define (ifjump-opnds gvm-instr) (vector-ref gvm-instr 4))3649(define (ifjump-true gvm-instr) (vector-ref gvm-instr 5))3650(define (ifjump-false gvm-instr) (vector-ref gvm-instr 6))3651(define (ifjump-poll? gvm-instr) (vector-ref gvm-instr 7))3652(define (make-jump opnd nb-args poll? frame comment)3653 (vector 'jump frame comment opnd nb-args poll?))3654(define (jump-opnd gvm-instr) (vector-ref gvm-instr 3))3655(define (jump-nb-args gvm-instr) (vector-ref gvm-instr 4))3656(define (jump-poll? gvm-instr) (vector-ref gvm-instr 5))3657(define (first-class-jump? gvm-instr) (jump-nb-args gvm-instr))3658(define (make-comment) (cons 'comment '()))3659(define (comment-put! comment name val)3660 (set-cdr! comment (cons (cons name val) (cdr comment))))3661(define (comment-get comment name)3662 (and comment (let ((x (assq name (cdr comment)))) (if x (cdr x) #f))))3663(define (bbs-purify! bbs)3664 (let loop ()3665 (bbs-remove-jump-cascades! bbs)3666 (bbs-remove-dead-code! bbs)3667 (let* ((changed1? (bbs-remove-common-code! bbs))3668 (changed2? (bbs-remove-useless-jumps! bbs)))3669 (if (or changed1? changed2?) (loop) (bbs-order! bbs)))))3670(define (bbs-remove-jump-cascades! bbs)3671 (define (empty-bb? bb)3672 (and (eq? (bb-label-type bb) 'simple) (null? (bb-non-branch-instrs bb))))3673 (define (jump-to-non-entry-lbl? branch)3674 (and (eq? (gvm-instr-type branch) 'jump)3675 (not (first-class-jump? branch))3676 (jump-lbl? branch)))3677 (define (jump-cascade-to lbl-num fs poll? seen thunk)3678 (if (memq lbl-num seen)3679 (thunk lbl-num fs poll?)3680 (let ((bb (lbl-num->bb lbl-num bbs)))3681 (if (and (empty-bb? bb) (<= (bb-slots-gained bb) 0))3682 (let ((jump-lbl-num3683 (jump-to-non-entry-lbl? (bb-branch-instr bb))))3684 (if jump-lbl-num3685 (jump-cascade-to3686 jump-lbl-num3687 (+ fs (bb-slots-gained bb))3688 (or poll? (jump-poll? (bb-branch-instr bb)))3689 (cons lbl-num seen)3690 thunk)3691 (thunk lbl-num fs poll?)))3692 (thunk lbl-num fs poll?)))))3693 (define (equiv-lbl lbl-num seen)3694 (if (memq lbl-num seen)3695 lbl-num3696 (let ((bb (lbl-num->bb lbl-num bbs)))3697 (if (empty-bb? bb)3698 (let ((jump-lbl-num3699 (jump-to-non-entry-lbl? (bb-branch-instr bb))))3700 (if (and jump-lbl-num3701 (not (jump-poll? (bb-branch-instr bb)))3702 (= (bb-slots-gained bb) 0))3703 (equiv-lbl jump-lbl-num (cons lbl-num seen))3704 lbl-num))3705 lbl-num))))3706 (define (remove-cascade! bb)3707 (let ((branch (bb-branch-instr bb)))3708 (case (gvm-instr-type branch)3709 ((ifjump)3710 (bb-put-branch!3711 bb3712 (make-ifjump3713 (ifjump-test branch)3714 (ifjump-opnds branch)3715 (equiv-lbl (ifjump-true branch) '())3716 (equiv-lbl (ifjump-false branch) '())3717 (ifjump-poll? branch)3718 (gvm-instr-frame branch)3719 (gvm-instr-comment branch))))3720 ((jump)3721 (if (not (first-class-jump? branch))3722 (let ((dest-lbl-num (jump-lbl? branch)))3723 (if dest-lbl-num3724 (jump-cascade-to3725 dest-lbl-num3726 (frame-size (gvm-instr-frame branch))3727 (jump-poll? branch)3728 '()3729 (lambda (lbl-num fs poll?)3730 (let* ((dest-bb (lbl-num->bb lbl-num bbs))3731 (last-branch (bb-branch-instr dest-bb)))3732 (if (and (empty-bb? dest-bb)3733 (or (not poll?)3734 put-poll-on-ifjump?3735 (not (eq? (gvm-instr-type last-branch)3736 'ifjump))))3737 (let* ((new-fs (+ fs (bb-slots-gained dest-bb)))3738 (new-frame3739 (frame-truncate3740 (gvm-instr-frame branch)3741 new-fs)))3742 (define (adjust-opnd opnd)3743 (cond ((stk? opnd)3744 (make-stk3745 (+ (- fs (bb-entry-frame-size dest-bb))3746 (stk-num opnd))))3747 ((clo? opnd)3748 (make-clo3749 (adjust-opnd (clo-base opnd))3750 (clo-index opnd)))3751 (else opnd)))3752 (case (gvm-instr-type last-branch)3753 ((ifjump)3754 (bb-put-branch!3755 bb3756 (make-ifjump3757 (ifjump-test last-branch)3758 (map adjust-opnd (ifjump-opnds last-branch))3759 (equiv-lbl (ifjump-true last-branch) '())3760 (equiv-lbl (ifjump-false last-branch) '())3761 (or poll? (ifjump-poll? last-branch))3762 new-frame3763 (gvm-instr-comment last-branch))))3764 ((jump)3765 (bb-put-branch!3766 bb3767 (make-jump3768 (adjust-opnd (jump-opnd last-branch))3769 (jump-nb-args last-branch)3770 (or poll? (jump-poll? last-branch))3771 new-frame3772 (gvm-instr-comment last-branch))))3773 (else3774 (compiler-internal-error3775 "bbs-remove-jump-cascades!, unknown branch type"))))3776 (bb-put-branch!3777 bb3778 (make-jump3779 (make-lbl lbl-num)3780 (jump-nb-args branch)3781 (or poll? (jump-poll? branch))3782 (frame-truncate (gvm-instr-frame branch) fs)3783 (gvm-instr-comment branch)))))))))))3784 (else3785 (compiler-internal-error3786 "bbs-remove-jump-cascades!, unknown branch type")))))3787 (for-each remove-cascade! (queue->list (bbs-bb-queue bbs))))3788(define (jump-lbl? branch)3789 (let ((opnd (jump-opnd branch))) (if (lbl? opnd) (lbl-num opnd) #f)))3790(define put-poll-on-ifjump? #f)3791(set! put-poll-on-ifjump? #t)3792(define (bbs-remove-dead-code! bbs)3793 (let ((new-bb-queue (queue-empty)) (scan-queue (queue-empty)))3794 (define (reachable ref bb)3795 (if bb (bb-add-reference! bb ref))3796 (if (not (memq ref (queue->list new-bb-queue)))3797 (begin3798 (bb-references-set! ref '())3799 (bb-precedents-set! ref '())3800 (queue-put! new-bb-queue ref)3801 (queue-put! scan-queue ref))))3802 (define (direct-jump to-bb from-bb)3803 (reachable to-bb from-bb)3804 (bb-add-precedent! to-bb from-bb))3805 (define (scan-instr gvm-instr bb)3806 (define (scan-opnd gvm-opnd)3807 (cond ((lbl? gvm-opnd)3808 (reachable (lbl-num->bb (lbl-num gvm-opnd) bbs) bb))3809 ((clo? gvm-opnd) (scan-opnd (clo-base gvm-opnd)))))3810 (case (gvm-instr-type gvm-instr)3811 ((label) '())3812 ((apply)3813 (for-each scan-opnd (apply-opnds gvm-instr))3814 (if (apply-loc gvm-instr) (scan-opnd (apply-loc gvm-instr))))3815 ((copy)3816 (scan-opnd (copy-opnd gvm-instr))3817 (scan-opnd (copy-loc gvm-instr)))3818 ((close)3819 (for-each3820 (lambda (parm)3821 (reachable (lbl-num->bb (closure-parms-lbl parm) bbs) bb)3822 (scan-opnd (closure-parms-loc parm))3823 (for-each scan-opnd (closure-parms-opnds parm)))3824 (close-parms gvm-instr)))3825 ((ifjump)3826 (for-each scan-opnd (ifjump-opnds gvm-instr))3827 (direct-jump (lbl-num->bb (ifjump-true gvm-instr) bbs) bb)3828 (direct-jump (lbl-num->bb (ifjump-false gvm-instr) bbs) bb))3829 ((jump)3830 (let ((opnd (jump-opnd gvm-instr)))3831 (if (lbl? opnd)3832 (direct-jump (lbl-num->bb (lbl-num opnd) bbs) bb)3833 (scan-opnd (jump-opnd gvm-instr)))))3834 (else3835 (compiler-internal-error3836 "bbs-remove-dead-code!, unknown GVM instruction type"))))3837 (reachable (lbl-num->bb (bbs-entry-lbl-num bbs) bbs) #f)3838 (let loop ()3839 (if (not (queue-empty? scan-queue))3840 (let ((bb (queue-get! scan-queue)))3841 (begin3842 (scan-instr (bb-label-instr bb) bb)3843 (for-each3844 (lambda (gvm-instr) (scan-instr gvm-instr bb))3845 (bb-non-branch-instrs bb))3846 (scan-instr (bb-branch-instr bb) bb)3847 (loop)))))3848 (bbs-bb-queue-set! bbs new-bb-queue)))3849(define (bbs-remove-useless-jumps! bbs)3850 (let ((changed? #f))3851 (define (remove-useless-jump bb)3852 (let ((branch (bb-branch-instr bb)))3853 (if (and (eq? (gvm-instr-type branch) 'jump)3854 (not (first-class-jump? branch))3855 (not (jump-poll? branch))3856 (jump-lbl? branch))3857 (let* ((dest-bb (lbl-num->bb (jump-lbl? branch) bbs))3858 (frame1 (gvm-instr-frame (bb-last-non-branch-instr bb)))3859 (frame2 (gvm-instr-frame (bb-label-instr dest-bb))))3860 (if (and (eq? (bb-label-type dest-bb) 'simple)3861 (frame-eq? frame1 frame2)3862 (= (length (bb-precedents dest-bb)) 1))3863 (begin3864 (set! changed? #t)3865 (bb-non-branch-instrs-set!3866 bb3867 (append (bb-non-branch-instrs bb)3868 (bb-non-branch-instrs dest-bb)3869 '()))3870 (bb-branch-instr-set! bb (bb-branch-instr dest-bb))3871 (remove-useless-jump bb)))))))3872 (for-each remove-useless-jump (queue->list (bbs-bb-queue bbs)))3873 changed?))3874(define (bbs-remove-common-code! bbs)3875 (let* ((bb-list (queue->list (bbs-bb-queue bbs)))3876 (n (length bb-list))3877 (hash-table-length (cond ((< n 50) 43) ((< n 500) 403) (else 4003)))3878 (hash-table (make-vector hash-table-length '()))3879 (prim-table '())3880 (block-map '())3881 (changed? #f))3882 (define (hash-prim prim)3883 (let ((n (length prim-table)) (i (pos-in-list prim prim-table)))3884 (if i3885 (- n i)3886 (begin (set! prim-table (cons prim prim-table)) (+ n 1)))))3887 (define (hash-opnds l)3888 (let loop ((l l) (n 0))3889 (if (pair? l)3890 (loop (cdr l)3891 (let ((x (car l)))3892 (if (lbl? x)3893 n3894 (modulo (+ (* n 10000) x) hash-table-length))))3895 n)))3896 (define (hash-bb bb)3897 (let ((branch (bb-branch-instr bb)))3898 (modulo (case (gvm-instr-type branch)3899 ((ifjump)3900 (+ (hash-opnds (ifjump-opnds branch))3901 (* 10 (hash-prim (ifjump-test branch)))3902 (* 100 (frame-size (gvm-instr-frame branch)))))3903 ((jump)3904 (+ (hash-opnds (list (jump-opnd branch)))3905 (* 10 (or (jump-nb-args branch) -1))3906 (* 100 (frame-size (gvm-instr-frame branch)))))3907 (else 0))3908 hash-table-length)))3909 (define (replacement-lbl-num lbl)3910 (let ((x (assv lbl block-map))) (if x (cdr x) lbl)))3911 (define (fix-map! bb1 bb2)3912 (let loop ((l block-map))3913 (if (pair? l)3914 (let ((x (car l)))3915 (if (= bb1 (cdr x)) (set-cdr! x bb2))3916 (loop (cdr l))))))3917 (define (enter-bb! bb)3918 (let ((h (hash-bb bb)))3919 (vector-set! hash-table h (add-bb bb (vector-ref hash-table h)))))3920 (define (add-bb bb l)3921 (if (pair? l)3922 (let ((bb* (car l)))3923 (set! block-map3924 (cons (cons (bb-lbl-num bb) (bb-lbl-num bb*)) block-map))3925 (if (eqv-bb? bb bb*)3926 (begin3927 (fix-map! (bb-lbl-num bb) (bb-lbl-num bb*))3928 (set! changed? #t)3929 l)3930 (begin3931 (set! block-map (cdr block-map))3932 (if (eqv-gvm-instr?3933 (bb-branch-instr bb)3934 (bb-branch-instr bb*))3935 (extract-common-tail3936 bb3937 bb*3938 (lambda (head head* tail)3939 (if (null? tail)3940 (cons bb* (add-bb bb (cdr l)))3941 (let* ((lbl (bbs-new-lbl! bbs))3942 (branch (bb-branch-instr bb))3943 (fs** (need-gvm-instrs tail branch))3944 (frame (frame-truncate3945 (gvm-instr-frame3946 (if (null? head)3947 (bb-label-instr bb)3948 (car head)))3949 fs**))3950 (bb** (make-bb (make-label-simple3951 lbl3952 frame3953 #f)3954 bbs)))3955 (bb-non-branch-instrs-set! bb** tail)3956 (bb-branch-instr-set! bb** branch)3957 (bb-non-branch-instrs-set! bb* (reverse head*))3958 (bb-branch-instr-set!3959 bb*3960 (make-jump (make-lbl lbl) #f #f frame #f))3961 (bb-non-branch-instrs-set! bb (reverse head))3962 (bb-branch-instr-set!3963 bb3964 (make-jump (make-lbl lbl) #f #f frame #f))3965 (set! changed? #t)3966 (cons bb (cons bb* (add-bb bb** (cdr l))))))))3967 (cons bb* (add-bb bb (cdr l)))))))3968 (list bb)))3969 (define (extract-common-tail bb1 bb2 cont)3970 (let loop ((l1 (reverse (bb-non-branch-instrs bb1)))3971 (l2 (reverse (bb-non-branch-instrs bb2)))3972 (tail '()))3973 (if (and (pair? l1) (pair? l2))3974 (let ((i1 (car l1)) (i2 (car l2)))3975 (if (eqv-gvm-instr? i1 i2)3976 (loop (cdr l1) (cdr l2) (cons i1 tail))3977 (cont l1 l2 tail)))3978 (cont l1 l2 tail))))3979 (define (eqv-bb? bb1 bb2)3980 (let ((bb1-non-branch (bb-non-branch-instrs bb1))3981 (bb2-non-branch (bb-non-branch-instrs bb2)))3982 (and (= (length bb1-non-branch) (length bb2-non-branch))3983 (eqv-gvm-instr? (bb-label-instr bb1) (bb-label-instr bb2))3984 (eqv-gvm-instr? (bb-branch-instr bb1) (bb-branch-instr bb2))3985 (eqv-list? eqv-gvm-instr? bb1-non-branch bb2-non-branch))))3986 (define (eqv-list? pred? l1 l2)3987 (if (pair? l1)3988 (and (pair? l2)3989 (pred? (car l1) (car l2))3990 (eqv-list? pred? (cdr l1) (cdr l2)))3991 (not (pair? l2))))3992 (define (eqv-lbl-num? lbl1 lbl2)3993 (= (replacement-lbl-num lbl1) (replacement-lbl-num lbl2)))3994 (define (eqv-gvm-opnd? opnd1 opnd2)3995 (if (not opnd1)3996 (not opnd2)3997 (and opnd23998 (cond ((lbl? opnd1)3999 (and (lbl? opnd2)4000 (eqv-lbl-num? (lbl-num opnd1) (lbl-num opnd2))))4001 ((clo? opnd1)4002 (and (clo? opnd2)4003 (= (clo-index opnd1) (clo-index opnd2))4004 (eqv-gvm-opnd? (clo-base opnd1) (clo-base opnd2))))4005 (else (eqv? opnd1 opnd2))))))4006 (define (eqv-gvm-instr? instr1 instr2)4007 (define (eqv-closure-parms? p1 p2)4008 (and (eqv-gvm-opnd? (closure-parms-loc p1) (closure-parms-loc p2))4009 (eqv-lbl-num? (closure-parms-lbl p1) (closure-parms-lbl p2))4010 (eqv-list?4011 eqv-gvm-opnd?4012 (closure-parms-opnds p1)4013 (closure-parms-opnds p2))))4014 (let ((type1 (gvm-instr-type instr1)) (type2 (gvm-instr-type instr2)))4015 (and (eq? type1 type2)4016 (frame-eq? (gvm-instr-frame instr1) (gvm-instr-frame instr2))4017 (case type14018 ((label)4019 (let ((ltype1 (label-type instr1))4020 (ltype2 (label-type instr2)))4021 (and (eq? ltype1 ltype2)4022 (case ltype14023 ((simple return task-entry task-return) #t)4024 ((entry)4025 (and (= (label-entry-min instr1)4026 (label-entry-min instr2))4027 (= (label-entry-nb-parms instr1)4028 (label-entry-nb-parms instr2))4029 (eq? (label-entry-rest? instr1)4030 (label-entry-rest? instr2))4031 (eq? (label-entry-closed? instr1)4032 (label-entry-closed? instr2))))4033 (else4034 (compiler-internal-error4035 "eqv-gvm-instr?, unknown label type"))))))4036 ((apply)4037 (and (eq? (apply-prim instr1) (apply-prim instr2))4038 (eqv-list?4039 eqv-gvm-opnd?4040 (apply-opnds instr1)4041 (apply-opnds instr2))4042 (eqv-gvm-opnd? (apply-loc instr1) (apply-loc instr2))))4043 ((copy)4044 (and (eqv-gvm-opnd? (copy-opnd instr1) (copy-opnd instr2))4045 (eqv-gvm-opnd? (copy-loc instr1) (copy-loc instr2))))4046 ((close)4047 (eqv-list?4048 eqv-closure-parms?4049 (close-parms instr1)4050 (close-parms instr2)))4051 ((ifjump)4052 (and (eq? (ifjump-test instr1) (ifjump-test instr2))4053 (eqv-list?4054 eqv-gvm-opnd?4055 (ifjump-opnds instr1)4056 (ifjump-opnds instr2))4057 (eqv-lbl-num? (ifjump-true instr1) (ifjump-true instr2))4058 (eqv-lbl-num? (ifjump-false instr1) (ifjump-false instr2))4059 (eq? (ifjump-poll? instr1) (ifjump-poll? instr2))))4060 ((jump)4061 (and (eqv-gvm-opnd? (jump-opnd instr1) (jump-opnd instr2))4062 (eqv? (jump-nb-args instr1) (jump-nb-args instr2))4063 (eq? (jump-poll? instr1) (jump-poll? instr2))))4064 (else4065 (compiler-internal-error4066 "eqv-gvm-instr?, unknown 'gvm-instr':"4067 instr1))))))4068 (define (update-bb! bb) (replace-label-references! bb replacement-lbl-num))4069 (for-each enter-bb! bb-list)4070 (bbs-entry-lbl-num-set! bbs (replacement-lbl-num (bbs-entry-lbl-num bbs)))4071 (let loop ((i 0) (result '()))4072 (if (< i hash-table-length)4073 (let ((bb-kept (vector-ref hash-table i)))4074 (for-each update-bb! bb-kept)4075 (loop (+ i 1) (append bb-kept result)))4076 (bbs-bb-queue-set! bbs (list->queue result))))4077 changed?))4078(define (replace-label-references! bb replacement-lbl-num)4079 (define (update-gvm-opnd opnd)4080 (if opnd4081 (cond ((lbl? opnd) (make-lbl (replacement-lbl-num (lbl-num opnd))))4082 ((clo? opnd)4083 (make-clo (update-gvm-opnd (clo-base opnd)) (clo-index opnd)))4084 (else opnd))4085 opnd))4086 (define (update-gvm-instr instr)4087 (define (update-closure-parms p)4088 (make-closure-parms4089 (update-gvm-opnd (closure-parms-loc p))4090 (replacement-lbl-num (closure-parms-lbl p))4091 (map update-gvm-opnd (closure-parms-opnds p))))4092 (case (gvm-instr-type instr)4093 ((apply)4094 (make-apply4095 (apply-prim instr)4096 (map update-gvm-opnd (apply-opnds instr))4097 (update-gvm-opnd (apply-loc instr))4098 (gvm-instr-frame instr)4099 (gvm-instr-comment instr)))4100 ((copy)4101 (make-copy4102 (update-gvm-opnd (copy-opnd instr))4103 (update-gvm-opnd (copy-loc instr))4104 (gvm-instr-frame instr)4105 (gvm-instr-comment instr)))4106 ((close)4107 (make-close4108 (map update-closure-parms (close-parms instr))4109 (gvm-instr-frame instr)4110 (gvm-instr-comment instr)))4111 ((ifjump)4112 (make-ifjump4113 (ifjump-test instr)4114 (map update-gvm-opnd (ifjump-opnds instr))4115 (replacement-lbl-num (ifjump-true instr))4116 (replacement-lbl-num (ifjump-false instr))4117 (ifjump-poll? instr)4118 (gvm-instr-frame instr)4119 (gvm-instr-comment instr)))4120 ((jump)4121 (make-jump4122 (update-gvm-opnd (jump-opnd instr))4123 (jump-nb-args instr)4124 (jump-poll? instr)4125 (gvm-instr-frame instr)4126 (gvm-instr-comment instr)))4127 (else4128 (compiler-internal-error "update-gvm-instr, unknown 'instr':" instr))))4129 (bb-non-branch-instrs-set!4130 bb4131 (map update-gvm-instr (bb-non-branch-instrs bb)))4132 (bb-branch-instr-set! bb (update-gvm-instr (bb-branch-instr bb))))4133(define (bbs-order! bbs)4134 (let ((new-bb-queue (queue-empty))4135 (left-to-schedule (queue->list (bbs-bb-queue bbs))))4136 (define (remove x l)4137 (if (eq? (car l) x) (cdr l) (cons (car l) (remove x (cdr l)))))4138 (define (remove-bb! bb)4139 (set! left-to-schedule (remove bb left-to-schedule))4140 bb)4141 (define (prec-bb bb)4142 (let loop ((l (bb-precedents bb)) (best #f) (best-fs #f))4143 (if (null? l)4144 best4145 (let* ((x (car l)) (x-fs (bb-exit-frame-size x)))4146 (if (and (memq x left-to-schedule)4147 (or (not best) (< x-fs best-fs)))4148 (loop (cdr l) x x-fs)4149 (loop (cdr l) best best-fs))))))4150 (define (succ-bb bb)4151 (define (branches-to-lbl? bb)4152 (let ((branch (bb-branch-instr bb)))4153 (case (gvm-instr-type branch)4154 ((ifjump) #t)4155 ((jump) (lbl? (jump-opnd branch)))4156 (else4157 (compiler-internal-error "bbs-order!, unknown branch type")))))4158 (define (best-succ bb1 bb2)4159 (if (branches-to-lbl? bb1)4160 bb14161 (if (branches-to-lbl? bb2)4162 bb24163 (if (< (bb-exit-frame-size bb1) (bb-exit-frame-size bb2))4164 bb24165 bb1))))4166 (let ((branch (bb-branch-instr bb)))4167 (case (gvm-instr-type branch)4168 ((ifjump)4169 (let* ((true-bb (lbl-num->bb (ifjump-true branch) bbs))4170 (true-bb* (and (memq true-bb left-to-schedule) true-bb))4171 (false-bb (lbl-num->bb (ifjump-false branch) bbs))4172 (false-bb* (and (memq false-bb left-to-schedule) false-bb)))4173 (if (and true-bb* false-bb*)4174 (best-succ true-bb* false-bb*)4175 (or true-bb* false-bb*))))4176 ((jump)4177 (let ((opnd (jump-opnd branch)))4178 (and (lbl? opnd)4179 (let ((bb (lbl-num->bb (lbl-num opnd) bbs)))4180 (and (memq bb left-to-schedule) bb)))))4181 (else (compiler-internal-error "bbs-order!, unknown branch type")))))4182 (define (schedule-from bb)4183 (queue-put! new-bb-queue bb)4184 (let ((x (succ-bb bb)))4185 (if x4186 (begin4187 (schedule-around (remove-bb! x))4188 (let ((y (succ-bb bb)))4189 (if y (schedule-around (remove-bb! y)))))))4190 (schedule-refs bb))4191 (define (schedule-around bb)4192 (let ((x (prec-bb bb)))4193 (if x4194 (let ((bb-list (schedule-back (remove-bb! x) '())))4195 (queue-put! new-bb-queue x)4196 (schedule-forw bb)4197 (for-each schedule-refs bb-list))4198 (schedule-from bb))))4199 (define (schedule-back bb bb-list)4200 (let ((bb-list* (cons bb bb-list)) (x (prec-bb bb)))4201 (if x4202 (let ((bb-list (schedule-back (remove-bb! x) bb-list*)))4203 (queue-put! new-bb-queue x)4204 bb-list)4205 bb-list*)))4206 (define (schedule-forw bb)4207 (queue-put! new-bb-queue bb)4208 (let ((x (succ-bb bb)))4209 (if x4210 (begin4211 (schedule-forw (remove-bb! x))4212 (let ((y (succ-bb bb)))4213 (if y (schedule-around (remove-bb! y)))))))4214 (schedule-refs bb))4215 (define (schedule-refs bb)4216 (for-each4217 (lambda (x)4218 (if (memq x left-to-schedule) (schedule-around (remove-bb! x))))4219 (bb-references bb)))4220 (schedule-from (remove-bb! (lbl-num->bb (bbs-entry-lbl-num bbs) bbs)))4221 (bbs-bb-queue-set! bbs new-bb-queue)4222 (let ((bb-list (queue->list new-bb-queue)))4223 (let loop ((l bb-list) (i 1) (lbl-map '()))4224 (if (pair? l)4225 (let* ((label-instr (bb-label-instr (car l)))4226 (old-lbl-num (label-lbl-num label-instr)))4227 (label-lbl-num-set! label-instr i)4228 (loop (cdr l) (+ i 1) (cons (cons old-lbl-num i) lbl-map)))4229 (let ()4230 (define (replacement-lbl-num x) (cdr (assv x lbl-map)))4231 (define (update-bb! bb)4232 (replace-label-references! bb replacement-lbl-num))4233 (for-each update-bb! bb-list)4234 (bbs-lbl-counter-set!4235 bbs4236 (make-counter4237 (* (+ 1 (quotient (bbs-new-lbl! bbs) 1000)) 1000)4238 label-limit4239 bbs-limit-err))))))))4240(define (make-code bb gvm-instr sn) (vector bb gvm-instr sn))4241(define (code-bb code) (vector-ref code 0))4242(define (code-gvm-instr code) (vector-ref code 1))4243(define (code-slots-needed code) (vector-ref code 2))4244(define (code-slots-needed-set! code n) (vector-set! code 2 n))4245(define (bbs->code-list bbs)4246 (let ((code-list (linearize bbs)))4247 (setup-slots-needed! code-list)4248 code-list))4249(define (linearize bbs)4250 (let ((code-queue (queue-empty)))4251 (define (put-bb bb)4252 (define (put-instr gvm-instr)4253 (queue-put! code-queue (make-code bb gvm-instr #f)))4254 (put-instr (bb-label-instr bb))4255 (for-each put-instr (bb-non-branch-instrs bb))4256 (put-instr (bb-branch-instr bb)))4257 (for-each put-bb (queue->list (bbs-bb-queue bbs)))4258 (queue->list code-queue)))4259(define (setup-slots-needed! code-list)4260 (if (null? code-list)4261 #f4262 (let* ((code (car code-list))4263 (gvm-instr (code-gvm-instr code))4264 (sn-rest (setup-slots-needed! (cdr code-list))))4265 (case (gvm-instr-type gvm-instr)4266 ((label)4267 (if (> sn-rest (frame-size (gvm-instr-frame gvm-instr)))4268 (compiler-internal-error4269 "setup-slots-needed!, incoherent slots needed for LABEL"))4270 (code-slots-needed-set! code sn-rest)4271 #f)4272 ((ifjump jump)4273 (let ((sn (frame-size (gvm-instr-frame gvm-instr))))4274 (code-slots-needed-set! code sn)4275 (need-gvm-instr gvm-instr sn)))4276 (else4277 (code-slots-needed-set! code sn-rest)4278 (need-gvm-instr gvm-instr sn-rest))))))4279(define (need-gvm-instrs non-branch branch)4280 (if (pair? non-branch)4281 (need-gvm-instr4282 (car non-branch)4283 (need-gvm-instrs (cdr non-branch) branch))4284 (need-gvm-instr branch (frame-size (gvm-instr-frame branch)))))4285(define (need-gvm-instr gvm-instr sn-rest)4286 (case (gvm-instr-type gvm-instr)4287 ((label) sn-rest)4288 ((apply)4289 (let ((loc (apply-loc gvm-instr)))4290 (need-gvm-opnds4291 (apply-opnds gvm-instr)4292 (need-gvm-loc-opnd loc (need-gvm-loc loc sn-rest)))))4293 ((copy)4294 (let ((loc (copy-loc gvm-instr)))4295 (need-gvm-opnd4296 (copy-opnd gvm-instr)4297 (need-gvm-loc-opnd loc (need-gvm-loc loc sn-rest)))))4298 ((close)4299 (let ((parms (close-parms gvm-instr)))4300 (define (need-parms-opnds p)4301 (if (null? p)4302 sn-rest4303 (need-gvm-opnds4304 (closure-parms-opnds (car p))4305 (need-parms-opnds (cdr p)))))4306 (define (need-parms-loc p)4307 (if (null? p)4308 (need-parms-opnds parms)4309 (let ((loc (closure-parms-loc (car p))))4310 (need-gvm-loc-opnd4311 loc4312 (need-gvm-loc loc (need-parms-loc (cdr p)))))))4313 (need-parms-loc parms)))4314 ((ifjump) (need-gvm-opnds (ifjump-opnds gvm-instr) sn-rest))4315 ((jump) (need-gvm-opnd (jump-opnd gvm-instr) sn-rest))4316 (else4317 (compiler-internal-error4318 "need-gvm-instr, unknown 'gvm-instr':"4319 gvm-instr))))4320(define (need-gvm-loc loc sn-rest)4321 (if (and loc (stk? loc) (>= (stk-num loc) sn-rest))4322 (- (stk-num loc) 1)4323 sn-rest))4324(define (need-gvm-loc-opnd gvm-loc slots-needed)4325 (if (and gvm-loc (clo? gvm-loc))4326 (need-gvm-opnd (clo-base gvm-loc) slots-needed)4327 slots-needed))4328(define (need-gvm-opnd gvm-opnd slots-needed)4329 (cond ((stk? gvm-opnd) (max (stk-num gvm-opnd) slots-needed))4330 ((clo? gvm-opnd) (need-gvm-opnd (clo-base gvm-opnd) slots-needed))4331 (else slots-needed)))4332(define (need-gvm-opnds gvm-opnds slots-needed)4333 (if (null? gvm-opnds)4334 slots-needed4335 (need-gvm-opnd4336 (car gvm-opnds)4337 (need-gvm-opnds (cdr gvm-opnds) slots-needed))))4338(define (write-bb bb port)4339 (write-gvm-instr (bb-label-instr bb) port)4340 (display " [precedents=" port)4341 (write (map bb-lbl-num (bb-precedents bb)) port)4342 (display "]" port)4343 (newline port)4344 (for-each4345 (lambda (x) (write-gvm-instr x port) (newline port))4346 (bb-non-branch-instrs bb))4347 (write-gvm-instr (bb-branch-instr bb) port))4348(define (write-bbs bbs port)4349 (for-each4350 (lambda (bb)4351 (if (= (bb-lbl-num bb) (bbs-entry-lbl-num bbs))4352 (begin (display "**** Entry block:" port) (newline port)))4353 (write-bb bb port)4354 (newline port))4355 (queue->list (bbs-bb-queue bbs))))4356(define (virtual.dump proc port)4357 (let ((proc-seen (queue-empty)) (proc-left (queue-empty)))4358 (define (scan-opnd gvm-opnd)4359 (cond ((obj? gvm-opnd)4360 (let ((val (obj-val gvm-opnd)))4361 (if (and (proc-obj? val)4362 (proc-obj-code val)4363 (not (memq val (queue->list proc-seen))))4364 (begin4365 (queue-put! proc-seen val)4366 (queue-put! proc-left val)))))4367 ((clo? gvm-opnd) (scan-opnd (clo-base gvm-opnd)))))4368 (define (dump-proc p)4369 (define (scan-code code)4370 (let ((gvm-instr (code-gvm-instr code)))4371 (write-gvm-instr gvm-instr port)4372 (newline port)4373 (case (gvm-instr-type gvm-instr)4374 ((apply)4375 (for-each scan-opnd (apply-opnds gvm-instr))4376 (if (apply-loc gvm-instr) (scan-opnd (apply-loc gvm-instr))))4377 ((copy)4378 (scan-opnd (copy-opnd gvm-instr))4379 (scan-opnd (copy-loc gvm-instr)))4380 ((close)4381 (for-each4382 (lambda (parms)4383 (scan-opnd (closure-parms-loc parms))4384 (for-each scan-opnd (closure-parms-opnds parms)))4385 (close-parms gvm-instr)))4386 ((ifjump) (for-each scan-opnd (ifjump-opnds gvm-instr)))4387 ((jump) (scan-opnd (jump-opnd gvm-instr)))4388 (else '()))))4389 (if (proc-obj-primitive? p)4390 (display "**** #[primitive " port)4391 (display "**** #[procedure " port))4392 (display (proc-obj-name p) port)4393 (display "] =" port)4394 (newline port)4395 (let loop ((l (bbs->code-list (proc-obj-code p)))4396 (prev-filename "")4397 (prev-line 0))4398 (if (pair? l)4399 (let* ((code (car l))4400 (instr (code-gvm-instr code))4401 (src (comment-get (gvm-instr-comment instr) 'source))4402 (loc (and src (source-locat src)))4403 (filename4404 (if (and loc (eq? (vector-ref loc 0) 'file))4405 (vector-ref loc 1)4406 prev-filename))4407 (line (if (and loc (eq? (vector-ref loc 0) 'file))4408 (vector-ref loc 3)4409 prev-line)))4410 (if (or (not (string=? filename prev-filename))4411 (not (= line prev-line)))4412 (begin4413 (display "#line " port)4414 (display line port)4415 (if (not (string=? filename prev-filename))4416 (begin (display " " port) (write filename port)))4417 (newline port)))4418 (scan-code code)4419 (loop (cdr l) filename line))4420 (newline port))))4421 (scan-opnd (make-obj proc))4422 (let loop ()4423 (if (not (queue-empty? proc-left))4424 (begin (dump-proc (queue-get! proc-left)) (loop))))))4425(define (write-gvm-instr gvm-instr port)4426 (define (write-closure-parms parms)4427 (display " " port)4428 (let ((len (+ 1 (write-gvm-opnd (closure-parms-loc parms) port))))4429 (display " = (" port)4430 (let ((len (+ len (+ 4 (write-gvm-lbl (closure-parms-lbl parms) port)))))4431 (+ len4432 (write-terminated-opnd-list (closure-parms-opnds parms) port)))))4433 (define (write-terminated-opnd-list l port)4434 (let loop ((l l) (len 0))4435 (if (pair? l)4436 (let ((opnd (car l)))4437 (display " " port)4438 (loop (cdr l) (+ len (+ 1 (write-gvm-opnd opnd port)))))4439 (begin (display ")" port) (+ len 1)))))4440 (define (write-param-pattern gvm-instr port)4441 (let ((len (if (not (= (label-entry-min gvm-instr)4442 (label-entry-nb-parms gvm-instr)))4443 (let ((len (write-returning-len4444 (label-entry-min gvm-instr)4445 port)))4446 (display "-" port)4447 (+ len 1))4448 0)))4449 (let ((len (+ len4450 (write-returning-len4451 (label-entry-nb-parms gvm-instr)4452 port))))4453 (if (label-entry-rest? gvm-instr)4454 (begin (display "+" port) (+ len 1))4455 len))))4456 (define (write-prim-applic prim opnds port)4457 (display "(" port)4458 (let ((len (+ 1 (display-returning-len (proc-obj-name prim) port))))4459 (+ len (write-terminated-opnd-list opnds port))))4460 (define (write-instr gvm-instr)4461 (case (gvm-instr-type gvm-instr)4462 ((label)4463 (let ((len (write-gvm-lbl (label-lbl-num gvm-instr) port)))4464 (display " " port)4465 (let ((len (+ len4466 (+ 14467 (write-returning-len4468 (frame-size (gvm-instr-frame gvm-instr))4469 port)))))4470 (case (label-type gvm-instr)4471 ((simple) len)4472 ((entry)4473 (if (label-entry-closed? gvm-instr)4474 (begin4475 (display " closure-entry-point " port)4476 (+ len (+ 21 (write-param-pattern gvm-instr port))))4477 (begin4478 (display " entry-point " port)4479 (+ len (+ 13 (write-param-pattern gvm-instr port))))))4480 ((return) (display " return-point" port) (+ len 13))4481 ((task-entry) (display " task-entry-point" port) (+ len 17))4482 ((task-return) (display " task-return-point" port) (+ len 18))4483 (else4484 (compiler-internal-error4485 "write-gvm-instr, unknown label type"))))))4486 ((apply)4487 (display " " port)4488 (let ((len (+ 24489 (if (apply-loc gvm-instr)4490 (let ((len (write-gvm-opnd4491 (apply-loc gvm-instr)4492 port)))4493 (display " = " port)4494 (+ len 3))4495 0))))4496 (+ len4497 (write-prim-applic4498 (apply-prim gvm-instr)4499 (apply-opnds gvm-instr)4500 port))))4501 ((copy)4502 (display " " port)4503 (let ((len (+ 2 (write-gvm-opnd (copy-loc gvm-instr) port))))4504 (display " = " port)4505 (+ len (+ 3 (write-gvm-opnd (copy-opnd gvm-instr) port)))))4506 ((close)4507 (display " close" port)4508 (let ((len (+ 7 (write-closure-parms (car (close-parms gvm-instr))))))4509 (let loop ((l (cdr (close-parms gvm-instr))) (len len))4510 (if (pair? l)4511 (let ((x (car l)))4512 (display "," port)4513 (loop (cdr l) (+ len (+ 1 (write-closure-parms x)))))4514 len))))4515 ((ifjump)4516 (display " if " port)4517 (let ((len (+ 54518 (write-prim-applic4519 (ifjump-test gvm-instr)4520 (ifjump-opnds gvm-instr)4521 port))))4522 (let ((len (+ len4523 (if (ifjump-poll? gvm-instr)4524 (begin (display " jump* " port) 7)4525 (begin (display " jump " port) 6)))))4526 (let ((len (+ len4527 (write-returning-len4528 (frame-size (gvm-instr-frame gvm-instr))4529 port))))4530 (display " " port)4531 (let ((len (+ len4532 (+ 14533 (write-gvm-lbl (ifjump-true gvm-instr) port)))))4534 (display " else " port)4535 (+ len (+ 6 (write-gvm-lbl (ifjump-false gvm-instr) port))))))))4536 ((jump)4537 (display " " port)4538 (let ((len (+ 24539 (if (jump-poll? gvm-instr)4540 (begin (display "jump* " port) 6)4541 (begin (display "jump " port) 5)))))4542 (let ((len (+ len4543 (write-returning-len4544 (frame-size (gvm-instr-frame gvm-instr))4545 port))))4546 (display " " port)4547 (let ((len (+ len4548 (+ 1 (write-gvm-opnd (jump-opnd gvm-instr) port)))))4549 (+ len4550 (if (jump-nb-args gvm-instr)4551 (begin4552 (display " " port)4553 (+ 14554 (write-returning-len (jump-nb-args gvm-instr) port)))4555 0))))))4556 (else4557 (compiler-internal-error4558 "write-gvm-instr, unknown 'gvm-instr':"4559 gvm-instr))))4560 (define (spaces n)4561 (if (> n 0)4562 (if (> n 7)4563 (begin (display " " port) (spaces (- n 8)))4564 (begin (display " " port) (spaces (- n 1))))))4565 (let ((len (write-instr gvm-instr)))4566 (spaces (- 40 len))4567 (display " " port)4568 (write-frame (gvm-instr-frame gvm-instr) port))4569 (let ((x (gvm-instr-comment gvm-instr)))4570 (if x4571 (let ((y (comment-get x 'text)))4572 (if y (begin (display " ; " port) (display y port)))))))4573(define (write-frame frame port)4574 (define (write-var var opnd sep)4575 (display sep port)4576 (write-gvm-opnd opnd port)4577 (if var4578 (begin4579 (display "=" port)4580 (cond ((eq? var closure-env-var)4581 (write (map (lambda (var) (var-name var))4582 (frame-closed frame))4583 port))4584 ((eq? var ret-var) (display "#" port))4585 ((temp-var? var) (display "." port))4586 (else (write (var-name var) port))))))4587 (define (live? var)4588 (let ((live (frame-live frame)))4589 (or (set-member? var live)4590 (and (eq? var closure-env-var)4591 (not (set-empty?4592 (set-intersection4593 live4594 (list->set (frame-closed frame)))))))))4595 (let loop1 ((i 1) (l (reverse (frame-slots frame))) (sep "; "))4596 (if (pair? l)4597 (let ((var (car l)))4598 (write-var (if (live? var) var #f) (make-stk i) sep)4599 (loop1 (+ i 1) (cdr l) " "))4600 (let loop2 ((i 0) (l (frame-regs frame)) (sep sep))4601 (if (pair? l)4602 (let ((var (car l)))4603 (if (live? var)4604 (begin4605 (write-var var (make-reg i) sep)4606 (loop2 (+ i 1) (cdr l) " "))4607 (loop2 (+ i 1) (cdr l) sep))))))))4608(define (write-gvm-opnd gvm-opnd port)4609 (define (write-opnd)4610 (cond ((reg? gvm-opnd)4611 (display "+" port)4612 (+ 1 (write-returning-len (reg-num gvm-opnd) port)))4613 ((stk? gvm-opnd)4614 (display "-" port)4615 (+ 1 (write-returning-len (stk-num gvm-opnd) port)))4616 ((glo? gvm-opnd) (write-returning-len (glo-name gvm-opnd) port))4617 ((clo? gvm-opnd)4618 (let ((len (write-gvm-opnd (clo-base gvm-opnd) port)))4619 (display "(" port)4620 (let ((len (+ len4621 (+ 14622 (write-returning-len4623 (clo-index gvm-opnd)4624 port)))))4625 (display ")" port)4626 (+ len 1))))4627 ((lbl? gvm-opnd) (write-gvm-lbl (lbl-num gvm-opnd) port))4628 ((obj? gvm-opnd)4629 (display "'" port)4630 (+ (write-gvm-obj (obj-val gvm-opnd) port) 1))4631 (else4632 (compiler-internal-error4633 "write-gvm-opnd, unknown 'gvm-opnd':"4634 gvm-opnd))))4635 (write-opnd))4636(define (write-gvm-lbl lbl port)4637 (display "#" port)4638 (+ (write-returning-len lbl port) 1))4639(define (write-gvm-obj val port)4640 (cond ((false-object? val) (display "#f" port) 2)4641 ((undef-object? val) (display "#[undefined]" port) 12)4642 ((proc-obj? val)4643 (if (proc-obj-primitive? val)4644 (display "#[primitive " port)4645 (display "#[procedure " port))4646 (let ((len (display-returning-len (proc-obj-name val) port)))4647 (display "]" port)4648 (+ len 13)))4649 (else (write-returning-len val port))))4650(define (virtual.begin!)4651 (set! *opnd-table* (make-vector opnd-table-size))4652 (set! *opnd-table-alloc* 0)4653 '())4654(define (virtual.end!) (set! *opnd-table* '()) '())4655(define (make-target version name)4656 (define current-target-version 4)4657 (if (not (= version current-target-version))4658 (compiler-internal-error4659 "make-target, version of target package is not current"4660 name))4661 (let ((x (make-vector 11))) (vector-set! x 1 name) x))4662(define (target-name x) (vector-ref x 1))4663(define (target-begin! x) (vector-ref x 2))4664(define (target-begin!-set! x y) (vector-set! x 2 y))4665(define (target-end! x) (vector-ref x 3))4666(define (target-end!-set! x y) (vector-set! x 3 y))4667(define (target-dump x) (vector-ref x 4))4668(define (target-dump-set! x y) (vector-set! x 4 y))4669(define (target-nb-regs x) (vector-ref x 5))4670(define (target-nb-regs-set! x y) (vector-set! x 5 y))4671(define (target-prim-info x) (vector-ref x 6))4672(define (target-prim-info-set! x y) (vector-set! x 6 y))4673(define (target-label-info x) (vector-ref x 7))4674(define (target-label-info-set! x y) (vector-set! x 7 y))4675(define (target-jump-info x) (vector-ref x 8))4676(define (target-jump-info-set! x y) (vector-set! x 8 y))4677(define (target-proc-result x) (vector-ref x 9))4678(define (target-proc-result-set! x y) (vector-set! x 9 y))4679(define (target-task-return x) (vector-ref x 10))4680(define (target-task-return-set! x y) (vector-set! x 10 y))4681(define targets-loaded '())4682(define (get-target name)4683 (let ((x (assq name targets-loaded)))4684 (if x (cdr x) (compiler-error "Target package is not available" name))))4685(define (put-target targ)4686 (let* ((name (target-name targ)) (x (assq name targets-loaded)))4687 (if x4688 (set-cdr! x targ)4689 (set! targets-loaded (cons (cons name targ) targets-loaded)))4690 '()))4691(define (default-target)4692 (if (null? targets-loaded)4693 (compiler-error "No target package is available")4694 (car (car targets-loaded))))4695(define (select-target! name info-port)4696 (set! target (get-target name))4697 ((target-begin! target) info-port)4698 (set! target.dump (target-dump target))4699 (set! target.nb-regs (target-nb-regs target))4700 (set! target.prim-info (target-prim-info target))4701 (set! target.label-info (target-label-info target))4702 (set! target.jump-info (target-jump-info target))4703 (set! target.proc-result (target-proc-result target))4704 (set! target.task-return (target-task-return target))4705 (set! **not-proc-obj (target.prim-info **not-sym))4706 '())4707(define (unselect-target!) ((target-end! target)) '())4708(define target '())4709(define target.dump '())4710(define target.nb-regs '())4711(define target.prim-info '())4712(define target.label-info '())4713(define target.jump-info '())4714(define target.proc-result '())4715(define target.task-return '())4716(define **not-proc-obj '())4717(define (target.specialized-prim-info* name decl)4718 (let ((x (target.prim-info* name decl)))4719 (and x ((proc-obj-specialize x) decl))))4720(define (target.prim-info* name decl)4721 (and (if (standard-procedure name decl)4722 (standard-binding? name decl)4723 (extended-binding? name decl))4724 (target.prim-info name)))4725(define generic-sym (string->canonical-symbol "GENERIC"))4726(define fixnum-sym (string->canonical-symbol "FIXNUM"))4727(define flonum-sym (string->canonical-symbol "FLONUM"))4728(define-namable-decl generic-sym 'arith)4729(define-namable-decl fixnum-sym 'arith)4730(define-namable-decl flonum-sym 'arith)4731(define (arith-implementation name decls)4732 (declaration-value 'arith name generic-sym decls))4733(define (cf source target-name . opts)4734 (let* ((dest (file-root source))4735 (module-name (file-name dest))4736 (info-port (if (memq 'verbose opts) (current-output-port) #f))4737 (result (compile-program4738 (list **include-sym source)4739 (if target-name target-name (default-target))4740 opts4741 module-name4742 dest4743 info-port)))4744 (if (and info-port (not (eq? info-port (current-output-port))))4745 (close-output-port info-port))4746 result))4747(define (ce source target-name . opts)4748 (let* ((dest "program")4749 (module-name "program")4750 (info-port (if (memq 'verbose opts) (current-output-port) #f))4751 (result (compile-program4752 source4753 (if target-name target-name (default-target))4754 opts4755 module-name4756 dest4757 info-port)))4758 (if (and info-port (not (eq? info-port (current-output-port))))4759 (close-output-port info-port))4760 result))4761(define wrap-program #f)4762(set! wrap-program (lambda (program) program))4763(define (compile-program program target-name opts module-name dest info-port)4764 (define (compiler-body)4765 (if (not (valid-module-name? module-name))4766 (compiler-error4767 "Invalid characters in file name (must be a symbol with no \"#\")")4768 (begin4769 (ptree.begin! info-port)4770 (virtual.begin!)4771 (select-target! target-name info-port)4772 (parse-program4773 (list (expression->source (wrap-program program) #f))4774 (make-global-environment)4775 module-name4776 (lambda (lst env c-intf)4777 (let ((parsed-program4778 (map (lambda (x) (normalize-parse-tree (car x) (cdr x)))4779 lst)))4780 (if (memq 'expansion opts)4781 (let ((port (current-output-port)))4782 (display "Expansion:" port)4783 (newline port)4784 (let loop ((l parsed-program))4785 (if (pair? l)4786 (let ((ptree (car l)))4787 (pp-expression4788 (parse-tree->expression ptree)4789 port)4790 (loop (cdr l)))))4791 (newline port)))4792 (let ((module-init-proc4793 (compile-parsed-program4794 module-name4795 parsed-program4796 env4797 c-intf4798 info-port)))4799 (if (memq 'report opts) (generate-report env))4800 (if (memq 'gvm opts)4801 (let ((gvm-port4802 (open-output-file (string-append dest ".gvm"))))4803 (virtual.dump module-init-proc gvm-port)4804 (close-output-port gvm-port)))4805 (target.dump module-init-proc dest c-intf opts)4806 (dump-c-intf module-init-proc dest c-intf)))))4807 (unselect-target!)4808 (virtual.end!)4809 (ptree.end!)4810 #t)))4811 (let ((successful (with-exception-handling compiler-body)))4812 (if info-port4813 (if successful4814 (begin4815 (display "Compilation finished." info-port)4816 (newline info-port))4817 (begin4818 (display "Compilation terminated abnormally." info-port)4819 (newline info-port))))4820 successful))4821(define (valid-module-name? module-name)4822 (define (valid-char? c)4823 (and (not (memv c4824 '(#\#4825 #\;4826 #\(4827 #\)4828 #\space4829 #\[4830 #\]4831 #\{4832 #\}4833 #\"4834 #\'4835 #\`4836 #\,)))4837 (not (char-whitespace? c))))4838 (let ((n (string-length module-name)))4839 (and (> n 0)4840 (not (string=? module-name "."))4841 (not (string->number module-name 10))4842 (let loop ((i 0))4843 (if (< i n)4844 (if (valid-char? (string-ref module-name i)) (loop (+ i 1)) #f)4845 #t)))))4846(define (dump-c-intf module-init-proc dest c-intf)4847 (let ((decls (c-intf-decls c-intf))4848 (procs (c-intf-procs c-intf))4849 (inits (c-intf-inits c-intf)))4850 (if (or (not (null? decls)) (not (null? procs)) (not (null? inits)))4851 (let* ((module-name (proc-obj-name module-init-proc))4852 (filename (string-append dest ".c"))4853 (port (open-output-file filename)))4854 (display "/* File: \"" port)4855 (display filename port)4856 (display "\", C-interface file produced by Gambit " port)4857 (display compiler-version port)4858 (display " */" port)4859 (newline port)4860 (display "#define " port)4861 (display c-id-prefix port)4862 (display "MODULE_NAME \"" port)4863 (display module-name port)4864 (display "\"" port)4865 (newline port)4866 (display "#define " port)4867 (display c-id-prefix port)4868 (display "MODULE_LINKER " port)4869 (display c-id-prefix port)4870 (display (scheme-id->c-id module-name) port)4871 (newline port)4872 (display "#define " port)4873 (display c-id-prefix port)4874 (display "VERSION \"" port)4875 (display compiler-version port)4876 (display "\"" port)4877 (newline port)4878 (if (not (null? procs))4879 (begin4880 (display "#define " port)4881 (display c-id-prefix port)4882 (display "C_PRC_COUNT " port)4883 (display (length procs) port)4884 (newline port)))4885 (display "#include \"gambit.h\"" port)4886 (newline port)4887 (display c-id-prefix port)4888 (display "BEGIN_MODULE" port)4889 (newline port)4890 (for-each4891 (lambda (x)4892 (let ((scheme-name (vector-ref x 0)))4893 (display c-id-prefix port)4894 (display "SUPPLY_PRM(" port)4895 (display c-id-prefix port)4896 (display "P_" port)4897 (display (scheme-id->c-id scheme-name) port)4898 (display ")" port)4899 (newline port)))4900 procs)4901 (newline port)4902 (for-each (lambda (x) (display x port) (newline port)) decls)4903 (if (not (null? procs))4904 (begin4905 (for-each4906 (lambda (x)4907 (let ((scheme-name (vector-ref x 0))4908 (c-name (vector-ref x 1))4909 (arity (vector-ref x 2))4910 (def (vector-ref x 3)))4911 (display c-id-prefix port)4912 (display "BEGIN_C_COD(" port)4913 (display c-name port)4914 (display "," port)4915 (display c-id-prefix port)4916 (display "P_" port)4917 (display (scheme-id->c-id scheme-name) port)4918 (display "," port)4919 (display arity port)4920 (display ")" port)4921 (newline port)4922 (display "#undef ___ARG1" port)4923 (newline port)4924 (display "#define ___ARG1 ___R1" port)4925 (newline port)4926 (display "#undef ___ARG2" port)4927 (newline port)4928 (display "#define ___ARG2 ___R2" port)4929 (newline port)4930 (display "#undef ___ARG3" port)4931 (newline port)4932 (display "#define ___ARG3 ___R3" port)4933 (newline port)4934 (display "#undef ___RESULT" port)4935 (newline port)4936 (display "#define ___RESULT ___R1" port)4937 (newline port)4938 (display def port)4939 (display c-id-prefix port)4940 (display "END_C_COD" port)4941 (newline port)))4942 procs)4943 (newline port)4944 (display c-id-prefix port)4945 (display "BEGIN_C_PRC" port)4946 (newline port)4947 (let loop ((i 0) (lst procs))4948 (if (not (null? lst))4949 (let* ((x (car lst))4950 (scheme-name (vector-ref x 0))4951 (c-name (vector-ref x 1))4952 (arity (vector-ref x 2)))4953 (if (= i 0) (display " " port) (display "," port))4954 (display c-id-prefix port)4955 (display "DEF_C_PRC(" port)4956 (display c-name port)4957 (display "," port)4958 (display c-id-prefix port)4959 (display "P_" port)4960 (display (scheme-id->c-id scheme-name) port)4961 (display "," port)4962 (display arity port)4963 (display ")" port)4964 (newline port)4965 (loop (+ i 1) (cdr lst)))))4966 (display c-id-prefix port)4967 (display "END_C_PRC" port)4968 (newline port)))4969 (newline port)4970 (display c-id-prefix port)4971 (display "BEGIN_PRM" port)4972 (newline port)4973 (for-each (lambda (x) (display x port) (newline port)) inits)4974 (display c-id-prefix port)4975 (display "END_PRM" port)4976 (newline port)4977 (close-output-port port)))))4978(define (generate-report env)4979 (let ((vars (sort-variables (env-global-variables env)))4980 (decl (env-declarations env)))4981 (define (report title pred? vars wrote-something?)4982 (if (pair? vars)4983 (let ((var (car vars)))4984 (if (pred? var)4985 (begin4986 (if (not wrote-something?)4987 (begin (display " ") (display title) (newline)))4988 (let loop1 ((l (var-refs var)) (r? #f) (c? #f))4989 (if (pair? l)4990 (let* ((x (car l)) (y (node-parent x)))4991 (if (and y (app? y) (eq? x (app-oper y)))4992 (loop1 (cdr l) r? #t)4993 (loop1 (cdr l) #t c?)))4994 (let loop2 ((l (var-sets var)) (d? #f) (a? #f))4995 (if (pair? l)4996 (if (set? (car l))4997 (loop2 (cdr l) d? #t)4998 (loop2 (cdr l) #t a?))4999 (begin5000 (display " [")5001 (if d? (display "D") (display " "))5002 (if a? (display "A") (display " "))5003 (if r? (display "R") (display " "))5004 (if c? (display "C") (display " "))5005 (display "] ")5006 (display (var-name var))5007 (newline))))))5008 (report title pred? (cdr vars) #t))5009 (cons (car vars)5010 (report title pred? (cdr vars) wrote-something?))))5011 (begin (if wrote-something? (newline)) '())))5012 (display "Global variable usage:")5013 (newline)5014 (newline)5015 (report "OTHERS"5016 (lambda (x) #t)5017 (report "EXTENDED"5018 (lambda (x) (target.prim-info (var-name x)))5019 (report "STANDARD"5020 (lambda (x) (standard-procedure (var-name x) decl))5021 vars5022 #f)5023 #f)5024 #f)))5025(define (compile-parsed-program module-name program env c-intf info-port)5026 (if info-port (display "Compiling:" info-port))5027 (set! trace-indentation 0)5028 (set! *bbs* (make-bbs))5029 (set! *global-env* env)5030 (set! proc-queue '())5031 (set! constant-vars '())5032 (set! known-procs '())5033 (restore-context (make-context 0 '() (list ret-var) '() (entry-poll) #f))5034 (let* ((entry-lbl (bbs-new-lbl! *bbs*))5035 (body-lbl (bbs-new-lbl! *bbs*))5036 (frame (current-frame ret-var-set))5037 (comment (if (null? program) #f (source-comment (car program)))))5038 (bbs-entry-lbl-num-set! *bbs* entry-lbl)5039 (set! entry-bb5040 (make-bb (make-label-entry entry-lbl 0 0 #f #f frame comment) *bbs*))5041 (bb-put-branch! entry-bb (make-jump (make-lbl body-lbl) #f #f frame #f))5042 (set! *bb* (make-bb (make-label-simple body-lbl frame comment) *bbs*))5043 (let loop1 ((l (c-intf-procs c-intf)))5044 (if (not (null? l))5045 (let* ((x (car l))5046 (name (vector-ref x 0))5047 (sym (string->canonical-symbol name))5048 (var (env-lookup-global-var *global-env* sym)))5049 (add-constant-var5050 var5051 (make-obj (make-proc-obj name #t #f 0 #t '() '(#f))))5052 (loop1 (cdr l)))))5053 (let loop2 ((l program))5054 (if (not (null? l))5055 (let ((node (car l)))5056 (if (def? node)5057 (let* ((var (def-var node)) (val (global-val var)))5058 (if (and val (prc? val))5059 (add-constant-var5060 var5061 (make-obj5062 (make-proc-obj5063 (symbol->string (var-name var))5064 #t5065 #f5066 (call-pattern val)5067 #t5068 '()5069 '(#f)))))))5070 (loop2 (cdr l)))))5071 (let loop3 ((l program))5072 (if (null? l)5073 (let ((ret-opnd (var->opnd ret-var)))5074 (seal-bb #t 'return)5075 (dealloc-slots nb-slots)5076 (bb-put-branch!5077 *bb*5078 (make-jump ret-opnd #f #f (current-frame (set-empty)) #f)))5079 (let ((node (car l)))5080 (if (def? node)5081 (begin5082 (gen-define (def-var node) (def-val node) info-port)5083 (loop3 (cdr l)))5084 (if (null? (cdr l))5085 (gen-node node ret-var-set 'tail)5086 (begin5087 (gen-node node ret-var-set 'need)5088 (loop3 (cdr l))))))))5089 (let loop4 ()5090 (if (pair? proc-queue)5091 (let ((x (car proc-queue)))5092 (set! proc-queue (cdr proc-queue))5093 (gen-proc (car x) (cadr x) (caddr x) info-port)5094 (trace-unindent info-port)5095 (loop4))))5096 (if info-port (begin (newline info-port) (newline info-port)))5097 (bbs-purify! *bbs*)5098 (let ((proc (make-proc-obj5099 (string-append "#!" module-name)5100 #t5101 *bbs*5102 '(0)5103 #t5104 '()5105 '(#f))))5106 (set! *bb* '())5107 (set! *bbs* '())5108 (set! *global-env* '())5109 (set! proc-queue '())5110 (set! constant-vars '())5111 (set! known-procs '())5112 (clear-context)5113 proc)))5114(define *bb* '())5115(define *bbs* '())5116(define *global-env* '())5117(define proc-queue '())5118(define constant-vars '())5119(define known-procs '())5120(define trace-indentation '())5121(define (trace-indent info-port)5122 (set! trace-indentation (+ trace-indentation 1))5123 (if info-port5124 (begin5125 (newline info-port)5126 (let loop ((i trace-indentation))5127 (if (> i 0) (begin (display " " info-port) (loop (- i 1))))))))5128(define (trace-unindent info-port)5129 (set! trace-indentation (- trace-indentation 1)))5130(define (gen-define var node info-port)5131 (if (prc? node)5132 (let* ((p-bbs *bbs*)5133 (p-bb *bb*)5134 (p-proc-queue proc-queue)5135 (p-known-procs known-procs)5136 (p-context (current-context))5137 (bbs (make-bbs))5138 (lbl1 (bbs-new-lbl! bbs))5139 (lbl2 (bbs-new-lbl! bbs))5140 (context (entry-context node '()))5141 (frame (context->frame5142 context5143 (set-union (free-variables (prc-body node)) ret-var-set)))5144 (bb1 (make-bb (make-label-entry5145 lbl15146 (length (prc-parms node))5147 (prc-min node)5148 (prc-rest node)5149 #f5150 frame5151 (source-comment node))5152 bbs))5153 (bb2 (make-bb (make-label-simple lbl2 frame (source-comment node))5154 bbs)))5155 (define (do-body)5156 (gen-proc node bb2 context info-port)5157 (let loop ()5158 (if (pair? proc-queue)5159 (let ((x (car proc-queue)))5160 (set! proc-queue (cdr proc-queue))5161 (gen-proc (car x) (cadr x) (caddr x) info-port)5162 (trace-unindent info-port)5163 (loop))))5164 (trace-unindent info-port)5165 (bbs-purify! *bbs*))5166 (context-entry-bb-set! context bb1)5167 (bbs-entry-lbl-num-set! bbs lbl1)5168 (bb-put-branch! bb1 (make-jump (make-lbl lbl2) #f #f frame #f))5169 (set! *bbs* bbs)5170 (set! proc-queue '())5171 (set! known-procs '())5172 (if (constant-var? var)5173 (let-constant-var5174 var5175 (make-lbl lbl1)5176 (lambda () (add-known-proc lbl1 node) (do-body)))5177 (do-body))5178 (set! *bbs* p-bbs)5179 (set! *bb* p-bb)5180 (set! proc-queue p-proc-queue)5181 (set! known-procs p-known-procs)5182 (restore-context p-context)5183 (let* ((x (assq var constant-vars))5184 (proc (if x5185 (let ((p (cdr x)))5186 (proc-obj-code-set! (obj-val p) bbs)5187 p)5188 (make-obj5189 (make-proc-obj5190 (symbol->string (var-name var))5191 #f5192 bbs5193 (call-pattern node)5194 #t5195 '()5196 '(#f))))))5197 (put-copy5198 proc5199 (make-glo (var-name var))5200 #f5201 ret-var-set5202 (source-comment node))))5203 (put-copy5204 (gen-node node ret-var-set 'need)5205 (make-glo (var-name var))5206 #f5207 ret-var-set5208 (source-comment node))))5209(define (call-pattern node)5210 (make-pattern (prc-min node) (length (prc-parms node)) (prc-rest node)))5211(define (make-context nb-slots slots regs closed poll entry-bb)5212 (vector nb-slots slots regs closed poll entry-bb))5213(define (context-nb-slots x) (vector-ref x 0))5214(define (context-slots x) (vector-ref x 1))5215(define (context-regs x) (vector-ref x 2))5216(define (context-closed x) (vector-ref x 3))5217(define (context-poll x) (vector-ref x 4))5218(define (context-entry-bb x) (vector-ref x 5))5219(define (context-entry-bb-set! x y) (vector-set! x 5 y))5220(define nb-slots '())5221(define slots '())5222(define regs '())5223(define closed '())5224(define poll '())5225(define entry-bb '())5226(define (restore-context context)5227 (set! nb-slots (context-nb-slots context))5228 (set! slots (context-slots context))5229 (set! regs (context-regs context))5230 (set! closed (context-closed context))5231 (set! poll (context-poll context))5232 (set! entry-bb (context-entry-bb context)))5233(define (clear-context)5234 (restore-context (make-context '() '() '() '() '() '())))5235(define (current-context)5236 (make-context nb-slots slots regs closed poll entry-bb))5237(define (current-frame live) (make-frame nb-slots slots regs closed live))5238(define (context->frame context live)5239 (make-frame5240 (context-nb-slots context)5241 (context-slots context)5242 (context-regs context)5243 (context-closed context)5244 live))5245(define (make-poll since-entry? delta) (cons since-entry? delta))5246(define (poll-since-entry? x) (car x))5247(define (poll-delta x) (cdr x))5248(define (entry-poll) (make-poll #f (- poll-period poll-head)))5249(define (return-poll poll)5250 (let ((delta (poll-delta poll)))5251 (make-poll (poll-since-entry? poll) (+ poll-head (max delta poll-tail)))))5252(define (poll-merge poll other-poll)5253 (make-poll5254 (or (poll-since-entry? poll) (poll-since-entry? other-poll))5255 (max (poll-delta poll) (poll-delta other-poll))))5256(define poll-period #f)5257(set! poll-period 90)5258(define poll-head #f)5259(set! poll-head 15)5260(define poll-tail #f)5261(set! poll-tail 15)5262(define (entry-context proc closed)5263 (define (empty-vars-list n)5264 (if (> n 0) (cons empty-var (empty-vars-list (- n 1))) '()))5265 (let* ((parms (prc-parms proc))5266 (pc (target.label-info5267 (prc-min proc)5268 (length parms)5269 (prc-rest proc)5270 (not (null? closed))))5271 (fs (pcontext-fs pc))5272 (slots-list (empty-vars-list fs))5273 (regs-list (empty-vars-list target.nb-regs)))5274 (define (assign-var-to-loc var loc)5275 (let ((x (cond ((reg? loc)5276 (let ((i (reg-num loc)))5277 (if (<= i target.nb-regs)5278 (nth-after regs-list i)5279 (compiler-internal-error5280 "entry-context, reg out of bound in back-end's pcontext"))))5281 ((stk? loc)5282 (let ((i (stk-num loc)))5283 (if (<= i fs)5284 (nth-after slots-list (- fs i))5285 (compiler-internal-error5286 "entry-context, stk out of bound in back-end's pcontext"))))5287 (else5288 (compiler-internal-error5289 "entry-context, loc other than reg or stk in back-end's pcontext")))))5290 (if (eq? (car x) empty-var)5291 (set-car! x var)5292 (compiler-internal-error5293 "entry-context, duplicate location in back-end's pcontext"))))5294 (let loop ((l (pcontext-map pc)))5295 (if (not (null? l))5296 (let* ((couple (car l)) (name (car couple)) (loc (cdr couple)))5297 (cond ((eq? name 'return) (assign-var-to-loc ret-var loc))5298 ((eq? name 'closure-env)5299 (assign-var-to-loc closure-env-var loc))5300 (else (assign-var-to-loc (list-ref parms (- name 1)) loc)))5301 (loop (cdr l)))))5302 (make-context fs slots-list regs-list closed (entry-poll) #f)))5303(define (get-var opnd)5304 (cond ((glo? opnd) (env-lookup-global-var *global-env* (glo-name opnd)))5305 ((reg? opnd) (list-ref regs (reg-num opnd)))5306 ((stk? opnd) (list-ref slots (- nb-slots (stk-num opnd))))5307 (else5308 (compiler-internal-error5309 "get-var, location must be global, register or stack slot"))))5310(define (put-var opnd new)5311 (define (put-v opnd new)5312 (cond ((reg? opnd) (set! regs (replace-nth regs (reg-num opnd) new)))5313 ((stk? opnd)5314 (set! slots (replace-nth slots (- nb-slots (stk-num opnd)) new)))5315 (else5316 (compiler-internal-error5317 "put-var, location must be register or stack slot, for var:"5318 (var-name new)))))5319 (if (eq? new ret-var)5320 (let ((x (var->opnd ret-var))) (and x (put-v x empty-var))))5321 (put-v opnd new))5322(define (flush-regs) (set! regs '()))5323(define (push-slot)5324 (set! nb-slots (+ nb-slots 1))5325 (set! slots (cons empty-var slots)))5326(define (dealloc-slots n)5327 (set! nb-slots (- nb-slots n))5328 (set! slots (nth-after slots n)))5329(define (pop-slot) (dealloc-slots 1))5330(define (replace-nth l i v)5331 (if (null? l)5332 (if (= i 0) (list v) (cons empty-var (replace-nth l (- i 1) v)))5333 (if (= i 0)5334 (cons v (cdr l))5335 (cons (car l) (replace-nth (cdr l) (- i 1) v)))))5336(define (live-vars live)5337 (if (not (set-empty? (set-intersection live (list->set closed))))5338 (set-adjoin live closure-env-var)5339 live))5340(define (dead-slots live)5341 (let ((live-v (live-vars live)))5342 (define (loop s l i)5343 (cond ((null? l) (list->set (reverse s)))5344 ((set-member? (car l) live-v) (loop s (cdr l) (- i 1)))5345 (else (loop (cons i s) (cdr l) (- i 1)))))5346 (loop '() slots nb-slots)))5347(define (live-slots live)5348 (let ((live-v (live-vars live)))5349 (define (loop s l i)5350 (cond ((null? l) (list->set (reverse s)))5351 ((set-member? (car l) live-v) (loop (cons i s) (cdr l) (- i 1)))5352 (else (loop s (cdr l) (- i 1)))))5353 (loop '() slots nb-slots)))5354(define (dead-regs live)5355 (let ((live-v (live-vars live)))5356 (define (loop s l i)5357 (cond ((>= i target.nb-regs) (list->set (reverse s)))5358 ((null? l) (loop (cons i s) l (+ i 1)))5359 ((and (set-member? (car l) live-v) (not (memq (car l) slots)))5360 (loop s (cdr l) (+ i 1)))5361 (else (loop (cons i s) (cdr l) (+ i 1)))))5362 (loop '() regs 0)))5363(define (live-regs live)5364 (let ((live-v (live-vars live)))5365 (define (loop s l i)5366 (cond ((null? l) (list->set (reverse s)))5367 ((and (set-member? (car l) live-v) (not (memq (car l) slots)))5368 (loop (cons i s) (cdr l) (+ i 1)))5369 (else (loop s (cdr l) (+ i 1)))))5370 (loop '() regs 0)))5371(define (lowest-dead-slot live)5372 (make-stk (or (lowest (dead-slots live)) (+ nb-slots 1))))5373(define (highest-live-slot live) (make-stk (or (highest (live-slots live)) 0)))5374(define (lowest-dead-reg live)5375 (let ((x (lowest (set-remove (dead-regs live) 0)))) (if x (make-reg x) #f)))5376(define (highest-dead-reg live)5377 (let ((x (highest (dead-regs live)))) (if x (make-reg x) #f)))5378(define (highest set) (if (set-empty? set) #f (apply max (set->list set))))5379(define (lowest set) (if (set-empty? set) #f (apply min (set->list set))))5380(define (above set n) (set-keep (lambda (x) (> x n)) set))5381(define (below set n) (set-keep (lambda (x) (< x n)) set))5382(define (var->opnd var)5383 (let ((x (assq var constant-vars)))5384 (if x5385 (cdr x)5386 (if (global? var)5387 (make-glo (var-name var))5388 (let ((n (pos-in-list var regs)))5389 (if n5390 (make-reg n)5391 (let ((n (pos-in-list var slots)))5392 (if n5393 (make-stk (- nb-slots n))5394 (let ((n (pos-in-list var closed)))5395 (if n5396 (make-clo (var->opnd closure-env-var) (+ n 1))5397 (compiler-internal-error5398 "var->opnd, variable is not accessible:"5399 (var-name var))))))))))))5400(define (source-comment node)5401 (let ((x (make-comment))) (comment-put! x 'source (node-source node)) x))5402(define (sort-variables lst)5403 (sort-list5404 lst5405 (lambda (x y)5406 (string<? (symbol->string (var-name x)) (symbol->string (var-name y))))))5407(define (add-constant-var var opnd)5408 (set! constant-vars (cons (cons var opnd) constant-vars)))5409(define (let-constant-var var opnd thunk)5410 (let* ((x (assq var constant-vars)) (temp (cdr x)))5411 (set-cdr! x opnd)5412 (thunk)5413 (set-cdr! x temp)))5414(define (constant-var? var) (assq var constant-vars))5415(define (not-constant-var? var) (not (constant-var? var)))5416(define (add-known-proc label proc)5417 (set! known-procs (cons (cons label proc) known-procs)))5418(define (gen-proc proc bb context info-port)5419 (trace-indent info-port)5420 (if info-port5421 (if (prc-name proc)5422 (display (prc-name proc) info-port)5423 (display "\"unknown\"" info-port)))5424 (let ((lbl (bb-lbl-num bb))5425 (live (set-union (free-variables (prc-body proc)) ret-var-set)))5426 (set! *bb* bb)5427 (restore-context context)5428 (gen-node (prc-body proc) ret-var-set 'tail)))5429(define (schedule-gen-proc proc closed-list)5430 (let* ((lbl1 (bbs-new-lbl! *bbs*))5431 (lbl2 (bbs-new-lbl! *bbs*))5432 (context (entry-context proc closed-list))5433 (frame (context->frame5434 context5435 (set-union (free-variables (prc-body proc)) ret-var-set)))5436 (bb1 (make-bb (make-label-entry5437 lbl15438 (length (prc-parms proc))5439 (prc-min proc)5440 (prc-rest proc)5441 (not (null? closed-list))5442 frame5443 (source-comment proc))5444 *bbs*))5445 (bb2 (make-bb (make-label-simple lbl2 frame (source-comment proc))5446 *bbs*)))5447 (context-entry-bb-set! context bb1)5448 (bb-put-branch! bb1 (make-jump (make-lbl lbl2) #f #f frame #f))5449 (set! proc-queue (cons (list proc bb2 context) proc-queue))5450 (make-lbl lbl1)))5451(define (gen-node node live why)5452 (cond ((cst? node) (gen-return (make-obj (cst-val node)) why node))5453 ((ref? node)5454 (let* ((var (ref-var node)) (name (var-name var)))5455 (gen-return5456 (cond ((eq? why 'side) (make-obj undef-object))5457 ((global? var)5458 (let ((prim (target.prim-info* name (node-decl node))))5459 (if prim (make-obj prim) (var->opnd var))))5460 (else (var->opnd var)))5461 why5462 node)))5463 ((set? node)5464 (let* ((src (gen-node5465 (set-val node)5466 (set-adjoin live (set-var node))5467 'keep))5468 (dst (var->opnd (set-var node))))5469 (put-copy src dst #f live (source-comment node))5470 (gen-return (make-obj undef-object) why node)))5471 ((def? node)5472 (compiler-internal-error5473 "gen-node, 'def' node not at root of parse tree"))5474 ((tst? node) (gen-tst node live why))5475 ((conj? node) (gen-conj/disj node live why))5476 ((disj? node) (gen-conj/disj node live why))5477 ((prc? node)5478 (let* ((closed (not-constant-closed-vars node))5479 (closed-list (sort-variables (set->list closed)))5480 (proc-lbl (schedule-gen-proc node closed-list)))5481 (let ((opnd (if (null? closed-list)5482 (begin5483 (add-known-proc (lbl-num proc-lbl) node)5484 proc-lbl)5485 (begin5486 (dealloc-slots5487 (- nb-slots5488 (stk-num (highest-live-slot5489 (set-union closed live)))))5490 (push-slot)5491 (let ((slot (make-stk nb-slots))5492 (var (make-temp-var 'closure)))5493 (put-var slot var)5494 (bb-put-non-branch!5495 *bb*5496 (make-close5497 (list (make-closure-parms5498 slot5499 (lbl-num proc-lbl)5500 (map var->opnd closed-list)))5501 (current-frame (set-adjoin live var))5502 (source-comment node)))5503 slot)))))5504 (gen-return opnd why node))))5505 ((app? node) (gen-call node live why))5506 ((fut? node) (gen-fut node live why))5507 (else5508 (compiler-internal-error5509 "gen-node, unknown parse tree node type:"5510 node))))5511(define (gen-return opnd why node)5512 (cond ((eq? why 'tail)5513 (let ((var (make-temp-var 'result)))5514 (put-copy5515 opnd5516 target.proc-result5517 var5518 ret-var-set5519 (source-comment node))5520 (let ((ret-opnd (var->opnd ret-var)))5521 (seal-bb (intrs-enabled? (node-decl node)) 'return)5522 (dealloc-slots nb-slots)5523 (bb-put-branch!5524 *bb*5525 (make-jump5526 ret-opnd5527 #f5528 #f5529 (current-frame (set-singleton var))5530 #f)))))5531 (else opnd)))5532(define (not-constant-closed-vars val)5533 (set-keep not-constant-var? (free-variables val)))5534(define (predicate node live cont)5535 (define (cont* true-lbl false-lbl) (cont false-lbl true-lbl))5536 (define (generic-true-test)5537 (predicate-test node live **not-proc-obj '0 (list node) cont*))5538 (cond ((or (conj? node) (disj? node)) (predicate-conj/disj node live cont))5539 ((app? node)5540 (let ((proc (node->proc (app-oper node))))5541 (if proc5542 (let ((spec (specialize-for-call proc (node-decl node))))5543 (if (and (proc-obj-test spec)5544 (nb-args-conforms?5545 (length (app-args node))5546 (proc-obj-call-pat spec)))5547 (if (eq? spec **not-proc-obj)5548 (predicate (car (app-args node)) live cont*)5549 (predicate-test5550 node5551 live5552 spec5553 (proc-obj-strict-pat proc)5554 (app-args node)5555 cont))5556 (generic-true-test)))5557 (generic-true-test))))5558 (else (generic-true-test))))5559(define (predicate-conj/disj node live cont)5560 (let* ((pre (if (conj? node) (conj-pre node) (disj-pre node)))5561 (alt (if (conj? node) (conj-alt node) (disj-alt node)))5562 (alt-live (set-union live (free-variables alt))))5563 (predicate5564 pre5565 alt-live5566 (lambda (true-lbl false-lbl)5567 (let ((pre-context (current-context)))5568 (set! *bb*5569 (make-bb (make-label-simple5570 (if (conj? node) true-lbl false-lbl)5571 (current-frame alt-live)5572 (source-comment alt))5573 *bbs*))5574 (predicate5575 alt5576 live5577 (lambda (true-lbl2 false-lbl2)5578 (let ((alt-context (current-context)))5579 (restore-context pre-context)5580 (set! *bb*5581 (make-bb (make-label-simple5582 (if (conj? node) false-lbl true-lbl)5583 (current-frame live)5584 (source-comment alt))5585 *bbs*))5586 (merge-contexts-and-seal-bb5587 alt-context5588 live5589 (intrs-enabled? (node-decl node))5590 'internal5591 (source-comment node))5592 (bb-put-branch!5593 *bb*5594 (make-jump5595 (make-lbl (if (conj? node) false-lbl2 true-lbl2))5596 #f5597 #f5598 (current-frame live)5599 #f))5600 (cont true-lbl2 false-lbl2)))))))))5601(define (predicate-test node live test strict-pat args cont)5602 (let loop ((args* args) (liv live) (vars* '()))5603 (if (not (null? args*))5604 (let* ((needed (vals-live-vars liv (cdr args*)))5605 (var (save-var5606 (gen-node (car args*) needed 'need)5607 (make-temp-var 'predicate)5608 needed5609 (source-comment (car args*)))))5610 (loop (cdr args*) (set-adjoin liv var) (cons var vars*)))5611 (let* ((true-lbl (bbs-new-lbl! *bbs*))5612 (false-lbl (bbs-new-lbl! *bbs*)))5613 (seal-bb (intrs-enabled? (node-decl node)) 'internal)5614 (bb-put-branch!5615 *bb*5616 (make-ifjump5617 test5618 (map var->opnd (reverse vars*))5619 true-lbl5620 false-lbl5621 #f5622 (current-frame live)5623 (source-comment node)))5624 (cont true-lbl false-lbl)))))5625(define (gen-tst node live why)5626 (let ((pre (tst-pre node)) (con (tst-con node)) (alt (tst-alt node)))5627 (predicate5628 pre5629 (set-union live (free-variables con) (free-variables alt))5630 (lambda (true-lbl false-lbl)5631 (let ((pre-context (current-context))5632 (true-bb (make-bb (make-label-simple5633 true-lbl5634 (current-frame5635 (set-union live (free-variables con)))5636 (source-comment con))5637 *bbs*))5638 (false-bb5639 (make-bb (make-label-simple5640 false-lbl5641 (current-frame (set-union live (free-variables alt)))5642 (source-comment alt))5643 *bbs*)))5644 (set! *bb* true-bb)5645 (let ((con-opnd (gen-node con live why)))5646 (if (eq? why 'tail)5647 (begin5648 (restore-context pre-context)5649 (set! *bb* false-bb)5650 (gen-node alt live why))5651 (let* ((result-var (make-temp-var 'result))5652 (live-after (set-adjoin live result-var)))5653 (save-opnd-to-reg5654 con-opnd5655 target.proc-result5656 result-var5657 live5658 (source-comment con))5659 (let ((con-context (current-context)) (con-bb *bb*))5660 (restore-context pre-context)5661 (set! *bb* false-bb)5662 (save-opnd-to-reg5663 (gen-node alt live why)5664 target.proc-result5665 result-var5666 live5667 (source-comment alt))5668 (let ((next-lbl (bbs-new-lbl! *bbs*)) (alt-bb *bb*))5669 (if (> (context-nb-slots con-context) nb-slots)5670 (begin5671 (seal-bb (intrs-enabled? (node-decl node))5672 'internal)5673 (let ((alt-context (current-context)))5674 (restore-context con-context)5675 (set! *bb* con-bb)5676 (merge-contexts-and-seal-bb5677 alt-context5678 live-after5679 (intrs-enabled? (node-decl node))5680 'internal5681 (source-comment node))))5682 (let ((alt-context (current-context)))5683 (restore-context con-context)5684 (set! *bb* con-bb)5685 (seal-bb (intrs-enabled? (node-decl node))5686 'internal)5687 (let ((con-context* (current-context)))5688 (restore-context alt-context)5689 (set! *bb* alt-bb)5690 (merge-contexts-and-seal-bb5691 con-context*5692 live-after5693 (intrs-enabled? (node-decl node))5694 'internal5695 (source-comment node)))))5696 (let ((frame (current-frame live-after)))5697 (bb-put-branch!5698 con-bb5699 (make-jump (make-lbl next-lbl) #f #f frame #f))5700 (bb-put-branch!5701 alt-bb5702 (make-jump (make-lbl next-lbl) #f #f frame #f))5703 (set! *bb*5704 (make-bb (make-label-simple5705 next-lbl5706 frame5707 (source-comment node))5708 *bbs*))5709 target.proc-result)))))))))))5710(define (nb-args-conforms? n call-pat) (pattern-member? n call-pat))5711(define (merge-contexts-and-seal-bb other-context live poll? where comment)5712 (let ((live-v (live-vars live))5713 (other-nb-slots (context-nb-slots other-context))5714 (other-regs (context-regs other-context))5715 (other-slots (context-slots other-context))5716 (other-poll (context-poll other-context))5717 (other-entry-bb (context-entry-bb other-context)))5718 (let loop1 ((i (- target.nb-regs 1)))5719 (if (>= i 0)5720 (let ((other-var (reg->var other-regs i)) (var (reg->var regs i)))5721 (if (and (not (eq? var other-var)) (set-member? other-var live-v))5722 (let ((r (make-reg i)))5723 (put-var r empty-var)5724 (if (not (or (not (set-member? var live-v))5725 (memq var regs)5726 (memq var slots)))5727 (let ((top (make-stk (+ nb-slots 1))))5728 (put-copy r top var live-v comment)))5729 (put-copy (var->opnd other-var) r other-var live-v comment)))5730 (loop1 (- i 1)))))5731 (let loop2 ((i 1))5732 (if (<= i other-nb-slots)5733 (let ((other-var (stk->var other-slots i)) (var (stk->var slots i)))5734 (if (and (not (eq? var other-var)) (set-member? other-var live-v))5735 (let ((s (make-stk i)))5736 (if (<= i nb-slots) (put-var s empty-var))5737 (if (not (or (not (set-member? var live-v))5738 (memq var regs)5739 (memq var slots)))5740 (let ((top (make-stk (+ nb-slots 1))))5741 (put-copy s top var live-v comment)))5742 (put-copy (var->opnd other-var) s other-var live-v comment))5743 (if (> i nb-slots)5744 (let ((top (make-stk (+ nb-slots 1))))5745 (put-copy5746 (make-obj undef-object)5747 top5748 empty-var5749 live-v5750 comment))))5751 (loop2 (+ i 1)))))5752 (dealloc-slots (- nb-slots other-nb-slots))5753 (let loop3 ((i (- target.nb-regs 1)))5754 (if (>= i 0)5755 (let ((other-var (reg->var other-regs i)) (var (reg->var regs i)))5756 (if (not (eq? var other-var)) (put-var (make-reg i) empty-var))5757 (loop3 (- i 1)))))5758 (let loop4 ((i 1))5759 (if (<= i other-nb-slots)5760 (let ((other-var (stk->var other-slots i)) (var (stk->var slots i)))5761 (if (not (eq? var other-var)) (put-var (make-stk i) empty-var))5762 (loop4 (+ i 1)))))5763 (seal-bb poll? where)5764 (set! poll (poll-merge poll other-poll))5765 (if (not (eq? entry-bb other-entry-bb))5766 (compiler-internal-error5767 "merge-contexts-and-seal-bb, entry-bb's do not agree"))))5768(define (seal-bb poll? where)5769 (define (my-last-pair l) (if (pair? (cdr l)) (my-last-pair (cdr l)) l))5770 (define (poll-at split-point)5771 (let loop ((i 0) (l1 (bb-non-branch-instrs *bb*)) (l2 '()))5772 (if (< i split-point)5773 (loop (+ i 1) (cdr l1) (cons (car l1) l2))5774 (let* ((label-instr (bb-label-instr *bb*))5775 (non-branch-instrs1 (reverse l2))5776 (non-branch-instrs2 l1)5777 (frame (gvm-instr-frame5778 (car (my-last-pair5779 (cons label-instr non-branch-instrs1)))))5780 (prec-bb (make-bb label-instr *bbs*))5781 (new-lbl (bbs-new-lbl! *bbs*)))5782 (bb-non-branch-instrs-set! prec-bb non-branch-instrs1)5783 (bb-put-branch!5784 prec-bb5785 (make-jump (make-lbl new-lbl) #f #t frame #f))5786 (bb-label-instr-set! *bb* (make-label-simple new-lbl frame #f))5787 (bb-non-branch-instrs-set! *bb* non-branch-instrs2)5788 (set! poll (make-poll #t 0))))))5789 (define (poll-at-end) (poll-at (length (bb-non-branch-instrs *bb*))))5790 (define (impose-polling-constraints)5791 (let ((n (+ (length (bb-non-branch-instrs *bb*)) 1))5792 (delta (poll-delta poll)))5793 (if (> (+ delta n) poll-period)5794 (begin5795 (poll-at (max (- poll-period delta) 0))5796 (impose-polling-constraints)))))5797 (if poll? (impose-polling-constraints))5798 (let* ((n (+ (length (bb-non-branch-instrs *bb*)) 1))5799 (delta (+ (poll-delta poll) n))5800 (since-entry? (poll-since-entry? poll)))5801 (if (and poll?5802 (case where5803 ((call) (> delta (- poll-period poll-head)))5804 ((tail-call) (> delta poll-tail))5805 ((return) (and since-entry? (> delta (+ poll-head poll-tail))))5806 ((internal) #f)5807 (else5808 (compiler-internal-error "seal-bb, unknown 'where':" where))))5809 (poll-at-end)5810 (set! poll (make-poll since-entry? delta)))))5811(define (reg->var regs i)5812 (cond ((null? regs) '())5813 ((> i 0) (reg->var (cdr regs) (- i 1)))5814 (else (car regs))))5815(define (stk->var slots i)5816 (let ((j (- (length slots) i))) (if (< j 0) '() (list-ref slots j))))5817(define (gen-conj/disj node live why)5818 (let ((pre (if (conj? node) (conj-pre node) (disj-pre node)))5819 (alt (if (conj? node) (conj-alt node) (disj-alt node))))5820 (let ((needed (set-union live (free-variables alt)))5821 (bool? (boolean-value? pre))5822 (predicate-var (make-temp-var 'predicate)))5823 (define (general-predicate node live cont)5824 (let* ((con-lbl (bbs-new-lbl! *bbs*)) (alt-lbl (bbs-new-lbl! *bbs*)))5825 (save-opnd-to-reg5826 (gen-node pre live 'need)5827 target.proc-result5828 predicate-var5829 live5830 (source-comment pre))5831 (seal-bb (intrs-enabled? (node-decl node)) 'internal)5832 (bb-put-branch!5833 *bb*5834 (make-ifjump5835 **not-proc-obj5836 (list target.proc-result)5837 alt-lbl5838 con-lbl5839 #f5840 (current-frame (set-adjoin live predicate-var))5841 (source-comment node)))5842 (cont con-lbl alt-lbl)))5843 (define (alternative con-lbl alt-lbl)5844 (let* ((pre-context (current-context))5845 (result-var (make-temp-var 'result))5846 (con-live (if bool? live (set-adjoin live predicate-var)))5847 (alt-live (set-union live (free-variables alt)))5848 (con-bb (make-bb (make-label-simple5849 con-lbl5850 (current-frame con-live)5851 (source-comment alt))5852 *bbs*))5853 (alt-bb (make-bb (make-label-simple5854 alt-lbl5855 (current-frame alt-live)5856 (source-comment alt))5857 *bbs*)))5858 (if bool?5859 (begin5860 (set! *bb* con-bb)5861 (save-opnd-to-reg5862 (make-obj (if (conj? node) false-object #t))5863 target.proc-result5864 result-var5865 live5866 (source-comment node)))5867 (put-var (var->opnd predicate-var) result-var))5868 (let ((con-context (current-context)))5869 (set! *bb* alt-bb)5870 (restore-context pre-context)5871 (let ((alt-opnd (gen-node alt live why)))5872 (if (eq? why 'tail)5873 (begin5874 (restore-context con-context)5875 (set! *bb* con-bb)5876 (let ((ret-opnd (var->opnd ret-var))5877 (result-set (set-singleton result-var)))5878 (seal-bb (intrs-enabled? (node-decl node)) 'return)5879 (dealloc-slots nb-slots)5880 (bb-put-branch!5881 *bb*5882 (make-jump5883 ret-opnd5884 #f5885 #f5886 (current-frame result-set)5887 #f))))5888 (let ((alt-context* (current-context)) (alt-bb* *bb*))5889 (restore-context con-context)5890 (set! *bb* con-bb)5891 (seal-bb (intrs-enabled? (node-decl node)) 'internal)5892 (let ((con-context* (current-context))5893 (next-lbl (bbs-new-lbl! *bbs*)))5894 (restore-context alt-context*)5895 (set! *bb* alt-bb*)5896 (save-opnd-to-reg5897 alt-opnd5898 target.proc-result5899 result-var5900 live5901 (source-comment alt))5902 (merge-contexts-and-seal-bb5903 con-context*5904 (set-adjoin live result-var)5905 (intrs-enabled? (node-decl node))5906 'internal5907 (source-comment node))5908 (let ((frame (current-frame5909 (set-adjoin live result-var))))5910 (bb-put-branch!5911 *bb*5912 (make-jump (make-lbl next-lbl) #f #f frame #f))5913 (bb-put-branch!5914 con-bb5915 (make-jump (make-lbl next-lbl) #f #f frame #f))5916 (set! *bb*5917 (make-bb (make-label-simple5918 next-lbl5919 frame5920 (source-comment node))5921 *bbs*))5922 target.proc-result))))))))5923 ((if bool? predicate general-predicate)5924 pre5925 needed5926 (lambda (true-lbl false-lbl)5927 (if (conj? node)5928 (alternative false-lbl true-lbl)5929 (alternative true-lbl false-lbl)))))))5930(define (gen-call node live why)5931 (let* ((oper (app-oper node)) (args (app-args node)) (nb-args (length args)))5932 (if (and (prc? oper)5933 (not (prc-rest oper))5934 (= (length (prc-parms oper)) nb-args))5935 (gen-let (prc-parms oper) args (prc-body oper) live why)5936 (if (inlinable-app? node)5937 (let ((eval-order (arg-eval-order #f args))5938 (vars (map (lambda (x) (cons x #f)) args)))5939 (let loop ((l eval-order) (liv live))5940 (if (not (null? l))5941 (let* ((needed (vals-live-vars liv (map car (cdr l))))5942 (arg (car (car l)))5943 (pos (cdr (car l)))5944 (var (save-var5945 (gen-node arg needed 'need)5946 (make-temp-var pos)5947 needed5948 (source-comment arg))))5949 (set-cdr! (assq arg vars) var)5950 (loop (cdr l) (set-adjoin liv var)))5951 (let ((loc (if (eq? why 'side)5952 (make-reg 0)5953 (or (lowest-dead-reg live)5954 (lowest-dead-slot live)))))5955 (if (and (stk? loc) (> (stk-num loc) nb-slots))5956 (push-slot))5957 (let* ((args (map var->opnd (map cdr vars)))5958 (var (make-temp-var 'result))5959 (proc (node->proc oper))5960 (strict-pat (proc-obj-strict-pat proc)))5961 (if (not (eq? why 'side)) (put-var loc var))5962 (bb-put-non-branch!5963 *bb*5964 (make-apply5965 (specialize-for-call proc (node-decl node))5966 args5967 (if (eq? why 'side) #f loc)5968 (current-frame5969 (if (eq? why 'side) live (set-adjoin live var)))5970 (source-comment node)))5971 (gen-return loc why node))))))5972 (let* ((calling-local-proc?5973 (and (ref? oper)5974 (let ((opnd (var->opnd (ref-var oper))))5975 (and (lbl? opnd)5976 (let ((x (assq (lbl-num opnd) known-procs)))5977 (and x5978 (let ((proc (cdr x)))5979 (and (not (prc-rest proc))5980 (= (prc-min proc) nb-args)5981 (= (length (prc-parms proc))5982 nb-args)5983 (lbl-num opnd)))))))))5984 (jstate (get-jump-state5985 args5986 (if calling-local-proc?5987 (target.label-info nb-args nb-args #f #f)5988 (target.jump-info nb-args))))5989 (in-stk (jump-state-in-stk jstate))5990 (in-reg (jump-state-in-reg jstate))5991 (eval-order5992 (arg-eval-order (if calling-local-proc? #f oper) in-reg))5993 (live-after5994 (if (eq? why 'tail) (set-remove live ret-var) live))5995 (live-for-regs (args-live-vars live eval-order))5996 (return-lbl (if (eq? why 'tail) #f (bbs-new-lbl! *bbs*))))5997 (save-regs5998 (live-regs live-after)5999 (stk-live-vars live-for-regs in-stk why)6000 (source-comment node))6001 (let ((frame-start (stk-num (highest-live-slot live-after))))6002 (let loop1 ((l in-stk) (liv live-after) (i (+ frame-start 1)))6003 (if (not (null? l))6004 (let ((arg (car l))6005 (slot (make-stk i))6006 (needed (set-union6007 (stk-live-vars liv (cdr l) why)6008 live-for-regs)))6009 (if arg6010 (let ((var (if (and (eq? arg 'return)6011 (eq? why 'tail))6012 ret-var6013 (make-temp-var (- frame-start i)))))6014 (save-opnd-to-stk6015 (if (eq? arg 'return)6016 (if (eq? why 'tail)6017 (var->opnd ret-var)6018 (make-lbl return-lbl))6019 (gen-node arg needed 'need))6020 slot6021 var6022 needed6023 (source-comment6024 (if (eq? arg 'return) node arg)))6025 (loop1 (cdr l) (set-adjoin liv var) (+ i 1)))6026 (begin6027 (if (> i nb-slots)6028 (put-copy6029 (make-obj undef-object)6030 slot6031 empty-var6032 liv6033 (source-comment node)))6034 (loop1 (cdr l) liv (+ i 1)))))6035 (let loop2 ((l eval-order)6036 (liv liv)6037 (reg-map '())6038 (oper-var '()))6039 (if (not (null? l))6040 (let* ((arg (car (car l)))6041 (pos (cdr (car l)))6042 (needed (args-live-vars liv (cdr l)))6043 (var (if (and (eq? arg 'return)6044 (eq? why 'tail))6045 ret-var6046 (make-temp-var pos)))6047 (opnd (if (eq? arg 'return)6048 (if (eq? why 'tail)6049 (var->opnd ret-var)6050 (make-lbl return-lbl))6051 (gen-node arg needed 'need))))6052 (if (eq? pos 'operator)6053 (if (and (ref? arg)6054 (not (or (obj? opnd) (lbl? opnd))))6055 (loop2 (cdr l)6056 (set-adjoin liv (ref-var arg))6057 reg-map6058 (ref-var arg))6059 (begin6060 (save-arg6061 opnd6062 var6063 needed6064 (source-comment6065 (if (eq? arg 'return) node arg)))6066 (loop2 (cdr l)6067 (set-adjoin liv var)6068 reg-map6069 var)))6070 (let ((reg (make-reg pos)))6071 (if (all-args-trivial? (cdr l))6072 (save-opnd-to-reg6073 opnd6074 reg6075 var6076 needed6077 (source-comment6078 (if (eq? arg 'return) node arg)))6079 (save-in-slot6080 opnd6081 var6082 needed6083 (source-comment6084 (if (eq? arg 'return) node arg))))6085 (loop2 (cdr l)6086 (set-adjoin liv var)6087 (cons (cons pos var) reg-map)6088 oper-var))))6089 (let loop3 ((i (- target.nb-regs 1)))6090 (if (>= i 0)6091 (let ((couple (assq i reg-map)))6092 (if couple6093 (let ((var (cdr couple)))6094 (if (not (eq? (reg->var regs i) var))6095 (save-opnd-to-reg6096 (var->opnd var)6097 (make-reg i)6098 var6099 liv6100 (source-comment node)))))6101 (loop3 (- i 1)))6102 (let ((opnd (if calling-local-proc?6103 (make-lbl6104 (+ calling-local-proc? 1))6105 (var->opnd oper-var))))6106 (seal-bb (intrs-enabled? (node-decl node))6107 (if return-lbl 'call 'tail-call))6108 (dealloc-slots6109 (- nb-slots6110 (+ frame-start (length in-stk))))6111 (bb-put-branch!6112 *bb*6113 (make-jump6114 opnd6115 (if calling-local-proc? #f nb-args)6116 #f6117 (current-frame liv)6118 (source-comment node)))6119 (let ((result-var (make-temp-var 'result)))6120 (dealloc-slots (- nb-slots frame-start))6121 (flush-regs)6122 (put-var target.proc-result result-var)6123 (if return-lbl6124 (begin6125 (set! poll (return-poll poll))6126 (set! *bb*6127 (make-bb (make-label-return6128 return-lbl6129 (current-frame6130 (set-adjoin6131 live6132 result-var))6133 (source-comment6134 node))6135 *bbs*))))6136 target.proc-result))))))))))))))6137(define (contained-reg/slot opnd)6138 (cond ((reg? opnd) opnd)6139 ((stk? opnd) opnd)6140 ((clo? opnd) (contained-reg/slot (clo-base opnd)))6141 (else #f)))6142(define (opnd-needed opnd needed)6143 (let ((x (contained-reg/slot opnd)))6144 (if x (set-adjoin needed (get-var x)) needed)))6145(define (save-opnd opnd live comment)6146 (let ((slot (lowest-dead-slot live)))6147 (put-copy opnd slot (get-var opnd) live comment)))6148(define (save-regs regs live comment)6149 (for-each6150 (lambda (i) (save-opnd (make-reg i) live comment))6151 (set->list regs)))6152(define (save-opnd-to-reg opnd reg var live comment)6153 (if (set-member? (reg-num reg) (live-regs live))6154 (save-opnd reg (opnd-needed opnd live) comment))6155 (put-copy opnd reg var live comment))6156(define (save-opnd-to-stk opnd stk var live comment)6157 (if (set-member? (stk-num stk) (live-slots live))6158 (save-opnd stk (opnd-needed opnd live) comment))6159 (put-copy opnd stk var live comment))6160(define (all-args-trivial? l)6161 (if (null? l)6162 #t6163 (let ((arg (car (car l))))6164 (or (eq? arg 'return)6165 (and (trivial? arg) (all-args-trivial? (cdr l)))))))6166(define (every-trivial? l)6167 (or (null? l) (and (trivial? (car l)) (every-trivial? (cdr l)))))6168(define (trivial? node)6169 (or (cst? node)6170 (ref? node)6171 (and (set? node) (trivial? (set-val node)))6172 (and (inlinable-app? node) (every-trivial? (app-args node)))))6173(define (inlinable-app? node)6174 (if (app? node)6175 (let ((proc (node->proc (app-oper node))))6176 (and proc6177 (let ((spec (specialize-for-call proc (node-decl node))))6178 (and (proc-obj-inlinable spec)6179 (nb-args-conforms?6180 (length (app-args node))6181 (proc-obj-call-pat spec))))))6182 #f))6183(define (boolean-value? node)6184 (or (and (conj? node)6185 (boolean-value? (conj-pre node))6186 (boolean-value? (conj-alt node)))6187 (and (disj? node)6188 (boolean-value? (disj-pre node))6189 (boolean-value? (disj-alt node)))6190 (boolean-app? node)))6191(define (boolean-app? node)6192 (if (app? node)6193 (let ((proc (node->proc (app-oper node))))6194 (if proc (eq? (type-name (proc-obj-type proc)) 'boolean) #f))6195 #f))6196(define (node->proc node)6197 (cond ((cst? node) (if (proc-obj? (cst-val node)) (cst-val node) #f))6198 ((ref? node)6199 (if (global? (ref-var node))6200 (target.prim-info* (var-name (ref-var node)) (node-decl node))6201 #f))6202 (else #f)))6203(define (specialize-for-call proc decl) ((proc-obj-specialize proc) decl))6204(define (get-jump-state args pc)6205 (define (empty-node-list n)6206 (if (> n 0) (cons #f (empty-node-list (- n 1))) '()))6207 (let* ((fs (pcontext-fs pc))6208 (slots-list (empty-node-list fs))6209 (regs-list (empty-node-list target.nb-regs)))6210 (define (assign-node-to-loc var loc)6211 (let ((x (cond ((reg? loc)6212 (let ((i (reg-num loc)))6213 (if (<= i target.nb-regs)6214 (nth-after regs-list i)6215 (compiler-internal-error6216 "jump-state, reg out of bound in back-end's pcontext"))))6217 ((stk? loc)6218 (let ((i (stk-num loc)))6219 (if (<= i fs)6220 (nth-after slots-list (- i 1))6221 (compiler-internal-error6222 "jump-state, stk out of bound in back-end's pcontext"))))6223 (else6224 (compiler-internal-error6225 "jump-state, loc other than reg or stk in back-end's pcontext")))))6226 (if (not (car x))6227 (set-car! x var)6228 (compiler-internal-error6229 "jump-state, duplicate location in back-end's pcontext"))))6230 (let loop ((l (pcontext-map pc)))6231 (if (not (null? l))6232 (let* ((couple (car l)) (name (car couple)) (loc (cdr couple)))6233 (cond ((eq? name 'return) (assign-node-to-loc 'return loc))6234 (else (assign-node-to-loc (list-ref args (- name 1)) loc)))6235 (loop (cdr l)))))6236 (vector slots-list regs-list)))6237(define (jump-state-in-stk x) (vector-ref x 0))6238(define (jump-state-in-reg x) (vector-ref x 1))6239(define (arg-eval-order oper nodes)6240 (define (loop nodes pos part1 part2)6241 (cond ((null? nodes)6242 (let ((p1 (reverse part1)) (p2 (free-vars-order part2)))6243 (cond ((not oper) (append p1 p2))6244 ((trivial? oper)6245 (append p1 p2 (list (cons oper 'operator))))6246 (else (append (cons (cons oper 'operator) p1) p2)))))6247 ((not (car nodes)) (loop (cdr nodes) (+ pos 1) part1 part2))6248 ((or (eq? (car nodes) 'return) (trivial? (car nodes)))6249 (loop (cdr nodes)6250 (+ pos 1)6251 part16252 (cons (cons (car nodes) pos) part2)))6253 (else6254 (loop (cdr nodes)6255 (+ pos 1)6256 (cons (cons (car nodes) pos) part1)6257 part2))))6258 (loop nodes 0 '() '()))6259(define (free-vars-order l)6260 (let ((bins '()) (ordered-args '()))6261 (define (free-v x) (if (eq? x 'return) (set-empty) (free-variables x)))6262 (define (add-to-bin! x)6263 (let ((y (assq x bins)))6264 (if y (set-cdr! y (+ (cdr y) 1)) (set! bins (cons (cons x 1) bins)))))6265 (define (payoff-if-removed node)6266 (let ((x (free-v node)))6267 (let loop ((l (set->list x)) (r 0))6268 (if (null? l)6269 r6270 (let ((y (cdr (assq (car l) bins))))6271 (loop (cdr l) (+ r (quotient 1000 (* y y)))))))))6272 (define (remove-free-vars! x)6273 (let loop ((l (set->list x)))6274 (if (not (null? l))6275 (let ((y (assq (car l) bins)))6276 (set-cdr! y (- (cdr y) 1))6277 (loop (cdr l))))))6278 (define (find-max-payoff l thunk)6279 (if (null? l)6280 (thunk '() -1)6281 (find-max-payoff6282 (cdr l)6283 (lambda (best-arg best-payoff)6284 (let ((payoff (payoff-if-removed (car (car l)))))6285 (if (>= payoff best-payoff)6286 (thunk (car l) payoff)6287 (thunk best-arg best-payoff)))))))6288 (define (remove x l)6289 (cond ((null? l) '())6290 ((eq? x (car l)) (cdr l))6291 (else (cons (car l) (remove x (cdr l))))))6292 (for-each6293 (lambda (x) (for-each add-to-bin! (set->list (free-v (car x)))))6294 l)6295 (let loop ((args l) (ordered-args '()))6296 (if (null? args)6297 (reverse ordered-args)6298 (find-max-payoff6299 args6300 (lambda (best-arg best-payoff)6301 (remove-free-vars! (free-v (car best-arg)))6302 (loop (remove best-arg args) (cons best-arg ordered-args))))))))6303(define (args-live-vars live order)6304 (cond ((null? order) live)6305 ((eq? (car (car order)) 'return)6306 (args-live-vars (set-adjoin live ret-var) (cdr order)))6307 (else6308 (args-live-vars6309 (set-union live (free-variables (car (car order))))6310 (cdr order)))))6311(define (stk-live-vars live slots why)6312 (cond ((null? slots) live)6313 ((not (car slots)) (stk-live-vars live (cdr slots) why))6314 ((eq? (car slots) 'return)6315 (stk-live-vars6316 (if (eq? why 'tail) (set-adjoin live ret-var) live)6317 (cdr slots)6318 why))6319 (else6320 (stk-live-vars6321 (set-union live (free-variables (car slots)))6322 (cdr slots)6323 why))))6324(define (gen-let vars vals node live why)6325 (let ((var-val-map (pair-up vars vals))6326 (var-set (list->set vars))6327 (all-live6328 (set-union6329 live6330 (free-variables node)6331 (apply set-union (map free-variables vals)))))6332 (define (var->val var) (cdr (assq var var-val-map)))6333 (define (proc-var? var) (prc? (var->val var)))6334 (define (closed-vars var const-proc-vars)6335 (set-difference6336 (not-constant-closed-vars (var->val var))6337 const-proc-vars))6338 (define (no-closed-vars? var const-proc-vars)6339 (set-empty? (closed-vars var const-proc-vars)))6340 (define (closed-vars? var const-proc-vars)6341 (not (no-closed-vars? var const-proc-vars)))6342 (define (compute-const-proc-vars proc-vars)6343 (let loop1 ((const-proc-vars proc-vars))6344 (let ((new-const-proc-vars6345 (set-keep6346 (lambda (x) (no-closed-vars? x const-proc-vars))6347 const-proc-vars)))6348 (if (not (set-equal? new-const-proc-vars const-proc-vars))6349 (loop1 new-const-proc-vars)6350 const-proc-vars))))6351 (let* ((proc-vars (set-keep proc-var? var-set))6352 (const-proc-vars (compute-const-proc-vars proc-vars))6353 (clo-vars6354 (set-keep (lambda (x) (closed-vars? x const-proc-vars)) proc-vars))6355 (clo-vars-list (set->list clo-vars)))6356 (for-each6357 (lambda (proc-var)6358 (let ((label (schedule-gen-proc (var->val proc-var) '())))6359 (add-known-proc (lbl-num label) (var->val proc-var))6360 (add-constant-var proc-var label)))6361 (set->list const-proc-vars))6362 (let ((non-clo-vars-list6363 (set->list6364 (set-keep6365 (lambda (var)6366 (and (not (set-member? var const-proc-vars))6367 (not (set-member? var clo-vars))))6368 vars)))6369 (liv (set-union6370 live6371 (apply set-union6372 (map (lambda (x) (closed-vars x const-proc-vars))6373 clo-vars-list))6374 (free-variables node))))6375 (let loop2 ((vars* non-clo-vars-list))6376 (if (not (null? vars*))6377 (let* ((var (car vars*))6378 (val (var->val var))6379 (needed (vals-live-vars liv (map var->val (cdr vars*)))))6380 (if (var-useless? var)6381 (gen-node val needed 'side)6382 (save-val6383 (gen-node val needed 'need)6384 var6385 needed6386 (source-comment val)))6387 (loop2 (cdr vars*)))))6388 (if (pair? clo-vars-list)6389 (begin6390 (dealloc-slots (- nb-slots (stk-num (highest-live-slot liv))))6391 (let loop3 ((l clo-vars-list))6392 (if (not (null? l))6393 (begin6394 (push-slot)6395 (let ((var (car l)) (slot (make-stk nb-slots)))6396 (put-var slot var)6397 (loop3 (cdr l))))))6398 (bb-put-non-branch!6399 *bb*6400 (make-close6401 (map (lambda (var)6402 (let ((closed-list6403 (sort-variables6404 (set->list (closed-vars var const-proc-vars)))))6405 (if (null? closed-list)6406 (compiler-internal-error6407 "gen-let, no closed variables:"6408 (var-name var))6409 (make-closure-parms6410 (var->opnd var)6411 (lbl-num (schedule-gen-proc6412 (var->val var)6413 closed-list))6414 (map var->opnd closed-list)))))6415 clo-vars-list)6416 (current-frame liv)6417 (source-comment node)))))6418 (gen-node node live why)))))6419(define (save-arg opnd var live comment)6420 (if (glo? opnd)6421 (add-constant-var var opnd)6422 (save-val opnd var live comment)))6423(define (save-val opnd var live comment)6424 (cond ((or (obj? opnd) (lbl? opnd)) (add-constant-var var opnd))6425 ((and (reg? opnd) (not (set-member? (reg-num opnd) (live-regs live))))6426 (put-var opnd var))6427 ((and (stk? opnd) (not (set-member? (stk-num opnd) (live-slots live))))6428 (put-var opnd var))6429 (else (save-in-slot opnd var live comment))))6430(define (save-in-slot opnd var live comment)6431 (let ((slot (lowest-dead-slot live))) (put-copy opnd slot var live comment)))6432(define (save-var opnd var live comment)6433 (cond ((or (obj? opnd) (lbl? opnd)) (add-constant-var var opnd) var)6434 ((or (glo? opnd) (reg? opnd) (stk? opnd)) (get-var opnd))6435 (else6436 (let ((dest (or (highest-dead-reg live) (lowest-dead-slot live))))6437 (put-copy opnd dest var live comment)6438 var))))6439(define (put-copy opnd loc var live comment)6440 (if (and (stk? loc) (> (stk-num loc) nb-slots)) (push-slot))6441 (if var (put-var loc var))6442 (if (not (eq? opnd loc))6443 (bb-put-non-branch!6444 *bb*6445 (make-copy6446 opnd6447 loc6448 (current-frame (if var (set-adjoin live var) live))6449 comment))))6450(define (var-useless? var)6451 (and (set-empty? (var-refs var)) (set-empty? (var-sets var))))6452(define (vals-live-vars live vals)6453 (if (null? vals)6454 live6455 (vals-live-vars6456 (set-union live (free-variables (car vals)))6457 (cdr vals))))6458(define (gen-fut node live why)6459 (let* ((val (fut-val node))6460 (clo-vars (not-constant-closed-vars val))6461 (clo-vars-list (set->list clo-vars))6462 (ret-var* (make-temp-var 0))6463 (live-after live)6464 (live-starting-task6465 (set-adjoin (set-union live-after clo-vars) ret-var*))6466 (task-lbl (bbs-new-lbl! *bbs*))6467 (return-lbl (bbs-new-lbl! *bbs*)))6468 (save-regs (live-regs live-after) live-starting-task (source-comment node))6469 (let ((frame-start (stk-num (highest-live-slot live-after))))6470 (save-opnd-to-reg6471 (make-lbl return-lbl)6472 target.task-return6473 ret-var*6474 (set-remove live-starting-task ret-var*)6475 (source-comment node))6476 (let loop1 ((l clo-vars-list) (i 0))6477 (if (null? l)6478 (dealloc-slots (- nb-slots (+ frame-start i)))6479 (let ((var (car l)) (rest (cdr l)))6480 (if (memq var regs)6481 (loop1 rest i)6482 (let loop2 ((j (- target.nb-regs 1)))6483 (if (>= j 0)6484 (if (or (>= j (length regs))6485 (not (set-member?6486 (list-ref regs j)6487 live-starting-task)))6488 (let ((reg (make-reg j)))6489 (put-copy6490 (var->opnd var)6491 reg6492 var6493 live-starting-task6494 (source-comment node))6495 (loop1 rest i))6496 (loop2 (- j 1)))6497 (let ((slot (make-stk (+ frame-start (+ i 1))))6498 (needed (list->set rest)))6499 (if (and (or (> (stk-num slot) nb-slots)6500 (not (memq (list-ref6501 slots6502 (- nb-slots (stk-num slot)))6503 regs)))6504 (set-member?6505 (stk-num slot)6506 (live-slots needed)))6507 (save-opnd6508 slot6509 live-starting-task6510 (source-comment node)))6511 (put-copy6512 (var->opnd var)6513 slot6514 var6515 live-starting-task6516 (source-comment node))6517 (loop1 rest (+ i 1)))))))))6518 (seal-bb (intrs-enabled? (node-decl node)) 'call)6519 (bb-put-branch!6520 *bb*6521 (make-jump6522 (make-lbl task-lbl)6523 #f6524 #f6525 (current-frame live-starting-task)6526 #f))6527 (let ((task-context6528 (make-context6529 (- nb-slots frame-start)6530 (reverse (nth-after (reverse slots) frame-start))6531 (cons ret-var (cdr regs))6532 '()6533 poll6534 entry-bb))6535 (return-context6536 (make-context6537 frame-start6538 (nth-after slots (- nb-slots frame-start))6539 '()6540 closed6541 (return-poll poll)6542 entry-bb)))6543 (restore-context task-context)6544 (set! *bb*6545 (make-bb (make-label-task-entry6546 task-lbl6547 (current-frame live-starting-task)6548 (source-comment node))6549 *bbs*))6550 (gen-node val ret-var-set 'tail)6551 (let ((result-var (make-temp-var 'future)))6552 (restore-context return-context)6553 (put-var target.proc-result result-var)6554 (set! *bb*6555 (make-bb (make-label-task-return6556 return-lbl6557 (current-frame (set-adjoin live result-var))6558 (source-comment node))6559 *bbs*))6560 (gen-return target.proc-result why node))))))6561(define prim-procs6562 '(("not" (1) #f 0 boolean)6563 ("boolean?" (1) #f 0 boolean)6564 ("eqv?" (2) #f 0 boolean)6565 ("eq?" (2) #f 0 boolean)6566 ("equal?" (2) #f 0 boolean)6567 ("pair?" (1) #f 0 boolean)6568 ("cons" (2) #f () pair)6569 ("car" (1) #f 0 (#f))6570 ("cdr" (1) #f 0 (#f))6571 ("set-car!" (2) #t (1) pair)6572 ("set-cdr!" (2) #t (1) pair)6573 ("caar" (1) #f 0 (#f))6574 ("cadr" (1) #f 0 (#f))6575 ("cdar" (1) #f 0 (#f))6576 ("cddr" (1) #f 0 (#f))6577 ("caaar" (1) #f 0 (#f))6578 ("caadr" (1) #f 0 (#f))6579 ("cadar" (1) #f 0 (#f))6580 ("caddr" (1) #f 0 (#f))6581 ("cdaar" (1) #f 0 (#f))6582 ("cdadr" (1) #f 0 (#f))6583 ("cddar" (1) #f 0 (#f))6584 ("cdddr" (1) #f 0 (#f))6585 ("caaaar" (1) #f 0 (#f))6586 ("caaadr" (1) #f 0 (#f))6587 ("caadar" (1) #f 0 (#f))6588 ("caaddr" (1) #f 0 (#f))6589 ("cadaar" (1) #f 0 (#f))6590 ("cadadr" (1) #f 0 (#f))6591 ("caddar" (1) #f 0 (#f))6592 ("cadddr" (1) #f 0 (#f))6593 ("cdaaar" (1) #f 0 (#f))6594 ("cdaadr" (1) #f 0 (#f))6595 ("cdadar" (1) #f 0 (#f))6596 ("cdaddr" (1) #f 0 (#f))6597 ("cddaar" (1) #f 0 (#f))6598 ("cddadr" (1) #f 0 (#f))6599 ("cdddar" (1) #f 0 (#f))6600 ("cddddr" (1) #f 0 (#f))6601 ("null?" (1) #f 0 boolean)6602 ("list?" (1) #f 0 boolean)6603 ("list" 0 #f () list)6604 ("length" (1) #f 0 integer)6605 ("append" 0 #f 0 list)6606 ("reverse" (1) #f 0 list)6607 ("list-ref" (2) #f 0 (#f))6608 ("memq" (2) #f 0 list)6609 ("memv" (2) #f 0 list)6610 ("member" (2) #f 0 list)6611 ("assq" (2) #f 0 #f)6612 ("assv" (2) #f 0 #f)6613 ("assoc" (2) #f 0 #f)6614 ("symbol?" (1) #f 0 boolean)6615 ("symbol->string" (1) #f 0 string)6616 ("string->symbol" (1) #f 0 symbol)6617 ("number?" (1) #f 0 boolean)6618 ("complex?" (1) #f 0 boolean)6619 ("real?" (1) #f 0 boolean)6620 ("rational?" (1) #f 0 boolean)6621 ("integer?" (1) #f 0 boolean)6622 ("exact?" (1) #f 0 boolean)6623 ("inexact?" (1) #f 0 boolean)6624 ("=" 0 #f 0 boolean)6625 ("<" 0 #f 0 boolean)6626 (">" 0 #f 0 boolean)6627 ("<=" 0 #f 0 boolean)6628 (">=" 0 #f 0 boolean)6629 ("zero?" (1) #f 0 boolean)6630 ("positive?" (1) #f 0 boolean)6631 ("negative?" (1) #f 0 boolean)6632 ("odd?" (1) #f 0 boolean)6633 ("even?" (1) #f 0 boolean)6634 ("max" 1 #f 0 number)6635 ("min" 1 #f 0 number)6636 ("+" 0 #f 0 number)6637 ("*" 0 #f 0 number)6638 ("-" 1 #f 0 number)6639 ("/" 1 #f 0 number)6640 ("abs" (1) #f 0 number)6641 ("quotient" 1 #f 0 integer)6642 ("remainder" (2) #f 0 integer)6643 ("modulo" (2) #f 0 integer)6644 ("gcd" 1 #f 0 integer)6645 ("lcm" 1 #f 0 integer)6646 ("numerator" (1) #f 0 integer)6647 ("denominator" (1) #f 0 integer)6648 ("floor" (1) #f 0 integer)6649 ("ceiling" (1) #f 0 integer)6650 ("truncate" (1) #f 0 integer)6651 ("round" (1) #f 0 integer)6652 ("rationalize" (2) #f 0 number)6653 ("exp" (1) #f 0 number)6654 ("log" (1) #f 0 number)6655 ("sin" (1) #f 0 number)6656 ("cos" (1) #f 0 number)6657 ("tan" (1) #f 0 number)6658 ("asin" (1) #f 0 number)6659 ("acos" (1) #f 0 number)6660 ("atan" (1 2) #f 0 number)6661 ("sqrt" (1) #f 0 number)6662 ("expt" (2) #f 0 number)6663 ("make-rectangular" (2) #f 0 number)6664 ("make-polar" (2) #f 0 number)6665 ("real-part" (1) #f 0 real)6666 ("imag-part" (1) #f 0 real)6667 ("magnitude" (1) #f 0 real)6668 ("angle" (1) #f 0 real)6669 ("exact->inexact" (1) #f 0 number)6670 ("inexact->exact" (1) #f 0 number)6671 ("number->string" (1 2) #f 0 string)6672 ("string->number" (1 2) #f 0 number)6673 ("char?" (1) #f 0 boolean)6674 ("char=?" 0 #f 0 boolean)6675 ("char<?" 0 #f 0 boolean)6676 ("char>?" 0 #f 0 boolean)6677 ("char<=?" 0 #f 0 boolean)6678 ("char>=?" 0 #f 0 boolean)6679 ("char-ci=?" 0 #f 0 boolean)6680 ("char-ci<?" 0 #f 0 boolean)6681 ("char-ci>?" 0 #f 0 boolean)6682 ("char-ci<=?" 0 #f 0 boolean)6683 ("char-ci>=?" 0 #f 0 boolean)6684 ("char-alphabetic?" (1) #f 0 boolean)6685 ("char-numeric?" (1) #f 0 boolean)6686 ("char-whitespace?" (1) #f 0 boolean)6687 ("char-upper-case?" (1) #f 0 boolean)6688 ("char-lower-case?" (1) #f 0 boolean)6689 ("char->integer" (1) #f 0 integer)6690 ("integer->char" (1) #f 0 char)6691 ("char-upcase" (1) #f 0 char)6692 ("char-downcase" (1) #f 0 char)6693 ("string?" (1) #f 0 boolean)6694 ("make-string" (1 2) #f 0 string)6695 ("string" 0 #f 0 string)6696 ("string-length" (1) #f 0 integer)6697 ("string-ref" (2) #f 0 char)6698 ("string-set!" (3) #t 0 string)6699 ("string=?" 0 #f 0 boolean)6700 ("string<?" 0 #f 0 boolean)6701 ("string>?" 0 #f 0 boolean)6702 ("string<=?" 0 #f 0 boolean)6703 ("string>=?" 0 #f 0 boolean)6704 ("string-ci=?" 0 #f 0 boolean)6705 ("string-ci<?" 0 #f 0 boolean)6706 ("string-ci>?" 0 #f 0 boolean)6707 ("string-ci<=?" 0 #f 0 boolean)6708 ("string-ci>=?" 0 #f 0 boolean)6709 ("substring" (3) #f 0 string)6710 ("string-append" 0 #f 0 string)6711 ("vector?" (1) #f 0 boolean)6712 ("make-vector" (1 2) #f (1) vector)6713 ("vector" 0 #f () vector)6714 ("vector-length" (1) #f 0 integer)6715 ("vector-ref" (2) #f 0 (#f))6716 ("vector-set!" (3) #t (1 2) vector)6717 ("procedure?" (1) #f 0 boolean)6718 ("apply" 2 #t 0 (#f))6719 ("map" 2 #t 0 list)6720 ("for-each" 2 #t 0 #f)6721 ("call-with-current-continuation" (1) #t 0 (#f))6722 ("call-with-input-file" (2) #t 0 (#f))6723 ("call-with-output-file" (2) #t 0 (#f))6724 ("input-port?" (1) #f 0 boolean)6725 ("output-port?" (1) #f 0 boolean)6726 ("current-input-port" (0) #f 0 port)6727 ("current-output-port" (0) #f 0 port)6728 ("open-input-file" (1) #t 0 port)6729 ("open-output-file" (1) #t 0 port)6730 ("close-input-port" (1) #t 0 #f)6731 ("close-output-port" (1) #t 0 #f)6732 ("eof-object?" (1) #f 0 boolean)6733 ("read" (0 1) #t 0 #f)6734 ("read-char" (0 1) #t 0 #f)6735 ("peek-char" (0 1) #t 0 #f)6736 ("write" (0 1) #t 0 #f)6737 ("display" (0 1) #t 0 #f)6738 ("newline" (0 1) #t 0 #f)6739 ("write-char" (1 2) #t 0 #f)6740 ("list-tail" (2) #f 0 (#f))6741 ("string->list" (1) #f 0 list)6742 ("list->string" (1) #f 0 string)6743 ("string-copy" (1) #f 0 string)6744 ("string-fill!" (2) #t 0 string)6745 ("vector->list" (1) #f 0 list)6746 ("list->vector" (1) #f 0 vector)6747 ("vector-fill!" (2) #t 0 vector)6748 ("force" (1) #t 0 #f)6749 ("with-input-from-file" (2) #t 0 (#f))6750 ("with-output-to-file" (2) #t 0 (#f))6751 ("char-ready?" (0 1) #f 0 boolean)6752 ("load" (1) #t 0 (#f))6753 ("transcript-on" (1) #t 0 #f)6754 ("transcript-off" (0) #t 0 #f)6755 ("touch" (1) #t 0 #f)6756 ("##type" (1) #f () integer)6757 ("##type-cast" (2) #f () (#f))6758 ("##subtype" (1) #f () integer)6759 ("##subtype-set!" (2) #t () #f)6760 ("##not" (1) #f () boolean)6761 ("##null?" (1) #f () boolean)6762 ("##unassigned?" (1) #f () boolean)6763 ("##unbound?" (1) #f () boolean)6764 ("##eq?" (2) #f () boolean)6765 ("##fixnum?" (1) #f () boolean)6766 ("##flonum?" (1) #f () boolean)6767 ("##special?" (1) #f () boolean)6768 ("##pair?" (1) #f () boolean)6769 ("##subtyped?" (1) #f () boolean)6770 ("##procedure?" (1) #f () boolean)6771 ("##placeholder?" (1) #f () boolean)6772 ("##vector?" (1) #f () boolean)6773 ("##symbol?" (1) #f () boolean)6774 ("##ratnum?" (1) #f () boolean)6775 ("##cpxnum?" (1) #f () boolean)6776 ("##string?" (1) #f () boolean)6777 ("##bignum?" (1) #f () boolean)6778 ("##char?" (1) #f () boolean)6779 ("##closure?" (1) #f () boolean)6780 ("##subprocedure?" (1) #f () boolean)6781 ("##return-dynamic-env-bind?" (1) #f () boolean)6782 ("##fixnum.+" 0 #f () integer)6783 ("##fixnum.*" 0 #f () integer)6784 ("##fixnum.-" 1 #f () integer)6785 ("##fixnum.quotient" (2) #f () integer)6786 ("##fixnum.remainder" (2) #f () integer)6787 ("##fixnum.modulo" (2) #f () integer)6788 ("##fixnum.logior" 0 #f () integer)6789 ("##fixnum.logxor" 0 #f () integer)6790 ("##fixnum.logand" 0 #f () integer)6791 ("##fixnum.lognot" (1) #f () integer)6792 ("##fixnum.ash" (2) #f () integer)6793 ("##fixnum.lsh" (2) #f () integer)6794 ("##fixnum.zero?" (1) #f () boolean)6795 ("##fixnum.positive?" (1) #f () boolean)6796 ("##fixnum.negative?" (1) #f () boolean)6797 ("##fixnum.odd?" (1) #f () boolean)6798 ("##fixnum.even?" (1) #f () boolean)6799 ("##fixnum.=" 0 #f () boolean)6800 ("##fixnum.<" 0 #f () boolean)6801 ("##fixnum.>" 0 #f () boolean)6802 ("##fixnum.<=" 0 #f () boolean)6803 ("##fixnum.>=" 0 #f () boolean)6804 ("##flonum.->fixnum" (1) #f () integer)6805 ("##flonum.<-fixnum" (1) #f () real)6806 ("##flonum.+" 0 #f () real)6807 ("##flonum.*" 0 #f () real)6808 ("##flonum.-" 1 #f () real)6809 ("##flonum./" 1 #f () real)6810 ("##flonum.abs" (1) #f () real)6811 ("##flonum.truncate" (1) #f () real)6812 ("##flonum.round" (1) #f () real)6813 ("##flonum.exp" (1) #f () real)6814 ("##flonum.log" (1) #f () real)6815 ("##flonum.sin" (1) #f () real)6816 ("##flonum.cos" (1) #f () real)6817 ("##flonum.tan" (1) #f () real)6818 ("##flonum.asin" (1) #f () real)6819 ("##flonum.acos" (1) #f () real)6820 ("##flonum.atan" (1) #f () real)6821 ("##flonum.sqrt" (1) #f () real)6822 ("##flonum.zero?" (1) #f () boolean)6823 ("##flonum.positive?" (1) #f () boolean)6824 ("##flonum.negative?" (1) #f () boolean)6825 ("##flonum.=" 0 #f () boolean)6826 ("##flonum.<" 0 #f () boolean)6827 ("##flonum.>" 0 #f () boolean)6828 ("##flonum.<=" 0 #f () boolean)6829 ("##flonum.>=" 0 #f () boolean)6830 ("##char=?" 0 #f () boolean)6831 ("##char<?" 0 #f () boolean)6832 ("##char>?" 0 #f () boolean)6833 ("##char<=?" 0 #f () boolean)6834 ("##char>=?" 0 #f () boolean)6835 ("##cons" (2) #f () pair)6836 ("##set-car!" (2) #t () pair)6837 ("##set-cdr!" (2) #t () pair)6838 ("##car" (1) #f () (#f))6839 ("##cdr" (1) #f () (#f))6840 ("##caar" (1) #f () (#f))6841 ("##cadr" (1) #f () (#f))6842 ("##cdar" (1) #f () (#f))6843 ("##cddr" (1) #f () (#f))6844 ("##caaar" (1) #f () (#f))6845 ("##caadr" (1) #f () (#f))6846 ("##cadar" (1) #f () (#f))6847 ("##caddr" (1) #f () (#f))6848 ("##cdaar" (1) #f () (#f))6849 ("##cdadr" (1) #f () (#f))6850 ("##cddar" (1) #f () (#f))6851 ("##cdddr" (1) #f () (#f))6852 ("##caaaar" (1) #f () (#f))6853 ("##caaadr" (1) #f () (#f))6854 ("##caadar" (1) #f () (#f))6855 ("##caaddr" (1) #f () (#f))6856 ("##cadaar" (1) #f () (#f))6857 ("##cadadr" (1) #f () (#f))6858 ("##caddar" (1) #f () (#f))6859 ("##cadddr" (1) #f () (#f))6860 ("##cdaaar" (1) #f () (#f))6861 ("##cdaadr" (1) #f () (#f))6862 ("##cdadar" (1) #f () (#f))6863 ("##cdaddr" (1) #f () (#f))6864 ("##cddaar" (1) #f () (#f))6865 ("##cddadr" (1) #f () (#f))6866 ("##cdddar" (1) #f () (#f))6867 ("##cddddr" (1) #f () (#f))6868 ("##make-cell" (1) #f () pair)6869 ("##cell-ref" (1) #f () (#f))6870 ("##cell-set!" (2) #t () pair)6871 ("##vector" 0 #f () vector)6872 ("##make-vector" (2) #f () vector)6873 ("##vector-length" (1) #f () integer)6874 ("##vector-ref" (2) #f () (#f))6875 ("##vector-set!" (3) #t () vector)6876 ("##vector-shrink!" (2) #t () vector)6877 ("##string" 0 #f () string)6878 ("##make-string" (2) #f () string)6879 ("##string-length" (1) #f () integer)6880 ("##string-ref" (2) #f () char)6881 ("##string-set!" (3) #t () string)6882 ("##string-shrink!" (2) #t () string)6883 ("##vector8" 0 #f () string)6884 ("##make-vector8" (2) #f () string)6885 ("##vector8-length" (1) #f () integer)6886 ("##vector8-ref" (2) #f () integer)6887 ("##vector8-set!" (3) #t () string)6888 ("##vector8-shrink!" (2) #t () string)6889 ("##vector16" 0 #f () string)6890 ("##make-vector16" (2) #f () string)6891 ("##vector16-length" (1) #f () integer)6892 ("##vector16-ref" (2) #f () integer)6893 ("##vector16-set!" (3) #t () string)6894 ("##vector16-shrink!" (2) #t () string)6895 ("##closure-code" (1) #f () #f)6896 ("##closure-ref" (2) #f () (#f))6897 ("##closure-set!" (3) #t () #f)6898 ("##subprocedure-id" (1) #f () #f)6899 ("##subprocedure-parent" (1) #f () #f)6900 ("##return-fs" (1) #f () #f)6901 ("##return-link" (1) #f () #f)6902 ("##procedure-info" (1) #f () #f)6903 ("##pstate" (0) #f () #f)6904 ("##make-placeholder" (1) #f 0 (#f))6905 ("##touch" (1) #t 0 #f)6906 ("##apply" (2) #t () (#f))6907 ("##call-with-current-continuation" (1) #t () (#f))6908 ("##global-var" (1) #t () #f)6909 ("##global-var-ref" (1) #f () (#f))6910 ("##global-var-set!" (2) #t () #f)6911 ("##atomic-car" (1) #f () (#f))6912 ("##atomic-cdr" (1) #f () (#f))6913 ("##atomic-set-car!" (2) #t () pair)6914 ("##atomic-set-cdr!" (2) #t () pair)6915 ("##atomic-set-car-if-eq?!" (3) #t () boolean)6916 ("##atomic-set-cdr-if-eq?!" (3) #t () boolean)6917 ("##quasi-append" 0 #f 0 list)6918 ("##quasi-list" 0 #f () list)6919 ("##quasi-cons" (2) #f () pair)6920 ("##quasi-list->vector" (1) #f 0 vector)6921 ("##case-memv" (2) #f 0 list)))6922(define ofile-version-major 5)6923(define ofile-version-minor 0)6924(define prim-proc-prefix 1)6925(define user-proc-prefix 2)6926(define pair-prefix 3)6927(define flonum-prefix 4)6928(define local-object-bits -524281)6929(define symbol-object-bits -393209)6930(define prim-proc-object-bits -262137)6931(define padding-tag 0)6932(define end-of-code-tag 32768)6933(define m68020-proc-code-tag 32769)6934(define m68881-proc-code-tag 32770)6935(define stat-tag 32771)6936(define global-var-ref-tag 34816)6937(define global-var-set-tag 36864)6938(define global-var-ref-jump-tag 38912)6939(define prim-proc-ref-tag 40960)6940(define local-proc-ref-tag 49152)6941(define long-index-mask 16383)6942(define word-index-mask 2047)6943(define (ofile.begin! filename add-obj)6944 (set! ofile-add-obj add-obj)6945 (set! ofile-syms (queue-empty))6946; (set! *ofile-port1* (open-output-file (string-append filename ".O")))6947 (if ofile-asm?6948 (begin6949 (set! *ofile-port2*6950 (asm-open-output-file (string-append filename ".asm")))6951 (set! *ofile-pos* 0)))6952 (ofile-word ofile-version-major)6953 (ofile-word ofile-version-minor)6954 '())6955(define (ofile.end!)6956 (ofile-line "")6957; (close-output-port *ofile-port1*)6958 (if ofile-asm? (asm-close-output-port *ofile-port2*))6959 '())6960(define asm-output '())6961(define asm-line '())6962(define (asm-open-output-file filename)6963 (set! asm-output '())6964 (set! asm-line '()))6965(define (asm-close-output-port asm-port) #f)6966(define (asm-newline asm-port) (asm-display char-newline asm-port))6967(define (asm-display obj asm-port)6968 (if (eqv? obj char-newline)6969 (begin6970 (set! asm-output6971 (cons (apply string-append (reverse asm-line)) asm-output))6972 (set! asm-line '()))6973 (set! asm-line6974 (cons (cond ((string? obj) obj)6975 ((char? obj) (if (eqv? obj char-tab) " " (string obj)))6976 ((number? obj) (number->string obj))6977 (else (compiler-internal-error "asm-display" obj)))6978 asm-line))))6979(define (asm-output-get) (reverse asm-output))6980(define *ofile-port1* '())6981(define *ofile-port2* '())6982(define *ofile-pos* '())6983(define ofile-nl char-newline)6984(define ofile-tab char-tab)6985(define ofile-asm? '())6986(set! ofile-asm? '())6987(define ofile-asm-bits? '())6988(set! ofile-asm-bits? #f)6989(define ofile-asm-gvm? '())6990(set! ofile-asm-gvm? #f)6991(define ofile-stats? '())6992(set! ofile-stats? '())6993(define ofile-add-obj '())6994(set! ofile-add-obj '())6995(define ofile-syms '())6996(set! ofile-syms '())6997(define (ofile-word n)6998 (let ((n (modulo n 65536)))6999 (if (and ofile-asm? ofile-asm-bits?)7000 (let ()7001 (define (ofile-display x)7002 (asm-display x *ofile-port2*)7003 (cond ((eq? x ofile-nl) (set! *ofile-pos* 0))7004 ((eq? x ofile-tab)7005 (set! *ofile-pos* (* (quotient (+ *ofile-pos* 8) 8) 8)))7006 (else (set! *ofile-pos* (+ *ofile-pos* (string-length x))))))7007 (if (> *ofile-pos* 64) (ofile-display ofile-nl))7008 (if (= *ofile-pos* 0) (ofile-display " .word") (ofile-display ","))7009 (ofile-display ofile-tab)7010 (let ((s (make-string 6 #\0)))7011 (string-set! s 1 #\x)7012 (let loop ((i 5) (n n))7013 (if (> n 0)7014 (begin7015 (string-set!7016 s7017 i7018 (string-ref "0123456789ABCDEF" (remainder n 16)))7019 (loop (- i 1) (quotient n 16)))))7020 (ofile-display s))))7021' (write-word n *ofile-port1*)))7022(define (ofile-long x) (ofile-word (upper-16bits x)) (ofile-word x))7023(define (ofile-string s)7024 (let ((len (string-length s)))7025 (define (ref i) (if (>= i len) 0 (character-encoding (string-ref s i))))7026 (let loop ((i 0))7027 (if (< i len)7028 (begin7029 (ofile-word (+ (* (ref i) 256) (ref (+ i 1))))7030 (loop (+ i 2)))))7031 (if (= (remainder len 2) 0) (ofile-word 0))))7032(define (ofile-wsym tag name)7033 (let ((n (string-pos-in-list name (queue->list ofile-syms))))7034 (if n7035 (ofile-word (+ tag n))7036 (let ((m (length (queue->list ofile-syms))))7037 (queue-put! ofile-syms name)7038 (ofile-word (+ tag word-index-mask))7039 (ofile-string name)))))7040(define (ofile-lsym tag name)7041 (let ((n (string-pos-in-list name (queue->list ofile-syms))))7042 (if n7043 (ofile-long (+ tag (* n 8)))7044 (let ((m (length (queue->list ofile-syms))))7045 (queue-put! ofile-syms name)7046 (ofile-long (+ tag (* long-index-mask 8)))7047 (ofile-string name)))))7048(define (ofile-ref obj)7049 (let ((n (obj-encoding obj)))7050 (if n7051 (ofile-long n)7052 (if (symbol-object? obj)7053 (begin (ofile-lsym symbol-object-bits (symbol->string obj)))7054 (let ((m (ofile-add-obj obj)))7055 (if m7056 (ofile-long (+ local-object-bits (* m 8)))7057 (begin7058 (ofile-lsym7059 prim-proc-object-bits7060 (proc-obj-name obj)))))))))7061(define (ofile-prim-proc s)7062 (ofile-long prim-proc-prefix)7063 (ofile-wsym 0 s)7064 (ofile-comment (list "| #[primitive " s "] =")))7065(define (ofile-user-proc) (ofile-long user-proc-prefix))7066(define (ofile-line s)7067 (if ofile-asm?7068 (begin7069 (if (> *ofile-pos* 0) (asm-newline *ofile-port2*))7070 (asm-display s *ofile-port2*)7071 (asm-newline *ofile-port2*)7072 (set! *ofile-pos* 0))))7073(define (ofile-tabs-to n)7074 (let loop ()7075 (if (< *ofile-pos* n)7076 (begin7077 (asm-display ofile-tab *ofile-port2*)7078 (set! *ofile-pos* (* (quotient (+ *ofile-pos* 8) 8) 8))7079 (loop)))))7080(define (ofile-comment l)7081 (if ofile-asm?7082 (let ()7083 (if ofile-asm-bits?7084 (begin (ofile-tabs-to 32) (asm-display "|" *ofile-port2*)))7085 (for-each (lambda (x) (asm-display x *ofile-port2*)) l)7086 (asm-newline *ofile-port2*)7087 (set! *ofile-pos* 0))))7088(define (ofile-gvm-instr code)7089 (if (and ofile-asm? ofile-asm-gvm?)7090 (let ((gvm-instr (code-gvm-instr code)) (sn (code-slots-needed code)))7091 (if (> *ofile-pos* 0)7092 (begin (asm-newline *ofile-port2*) (set! *ofile-pos* 0)))7093 (if ofile-asm-bits? (ofile-tabs-to 32))7094 (asm-display "| GVM: [" *ofile-port2*)7095 (asm-display sn *ofile-port2*)7096 (asm-display "] " *ofile-port2*)7097 (asm-newline *ofile-port2*)7098 (set! *ofile-pos* 0))))7099(define (ofile-stat stat)7100 (define (obj->string x)7101 (cond ((string? x) x)7102 ((symbol-object? x) (symbol->string x))7103 ((number? x) (number->string x))7104 ((false-object? x) "#f")7105 ((eq? x #t) "#t")7106 ((null? x) "()")7107 ((pair? x)7108 (let loop ((l1 (cdr x)) (l2 (list (obj->string (car x)) "(")))7109 (cond ((pair? l1)7110 (loop (cdr l1)7111 (cons (obj->string (car l1)) (cons " " l2))))7112 ((null? l1) (apply string-append (reverse (cons ")" l2))))7113 (else7114 (apply string-append7115 (reverse (cons ")"7116 (cons (obj->string l1)7117 (cons " . " l2)))))))))7118 (else7119 (compiler-internal-error7120 "ofile-stat, can't convert to string 'x'"7121 x))))7122 (ofile-string (obj->string stat)))7123(define (upper-16bits x)7124 (cond ((>= x 0) (quotient x 65536))7125 ((>= x (- 65536)) -1)7126 (else (- (quotient (+ x 65537) 65536) 2))))7127(define type-fixnum 0)7128(define type-flonum 1)7129(define type-special 7)7130(define type-pair 4)7131(define type-placeholder 5)7132(define type-subtyped 3)7133(define type-procedure 2)7134(define subtype-vector 0)7135(define subtype-symbol 1)7136(define subtype-port 2)7137(define subtype-ratnum 3)7138(define subtype-cpxnum 4)7139(define subtype-string 16)7140(define subtype-bignum 17)7141(define data-false (- 33686019))7142(define data-null (- 67372037))7143(define data-true -2)7144(define data-undef -3)7145(define data-unass -4)7146(define data-unbound -5)7147(define data-eof -6)7148(define data-max-fixnum 268435455)7149(define data-min-fixnum (- 268435456))7150(define (make-encoding data type) (+ (* data 8) type))7151(define (obj-type obj)7152 (cond ((false-object? obj) 'special)7153 ((undef-object? obj) 'special)7154 ((symbol-object? obj) 'subtyped)7155 ((proc-obj? obj) 'procedure)7156 ((eq? obj #t) 'special)7157 ((null? obj) 'special)7158 ((pair? obj) 'pair)7159 ((number? obj)7160 (cond ((and (integer? obj)7161 (exact? obj)7162 (>= obj data-min-fixnum)7163 (<= obj data-max-fixnum))7164 'fixnum)7165 (7166#t7167;; (and (inexact? (real-part obj))7168;; (zero? (imag-part obj))7169;; (exact? (imag-part obj)))7170 'flonum)7171 (else 'subtyped)))7172 ((char? obj) 'special)7173 (else 'subtyped)))7174(define (obj-subtype obj)7175 (cond ((symbol-object? obj) 'symbol)7176 ((number? obj)7177 (cond ((and (integer? obj) (exact? obj)) 'bignum)7178 ((and (rational? obj) (exact? obj)) 'ratnum)7179 (else 'cpxnum)))7180 ((vector? obj) 'vector)7181 ((string? obj) 'string)7182 (else7183 (compiler-internal-error "obj-subtype, unknown object 'obj'" obj))))7184(define (obj-type-tag obj)7185 (case (obj-type obj)7186 ((fixnum) type-fixnum)7187 ((flonum) type-flonum)7188 ((special) type-special)7189 ((pair) type-pair)7190 ((subtyped) type-subtyped)7191 ((procedure) type-procedure)7192 (else (compiler-internal-error "obj-type-tag, unknown object 'obj'" obj))))7193(define (obj-encoding obj)7194 (case (obj-type obj)7195 ((fixnum) (make-encoding obj type-fixnum))7196 ((special)7197 (make-encoding7198 (cond ((false-object? obj) data-false)7199 ((undef-object? obj) data-undef)7200 ((eq? obj #t) data-true)7201 ((null? obj) data-null)7202 ((char? obj) (character-encoding obj))7203 (else7204 (compiler-internal-error7205 "obj-encoding, unknown SPECIAL object 'obj'"7206 obj)))7207 type-special))7208 (else #f)))7209(define bits-false (make-encoding data-false type-special))7210(define bits-null (make-encoding data-null type-special))7211(define bits-true (make-encoding data-true type-special))7212(define bits-unass (make-encoding data-unass type-special))7213(define bits-unbound (make-encoding data-unbound type-special))7214(define (asm.begin!)7215 (set! asm-code-queue (queue-empty))7216 (set! asm-const-queue (queue-empty))7217 '())7218(define (asm.end! debug-info)7219 (asm-assemble! debug-info)7220 (set! asm-code-queue '())7221 (set! asm-const-queue '())7222 '())7223(define asm-code-queue '())7224(define asm-const-queue '())7225(define (asm-word x) (queue-put! asm-code-queue (modulo x 65536)))7226(define (asm-long x) (asm-word (upper-16bits x)) (asm-word x))7227(define (asm-label lbl label-descr)7228 (queue-put! asm-code-queue (cons 'label (cons lbl label-descr))))7229(define (asm-comment x) (queue-put! asm-code-queue (cons 'comment x)))7230(define (asm-align n offset)7231 (queue-put! asm-code-queue (cons 'align (cons n offset))))7232(define (asm-ref-glob glob)7233 (queue-put!7234 asm-code-queue7235 (cons 'ref-glob (symbol->string (glob-name glob)))))7236(define (asm-set-glob glob)7237 (queue-put!7238 asm-code-queue7239 (cons 'set-glob (symbol->string (glob-name glob)))))7240(define (asm-ref-glob-jump glob)7241 (queue-put!7242 asm-code-queue7243 (cons 'ref-glob-jump (symbol->string (glob-name glob)))))7244(define (asm-proc-ref num offset)7245 (queue-put! asm-code-queue (cons 'proc-ref (cons num offset))))7246(define (asm-prim-ref proc offset)7247 (queue-put!7248 asm-code-queue7249 (cons 'prim-ref (cons (proc-obj-name proc) offset))))7250(define (asm-m68020-proc) (queue-put! asm-code-queue '(m68020-proc)))7251(define (asm-m68881-proc) (queue-put! asm-code-queue '(m68881-proc)))7252(define (asm-stat x) (queue-put! asm-code-queue (cons 'stat x)))7253(define (asm-brel type lbl)7254 (queue-put! asm-code-queue (cons 'brab (cons type lbl))))7255(define (asm-wrel lbl offs)7256 (queue-put! asm-code-queue (cons 'wrel (cons lbl offs))))7257(define (asm-lrel lbl offs n)7258 (queue-put! asm-code-queue (cons 'lrel (cons lbl (cons offs n)))))7259(define (asm-assemble! debug-info)7260 (define header-offset 2)7261 (define ref-glob-len 2)7262 (define set-glob-len 10)7263 (define ref-glob-jump-len 2)7264 (define proc-ref-len 4)7265 (define prim-ref-len 4)7266 (define stat-len 4)7267 (define (padding loc n offset) (modulo (- offset loc) n))7268 (queue-put! asm-const-queue debug-info)7269 (asm-align 4 0)7270 (emit-label const-lbl)7271 (let ((code-list (queue->list asm-code-queue))7272 (const-list (queue->list asm-const-queue)))7273 (let* ((fix-list7274 (let loop ((l code-list) (len header-offset) (x '()))7275 (if (null? l)7276 (reverse x)7277 (let ((part (car l)) (rest (cdr l)))7278 (if (pair? part)7279 (case (car part)7280 ((label align brab)7281 (loop rest 0 (cons (cons len part) x)))7282 ((wrel) (loop rest (+ len 2) x))7283 ((lrel) (loop rest (+ len 4) x))7284 ((ref-glob) (loop rest (+ len ref-glob-len) x))7285 ((set-glob) (loop rest (+ len set-glob-len) x))7286 ((ref-glob-jump)7287 (loop rest (+ len ref-glob-jump-len) x))7288 ((proc-ref) (loop rest (+ len proc-ref-len) x))7289 ((prim-ref) (loop rest (+ len prim-ref-len) x))7290 ((stat) (loop rest (+ len stat-len) x))7291 ((comment m68020-proc m68881-proc) (loop rest len x))7292 (else7293 (compiler-internal-error7294 "asm-assemble!, unknown code list element"7295 part)))7296 (loop rest (+ len 2) x))))))7297 (lbl-list7298 (let loop ((l fix-list) (x '()))7299 (if (null? l)7300 x7301 (let ((part (cdar l)) (rest (cdr l)))7302 (if (eq? (car part) 'label)7303 (loop rest (cons (cons (cadr part) part) x))7304 (loop rest x)))))))7305 (define (replace-lbl-refs-by-pointer-to-label)7306 (let loop ((l code-list))7307 (if (not (null? l))7308 (let ((part (car l)) (rest (cdr l)))7309 (if (pair? part)7310 (case (car part)7311 ((brab)7312 (set-cdr! (cdr part) (cdr (assq (cddr part) lbl-list))))7313 ((wrel)7314 (set-car! (cdr part) (cdr (assq (cadr part) lbl-list))))7315 ((lrel)7316 (set-car!7317 (cdr part)7318 (cdr (assq (cadr part) lbl-list))))))7319 (loop rest)))))7320 (define (assign-loc-to-labels)7321 (let loop ((l fix-list) (loc 0))7322 (if (not (null? l))7323 (let* ((first (car l))7324 (rest (cdr l))7325 (len (car first))7326 (cur-loc (+ loc len))7327 (part (cdr first)))7328 (case (car part)7329 ((label)7330 (if (cddr part)7331 (vector-set!7332 (cddr part)7333 07334 (quotient (- cur-loc header-offset) 8)))7335 (set-car! (cdr part) cur-loc)7336 (loop rest cur-loc))7337 ((align)7338 (loop rest7339 (+ cur-loc7340 (padding cur-loc (cadr part) (cddr part)))))7341 ((brab) (loop rest (+ cur-loc 2)))7342 ((braw) (loop rest (+ cur-loc 4)))7343 (else7344 (compiler-internal-error7345 "assign-loc-to-labels, unknown code list element"7346 part)))))))7347 (define (branch-tensioning-pass)7348 (assign-loc-to-labels)7349 (let loop ((changed? #f) (l fix-list) (loc 0))7350 (if (null? l)7351 (if changed? (branch-tensioning-pass))7352 (let* ((first (car l))7353 (rest (cdr l))7354 (len (car first))7355 (cur-loc (+ loc len))7356 (part (cdr first)))7357 (case (car part)7358 ((label) (loop changed? rest cur-loc))7359 ((align)7360 (loop changed?7361 rest7362 (+ cur-loc7363 (padding cur-loc (cadr part) (cddr part)))))7364 ((brab)7365 (let ((dist (- (cadr (cddr part)) (+ cur-loc 2))))7366 (if (or (< dist -128) (> dist 127) (= dist 0))7367 (begin7368 (set-car! part 'braw)7369 (loop #t rest (+ cur-loc 2)))7370 (loop changed? rest (+ cur-loc 2)))))7371 ((braw) (loop changed? rest (+ cur-loc 4)))7372 (else7373 (compiler-internal-error7374 "branch-tensioning-pass, unknown code list element"7375 part)))))))7376 (define (write-block start-loc end-loc start end)7377 (if (> end-loc start-loc)7378 (ofile-word (quotient (- end-loc start-loc) 2)))7379 (let loop ((loc start-loc) (l start))7380 (if (not (eq? l end))7381 (let ((part (car l)) (rest (cdr l)))7382 (if (pair? part)7383 (case (car part)7384 ((label) (loop loc rest))7385 ((align)7386 (let ((n (padding loc (cadr part) (cddr part))))7387 (let pad ((i 0))7388 (if (< i n)7389 (begin (ofile-word 0) (pad (+ i 2)))7390 (loop (+ loc n) rest)))))7391 ((brab)7392 (let ((dist (- (cadr (cddr part)) (+ loc 2))))7393 (ofile-word (+ (cadr part) (modulo dist 256)))7394 (loop (+ loc 2) rest)))7395 ((braw)7396 (let ((dist (- (cadr (cddr part)) (+ loc 2))))7397 (ofile-word (cadr part))7398 (ofile-word (modulo dist 65536))7399 (loop (+ loc 4) rest)))7400 ((wrel)7401 (let ((dist (+ (- (cadr (cadr part)) loc) (cddr part))))7402 (ofile-word (modulo dist 65536))7403 (loop (+ loc 2) rest)))7404 ((lrel)7405 (let ((dist (+ (- (cadr (cadr part)) loc)7406 (caddr part))))7407 (ofile-long (+ (* dist 65536) (cdddr part)))7408 (loop (+ loc 4) rest)))7409 ((comment)7410 (let ((x (cdr part)))7411 (if (pair? x) (ofile-comment x) (ofile-gvm-instr x))7412 (loop loc rest))))7413 (begin (ofile-word part) (loop (+ loc 2) rest)))))))7414 (define (write-code)7415 (let ((proc-len7416 (+ (cadr (cdr (assq const-lbl lbl-list)))7417 (* (length const-list) 4))))7418 (if (>= proc-len 32768)7419 (compiler-limitation-error7420 "procedure is too big (32K bytes limit per procedure)"))7421 (ofile-word (+ 32768 proc-len)))7422 (let loop1 ((start code-list) (start-loc header-offset))7423 (let loop2 ((end start) (loc start-loc))7424 (if (null? end)7425 (write-block start-loc loc start end)7426 (let ((part (car end)) (rest (cdr end)))7427 (if (pair? part)7428 (case (car part)7429 ((label comment) (loop2 rest loc))7430 ((align)7431 (loop2 rest7432 (+ loc (padding loc (cadr part) (cddr part)))))7433 ((brab wrel) (loop2 rest (+ loc 2)))7434 ((braw) (loop2 rest (+ loc 4)))7435 ((lrel) (loop2 rest (+ loc 4)))7436 (else7437 (write-block start-loc loc start end)7438 (case (car part)7439 ((ref-glob)7440 (ofile-wsym global-var-ref-tag (cdr part))7441 (loop1 rest (+ loc ref-glob-len)))7442 ((set-glob)7443 (ofile-wsym global-var-set-tag (cdr part))7444 (loop1 rest (+ loc set-glob-len)))7445 ((ref-glob-jump)7446 (ofile-wsym global-var-ref-jump-tag (cdr part))7447 (loop1 rest (+ loc ref-glob-jump-len)))7448 ((proc-ref)7449 (ofile-word (+ local-proc-ref-tag (cadr part)))7450 (ofile-word (cddr part))7451 (loop1 rest (+ loc proc-ref-len)))7452 ((prim-ref)7453 (ofile-wsym prim-proc-ref-tag (cadr part))7454 (ofile-word (cddr part))7455 (loop1 rest (+ loc prim-ref-len)))7456 ((m68020-proc)7457 (ofile-word m68020-proc-code-tag)7458 (loop1 rest loc))7459 ((m68881-proc)7460 (ofile-word m68881-proc-code-tag)7461 (loop1 rest loc))7462 ((stat)7463 (ofile-word stat-tag)7464 (ofile-stat (cdr part))7465 (loop1 rest (+ loc stat-len))))))7466 (loop2 rest (+ loc 2)))))))7467 (ofile-word end-of-code-tag)7468 (for-each ofile-ref const-list)7469 (ofile-long (obj-encoding (+ (length const-list) 1))))7470 (replace-lbl-refs-by-pointer-to-label)7471 (branch-tensioning-pass)7472 (write-code))))7473(define const-lbl 0)7474(define (identical-opnd68? opnd1 opnd2) (eqv? opnd1 opnd2))7475(define (reg68? x) (or (dreg? x) (areg? x)))7476(define (make-dreg num) num)7477(define (dreg? x) (and (integer? x) (>= x 0) (< x 8)))7478(define (dreg-num x) x)7479(define (make-areg num) (+ num 8))7480(define (areg? x) (and (integer? x) (>= x 8) (< x 16)))7481(define (areg-num x) (- x 8))7482(define (make-ind areg) (+ areg 8))7483(define (ind? x) (and (integer? x) (>= x 16) (< x 24)))7484(define (ind-areg x) (- x 8))7485(define (make-pinc areg) (+ areg 16))7486(define (pinc? x) (and (integer? x) (>= x 24) (< x 32)))7487(define (pinc-areg x) (- x 16))7488(define (make-pdec areg) (+ areg 24))7489(define (pdec? x) (and (integer? x) (>= x 32) (< x 40)))7490(define (pdec-areg x) (- x 24))7491(define (make-disp areg offset) (+ (+ areg 32) (* (modulo offset 65536) 8)))7492(define (disp? x) (and (integer? x) (>= x 40) (< x 524328)))7493(define (disp-areg x) (+ (remainder x 8) 8))7494(define (disp-offset x)7495 (- (modulo (+ (quotient (- x 40) 8) 32768) 65536) 32768))7496(define (make-disp* areg offset)7497 (if (= offset 0) (make-ind areg) (make-disp areg offset)))7498(define (disp*? x) (or (ind? x) (disp? x)))7499(define (disp*-areg x) (if (ind? x) (ind-areg x) (disp-areg x)))7500(define (disp*-offset x) (if (ind? x) 0 (disp-offset x)))7501(define (make-inx areg ireg offset)7502 (+ (+ areg 524320) (* ireg 8) (* (modulo offset 256) 128)))7503(define (inx? x) (and (integer? x) (>= x 524328) (< x 557096)))7504(define (inx-areg x) (+ (remainder (- x 524328) 8) 8))7505(define (inx-ireg x) (quotient (remainder (- x 524328) 128) 8))7506(define (inx-offset x)7507 (- (modulo (+ (quotient (- x 524328) 128) 128) 256) 128))7508(define (make-freg num) (+ 557096 num))7509(define (freg? x) (and (integer? x) (>= x 557096) (< x 557104)))7510(define (freg-num x) (- x 557096))7511(define (make-pcr lbl offset)7512 (+ 557104 (+ (modulo offset 65536) (* lbl 65536))))7513(define (pcr? x) (and (integer? x) (>= x 557104)))7514(define (pcr-lbl x) (quotient (- x 557104) 65536))7515(define (pcr-offset x) (- (modulo (- x 524336) 65536) 32768))7516(define (make-imm val) (if (< val 0) (* val 2) (- -1 (* val 2))))7517(define (imm? x) (and (integer? x) (< x 0)))7518(define (imm-val x) (if (even? x) (quotient x 2) (- (quotient x 2))))7519(define (make-glob name) name)7520(define (glob? x) (symbol? x))7521(define (glob-name x) x)7522(define (make-frame-base-rel slot) (make-disp sp-reg slot))7523(define (frame-base-rel? x)7524 (and (disp? x) (identical-opnd68? sp-reg (disp-areg x))))7525(define (frame-base-rel-slot x) (disp-offset x))7526(define (make-reg-list regs) regs)7527(define (reg-list? x) (or (pair? x) (null? x)))7528(define (reg-list-regs x) x)7529(define first-dtemp 0)7530(define gvm-reg1 1)7531(define poll-timer-reg (make-dreg 5))7532(define null-reg (make-dreg 6))7533(define placeholder-reg (make-dreg 6))7534(define false-reg (make-dreg 7))7535(define pair-reg (make-dreg 7))7536(define gvm-reg0 0)7537(define first-atemp 1)7538(define heap-reg (make-areg 3))7539(define ltq-tail-reg (make-areg 4))7540(define pstate-reg (make-areg 5))7541(define table-reg (make-areg 6))7542(define sp-reg (make-areg 7))7543(define pdec-sp (make-pdec sp-reg))7544(define pinc-sp (make-pinc sp-reg))7545(define dtemp1 (make-dreg first-dtemp))7546(define atemp1 (make-areg first-atemp))7547(define atemp2 (make-areg (+ first-atemp 1)))7548(define ftemp1 (make-freg 0))7549(define arg-count-reg dtemp1)7550(define (trap-offset n) (+ 32768 (* (- n 32) 8)))7551(define (emit-move.l opnd1 opnd2)7552 (let ((src (opnd->mode/reg opnd1)) (dst (opnd->reg/mode opnd2)))7553 (asm-word (+ 8192 (+ dst src)))7554 (opnd-ext-rd-long opnd1)7555 (opnd-ext-wr-long opnd2)7556 (if ofile-asm?7557 (emit-asm "movl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2)))))7558(define (emit-move.w opnd1 opnd2)7559 (let ((src (opnd->mode/reg opnd1)) (dst (opnd->reg/mode opnd2)))7560 (asm-word (+ 12288 (+ dst src)))7561 (opnd-ext-rd-word opnd1)7562 (opnd-ext-wr-word opnd2)7563 (if ofile-asm?7564 (emit-asm "movw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2)))))7565(define (emit-move.b opnd1 opnd2)7566 (let ((src (opnd->mode/reg opnd1)) (dst (opnd->reg/mode opnd2)))7567 (asm-word (+ 4096 (+ dst src)))7568 (opnd-ext-rd-word opnd1)7569 (opnd-ext-wr-word opnd2)7570 (if ofile-asm?7571 (emit-asm "movb" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2)))))7572(define (emit-moveq n opnd)7573 (asm-word (+ 28672 (+ (* (dreg-num opnd) 512) (modulo n 256))))7574 (if ofile-asm? (emit-asm "moveq" ofile-tab "#" n "," (opnd-str opnd))))7575(define (emit-movem.l opnd1 opnd2)7576 (define (reg-mask reg-list flip-bits?)7577 (let loop ((i 15) (bit 32768) (mask 0))7578 (if (>= i 0)7579 (loop (- i 1)7580 (quotient bit 2)7581 (if (memq i reg-list)7582 (+ mask (if flip-bits? (quotient 32768 bit) bit))7583 mask))7584 mask)))7585 (define (movem op reg-list opnd)7586 (asm-word (+ op (opnd->mode/reg opnd)))7587 (asm-word (reg-mask reg-list (pdec? opnd))))7588 (if (reg-list? opnd1)7589 (begin (movem 18624 opnd1 opnd2) (opnd-ext-wr-long opnd2))7590 (begin (movem 19648 opnd2 opnd1) (opnd-ext-rd-long opnd1)))7591 (if ofile-asm?7592 (emit-asm "moveml" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))7593(define (emit-exg opnd1 opnd2)7594 (define (exg r1 r2)7595 (let ((mode (if (dreg? r2) 49472 (if (dreg? r1) 49544 49480)))7596 (num1 (if (dreg? r1) (dreg-num r1) (areg-num r1)))7597 (num2 (if (dreg? r2) (dreg-num r2) (areg-num r2))))7598 (asm-word (+ mode (+ (* num1 512) num2)))))7599 (if (dreg? opnd2) (exg opnd2 opnd1) (exg opnd1 opnd2))7600 (if ofile-asm?7601 (emit-asm "exg" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))7602(define (emit-eor.l opnd1 opnd2)7603 (cond ((imm? opnd1)7604 (asm-word (+ 2688 (opnd->mode/reg opnd2)))7605 (opnd-ext-rd-long opnd1)7606 (opnd-ext-wr-long opnd2))7607 (else7608 (asm-word7609 (+ 45440 (+ (* (dreg-num opnd1) 512) (opnd->mode/reg opnd2))))7610 (opnd-ext-wr-long opnd2)))7611 (if ofile-asm?7612 (emit-asm "eorl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))7613(define (emit-and.l opnd1 opnd2)7614 (cond ((imm? opnd1)7615 (asm-word (+ 640 (opnd->mode/reg opnd2)))7616 (opnd-ext-rd-long opnd1)7617 (opnd-ext-wr-long opnd2))7618 (else7619 (let ((mode (if (dreg? opnd2) 49280 49536))7620 (reg (if (dreg? opnd2) (dreg-num opnd2) (dreg-num opnd1)))7621 (other (if (dreg? opnd2) opnd1 opnd2)))7622 (asm-word (+ mode (+ (* reg 512) (opnd->mode/reg other))))7623 (if (dreg? opnd2)7624 (opnd-ext-rd-long other)7625 (opnd-ext-wr-long other)))))7626 (if ofile-asm?7627 (emit-asm "andl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))7628(define (emit-and.w opnd1 opnd2)7629 (cond ((imm? opnd1)7630 (asm-word (+ 576 (opnd->mode/reg opnd2)))7631 (opnd-ext-rd-word opnd1)7632 (opnd-ext-wr-word opnd2))7633 (else7634 (let ((mode (if (dreg? opnd2) 49216 49472))7635 (reg (if (dreg? opnd2) (dreg-num opnd2) (dreg-num opnd1)))7636 (other (if (dreg? opnd2) opnd1 opnd2)))7637 (asm-word (+ mode (+ (* reg 512) (opnd->mode/reg other))))7638 (if (dreg? opnd2)7639 (opnd-ext-rd-word other)7640 (opnd-ext-wr-word other)))))7641 (if ofile-asm?7642 (emit-asm "andw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))7643(define (emit-or.l opnd1 opnd2)7644 (cond ((imm? opnd1)7645 (asm-word (+ 128 (opnd->mode/reg opnd2)))7646 (opnd-ext-rd-long opnd1)7647 (opnd-ext-wr-long opnd2))7648 (else7649 (let ((mode (if (dreg? opnd2) 32896 33152))7650 (reg (if (dreg? opnd2) (dreg-num opnd2) (dreg-num opnd1)))7651 (other (if (dreg? opnd2) opnd1 opnd2)))7652 (asm-word (+ mode (+ (* reg 512) (opnd->mode/reg other))))7653 (if (dreg? opnd2)7654 (opnd-ext-rd-long other)7655 (opnd-ext-wr-long other)))))7656 (if ofile-asm?7657 (emit-asm "orl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))7658(define (emit-addq.l n opnd)7659 (let ((m (if (= n 8) 0 n)))7660 (asm-word (+ 20608 (* m 512) (opnd->mode/reg opnd)))7661 (opnd-ext-wr-long opnd)7662 (if ofile-asm? (emit-asm "addql" ofile-tab "#" n "," (opnd-str opnd)))))7663(define (emit-addq.w n opnd)7664 (let ((m (if (= n 8) 0 n)))7665 (asm-word (+ 20544 (* m 512) (opnd->mode/reg opnd)))7666 (opnd-ext-wr-word opnd)7667 (if ofile-asm? (emit-asm "addqw" ofile-tab "#" n "," (opnd-str opnd)))))7668(define (emit-add.l opnd1 opnd2)7669 (cond ((areg? opnd2)7670 (asm-word7671 (+ 53696 (+ (* (areg-num opnd2) 512) (opnd->mode/reg opnd1))))7672 (opnd-ext-rd-long opnd1))7673 ((imm? opnd1)7674 (asm-word (+ 1664 (opnd->mode/reg opnd2)))7675 (opnd-ext-rd-long opnd1)7676 (opnd-ext-wr-long opnd2))7677 (else7678 (let ((mode (if (dreg? opnd2) 53376 53632))7679 (reg (if (dreg? opnd2) (dreg-num opnd2) (dreg-num opnd1)))7680 (other (if (dreg? opnd2) opnd1 opnd2)))7681 (asm-word (+ mode (+ (* reg 512) (opnd->mode/reg other))))7682 (if (dreg? opnd2)7683 (opnd-ext-rd-long other)7684 (opnd-ext-wr-long other)))))7685 (if ofile-asm?7686 (emit-asm "addl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))7687(define (emit-add.w opnd1 opnd2)7688 (cond ((areg? opnd2)7689 (asm-word7690 (+ 53440 (+ (* (areg-num opnd2) 512) (opnd->mode/reg opnd1))))7691 (opnd-ext-rd-word opnd1))7692 ((imm? opnd1)7693 (asm-word (+ 1600 (opnd->mode/reg opnd2)))7694 (opnd-ext-rd-word opnd1)7695 (opnd-ext-wr-word opnd2))7696 (else7697 (let ((mode (if (dreg? opnd2) 53312 53568))7698 (reg (if (dreg? opnd2) (dreg-num opnd2) (dreg-num opnd1)))7699 (other (if (dreg? opnd2) opnd1 opnd2)))7700 (asm-word (+ mode (+ (* reg 512) (opnd->mode/reg other))))7701 (if (dreg? opnd2)7702 (opnd-ext-rd-word other)7703 (opnd-ext-wr-word other)))))7704 (if ofile-asm?7705 (emit-asm "addw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))7706(define (emit-addx.w opnd1 opnd2)7707 (if (dreg? opnd1)7708 (asm-word (+ 53568 (+ (* (dreg-num opnd2) 512) (dreg-num opnd1))))7709 (asm-word7710 (+ 535767711 (+ (* (areg-num (pdec-areg opnd2)) 512)7712 (areg-num (pdec-areg opnd1))))))7713 (if ofile-asm?7714 (emit-asm "addxw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))7715(define (emit-subq.l n opnd)7716 (let ((m (if (= n 8) 0 n)))7717 (asm-word (+ 20864 (* m 512) (opnd->mode/reg opnd)))7718 (opnd-ext-wr-long opnd)7719 (if ofile-asm? (emit-asm "subql" ofile-tab "#" n "," (opnd-str opnd)))))7720(define (emit-subq.w n opnd)7721 (let ((m (if (= n 8) 0 n)))7722 (asm-word (+ 20800 (* m 512) (opnd->mode/reg opnd)))7723 (opnd-ext-wr-word opnd)7724 (if ofile-asm? (emit-asm "subqw" ofile-tab "#" n "," (opnd-str opnd)))))7725(define (emit-sub.l opnd1 opnd2)7726 (cond ((areg? opnd2)7727 (asm-word7728 (+ 37312 (+ (* (areg-num opnd2) 512) (opnd->mode/reg opnd1))))7729 (opnd-ext-rd-long opnd1))7730 ((imm? opnd1)7731 (asm-word (+ 1152 (opnd->mode/reg opnd2)))7732 (opnd-ext-rd-long opnd1)7733 (opnd-ext-wr-long opnd2))7734 (else7735 (let ((mode (if (dreg? opnd2) 36992 37248))7736 (reg (if (dreg? opnd2) (dreg-num opnd2) (dreg-num opnd1)))7737 (other (if (dreg? opnd2) opnd1 opnd2)))7738 (asm-word (+ mode (+ (* reg 512) (opnd->mode/reg other))))7739 (if (dreg? opnd2)7740 (opnd-ext-rd-long other)7741 (opnd-ext-wr-long other)))))7742 (if ofile-asm?7743 (emit-asm "subl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))7744(define (emit-sub.w opnd1 opnd2)7745 (cond ((areg? opnd2)7746 (asm-word7747 (+ 37056 (+ (* (areg-num opnd2) 512) (opnd->mode/reg opnd1))))7748 (opnd-ext-rd-word opnd1))7749 ((imm? opnd1)7750 (asm-word (+ 1088 (opnd->mode/reg opnd2)))7751 (opnd-ext-rd-word opnd1)7752 (opnd-ext-wr-word opnd2))7753 (else7754 (let ((mode (if (dreg? opnd2) 36928 37184))7755 (reg (if (dreg? opnd2) (dreg-num opnd2) (dreg-num opnd1)))7756 (other (if (dreg? opnd2) opnd1 opnd2)))7757 (asm-word (+ mode (+ (* reg 512) (opnd->mode/reg other))))7758 (if (dreg? opnd2)7759 (opnd-ext-rd-word other)7760 (opnd-ext-wr-word other)))))7761 (if ofile-asm?7762 (emit-asm "subw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))7763(define (emit-asl.l opnd1 opnd2)7764 (if (dreg? opnd1)7765 (asm-word (+ 57760 (+ (* (dreg-num opnd1) 512) (dreg-num opnd2))))7766 (let ((n (imm-val opnd1)))7767 (asm-word (+ 57728 (+ (* (if (= n 8) 0 n) 512) (dreg-num opnd2))))))7768 (if ofile-asm?7769 (emit-asm "asll" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))7770(define (emit-asl.w opnd1 opnd2)7771 (if (dreg? opnd1)7772 (asm-word (+ 57696 (+ (* (dreg-num opnd1) 512) (dreg-num opnd2))))7773 (let ((n (imm-val opnd1)))7774 (asm-word (+ 57664 (+ (* (if (= n 8) 0 n) 512) (dreg-num opnd2))))))7775 (if ofile-asm?7776 (emit-asm "aslw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))7777(define (emit-asr.l opnd1 opnd2)7778 (if (dreg? opnd1)7779 (asm-word (+ 57504 (+ (* (dreg-num opnd1) 512) (dreg-num opnd2))))7780 (let ((n (imm-val opnd1)))7781 (asm-word (+ 57472 (+ (* (if (= n 8) 0 n) 512) (dreg-num opnd2))))))7782 (if ofile-asm?7783 (emit-asm "asrl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))7784(define (emit-asr.w opnd1 opnd2)7785 (if (dreg? opnd1)7786 (asm-word (+ 57440 (+ (* (dreg-num opnd1) 512) (dreg-num opnd2))))7787 (let ((n (imm-val opnd1)))7788 (asm-word (+ 57408 (+ (* (if (= n 8) 0 n) 512) (dreg-num opnd2))))))7789 (if ofile-asm?7790 (emit-asm "asrw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))7791(define (emit-lsl.l opnd1 opnd2)7792 (if (dreg? opnd1)7793 (asm-word (+ 57768 (+ (* (dreg-num opnd1) 512) (dreg-num opnd2))))7794 (let ((n (imm-val opnd1)))7795 (asm-word (+ 57736 (+ (* (if (= n 8) 0 n) 512) (dreg-num opnd2))))))7796 (if ofile-asm?7797 (emit-asm "lsll" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))7798(define (emit-lsr.l opnd1 opnd2)7799 (if (dreg? opnd1)7800 (asm-word (+ 57512 (+ (* (dreg-num opnd1) 512) (dreg-num opnd2))))7801 (let ((n (imm-val opnd1)))7802 (asm-word (+ 57480 (+ (* (if (= n 8) 0 n) 512) (dreg-num opnd2))))))7803 (if ofile-asm?7804 (emit-asm "lsrl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))7805(define (emit-lsr.w opnd1 opnd2)7806 (if (dreg? opnd1)7807 (asm-word (+ 57448 (+ (* (dreg-num opnd1) 512) (dreg-num opnd2))))7808 (let ((n (imm-val opnd1)))7809 (asm-word (+ 57416 (+ (* (if (= n 8) 0 n) 512) (dreg-num opnd2))))))7810 (if ofile-asm?7811 (emit-asm "lsrw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))7812(define (emit-clr.l opnd)7813 (asm-word (+ 17024 (opnd->mode/reg opnd)))7814 (opnd-ext-wr-long opnd)7815 (if ofile-asm? (emit-asm "clrl" ofile-tab (opnd-str opnd))))7816(define (emit-neg.l opnd)7817 (asm-word (+ 17536 (opnd->mode/reg opnd)))7818 (opnd-ext-wr-long opnd)7819 (if ofile-asm? (emit-asm "negl" ofile-tab (opnd-str opnd))))7820(define (emit-not.l opnd)7821 (asm-word (+ 18048 (opnd->mode/reg opnd)))7822 (opnd-ext-wr-long opnd)7823 (if ofile-asm? (emit-asm "notl" ofile-tab (opnd-str opnd))))7824(define (emit-ext.l opnd)7825 (asm-word (+ 18624 (dreg-num opnd)))7826 (if ofile-asm? (emit-asm "extl" ofile-tab (opnd-str opnd))))7827(define (emit-ext.w opnd)7828 (asm-word (+ 18560 (dreg-num opnd)))7829 (if ofile-asm? (emit-asm "extw" ofile-tab (opnd-str opnd))))7830(define (emit-swap opnd)7831 (asm-word (+ 18496 (dreg-num opnd)))7832 (if ofile-asm? (emit-asm "swap" ofile-tab (opnd-str opnd))))7833(define (emit-cmp.l opnd1 opnd2)7834 (cond ((areg? opnd2)7835 (asm-word7836 (+ 45504 (+ (* (areg-num opnd2) 512) (opnd->mode/reg opnd1))))7837 (opnd-ext-rd-long opnd1))7838 ((imm? opnd1)7839 (asm-word (+ 3200 (opnd->mode/reg opnd2)))7840 (opnd-ext-rd-long opnd1)7841 (opnd-ext-rd-long opnd2))7842 (else7843 (asm-word7844 (+ 45184 (+ (* (dreg-num opnd2) 512) (opnd->mode/reg opnd1))))7845 (opnd-ext-rd-long opnd1)))7846 (if ofile-asm?7847 (emit-asm "cmpl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))7848(define (emit-cmp.w opnd1 opnd2)7849 (cond ((areg? opnd2)7850 (asm-word7851 (+ 45248 (+ (* (areg-num opnd2) 512) (opnd->mode/reg opnd1))))7852 (opnd-ext-rd-word opnd1))7853 ((imm? opnd1)7854 (asm-word (+ 3136 (opnd->mode/reg opnd2)))7855 (opnd-ext-rd-word opnd1)7856 (opnd-ext-rd-word opnd2))7857 (else7858 (asm-word7859 (+ 45120 (+ (* (dreg-num opnd2) 512) (opnd->mode/reg opnd1))))7860 (opnd-ext-rd-word opnd1)))7861 (if ofile-asm?7862 (emit-asm "cmpw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))7863(define (emit-cmp.b opnd1 opnd2)7864 (cond ((imm? opnd1)7865 (asm-word (+ 3072 (opnd->mode/reg opnd2)))7866 (opnd-ext-rd-word opnd1)7867 (opnd-ext-rd-word opnd2))7868 (else7869 (asm-word7870 (+ 45056 (+ (* (dreg-num opnd2) 512) (opnd->mode/reg opnd1))))7871 (opnd-ext-rd-word opnd1)))7872 (if ofile-asm?7873 (emit-asm "cmpb" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))7874(define (emit-tst.l opnd)7875 (asm-word (+ 19072 (opnd->mode/reg opnd)))7876 (opnd-ext-rd-long opnd)7877 (if ofile-asm? (emit-asm "tstl" ofile-tab (opnd-str opnd))))7878(define (emit-tst.w opnd)7879 (asm-word (+ 19008 (opnd->mode/reg opnd)))7880 (opnd-ext-rd-word opnd)7881 (if ofile-asm? (emit-asm "tstw" ofile-tab (opnd-str opnd))))7882(define (emit-lea opnd areg)7883 (asm-word (+ 16832 (+ (* (areg-num areg) 512) (opnd->mode/reg opnd))))7884 (opnd-ext-rd-long opnd)7885 (if ofile-asm?7886 (emit-asm "lea" ofile-tab (opnd-str opnd) "," (opnd-str areg))))7887(define (emit-unlk areg)7888 (asm-word (+ 20056 (areg-num areg)))7889 (if ofile-asm? (emit-asm "unlk" ofile-tab (opnd-str areg))))7890(define (emit-move-proc num opnd)7891 (let ((dst (opnd->reg/mode opnd)))7892 (asm-word (+ 8192 (+ dst 60)))7893 (asm-proc-ref num 0)7894 (opnd-ext-wr-long opnd)7895 (if ofile-asm? (emit-asm "MOVE_PROC(" num "," (opnd-str opnd) ")"))))7896(define (emit-move-prim val opnd)7897 (let ((dst (opnd->reg/mode opnd)))7898 (asm-word (+ 8192 (+ dst 60)))7899 (asm-prim-ref val 0)7900 (opnd-ext-wr-long opnd)7901 (if ofile-asm?7902 (emit-asm "MOVE_PRIM(" (proc-obj-name val) "," (opnd-str opnd) ")"))))7903(define (emit-pea opnd)7904 (asm-word (+ 18496 (opnd->mode/reg opnd)))7905 (opnd-ext-rd-long opnd)7906 (if ofile-asm? (emit-asm "pea" ofile-tab (opnd-str opnd))))7907(define (emit-pea* n)7908 (asm-word 18552)7909 (asm-word n)7910 (if ofile-asm? (emit-asm "pea" ofile-tab n)))7911(define (emit-btst opnd1 opnd2)7912 (asm-word (+ 256 (+ (* (dreg-num opnd1) 512) (opnd->mode/reg opnd2))))7913 (opnd-ext-rd-word opnd2)7914 (if ofile-asm?7915 (emit-asm "btst" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))7916(define (emit-bra lbl)7917 (asm-brel 24576 lbl)7918 (if ofile-asm? (emit-asm "bra" ofile-tab "L" lbl)))7919(define (emit-bcc lbl)7920 (asm-brel 25600 lbl)7921 (if ofile-asm? (emit-asm "bcc" ofile-tab "L" lbl)))7922(define (emit-bcs lbl)7923 (asm-brel 25856 lbl)7924 (if ofile-asm? (emit-asm "bcs" ofile-tab "L" lbl)))7925(define (emit-bhi lbl)7926 (asm-brel 25088 lbl)7927 (if ofile-asm? (emit-asm "bhi" ofile-tab "L" lbl)))7928(define (emit-bls lbl)7929 (asm-brel 25344 lbl)7930 (if ofile-asm? (emit-asm "bls" ofile-tab "L" lbl)))7931(define (emit-bmi lbl)7932 (asm-brel 27392 lbl)7933 (if ofile-asm? (emit-asm "bmi" ofile-tab "L" lbl)))7934(define (emit-bpl lbl)7935 (asm-brel 27136 lbl)7936 (if ofile-asm? (emit-asm "bpl" ofile-tab "L" lbl)))7937(define (emit-beq lbl)7938 (asm-brel 26368 lbl)7939 (if ofile-asm? (emit-asm "beq" ofile-tab "L" lbl)))7940(define (emit-bne lbl)7941 (asm-brel 26112 lbl)7942 (if ofile-asm? (emit-asm "bne" ofile-tab "L" lbl)))7943(define (emit-blt lbl)7944 (asm-brel 27904 lbl)7945 (if ofile-asm? (emit-asm "blt" ofile-tab "L" lbl)))7946(define (emit-bgt lbl)7947 (asm-brel 28160 lbl)7948 (if ofile-asm? (emit-asm "bgt" ofile-tab "L" lbl)))7949(define (emit-ble lbl)7950 (asm-brel 28416 lbl)7951 (if ofile-asm? (emit-asm "ble" ofile-tab "L" lbl)))7952(define (emit-bge lbl)7953 (asm-brel 27648 lbl)7954 (if ofile-asm? (emit-asm "bge" ofile-tab "L" lbl)))7955(define (emit-dbra dreg lbl)7956 (asm-word (+ 20936 dreg))7957 (asm-wrel lbl 0)7958 (if ofile-asm? (emit-asm "dbra" ofile-tab (opnd-str dreg) ",L" lbl)))7959(define (emit-trap num)7960 (asm-word (+ 20032 num))7961 (if ofile-asm? (emit-asm "trap" ofile-tab "#" num)))7962(define (emit-trap1 num args)7963 (asm-word (+ 20136 (areg-num table-reg)))7964 (asm-word (trap-offset num))7965 (let loop ((args args))7966 (if (not (null? args)) (begin (asm-word (car args)) (loop (cdr args)))))7967 (if ofile-asm?7968 (let ()7969 (define (words l)7970 (if (null? l) (list ")") (cons "," (cons (car l) (words (cdr l))))))7971 (apply emit-asm (cons "TRAP1(" (cons num (words args)))))))7972(define (emit-trap2 num args)7973 (asm-word (+ 20136 (areg-num table-reg)))7974 (asm-word (trap-offset num))7975 (asm-align 8 (modulo (- 4 (* (length args) 2)) 8))7976 (let loop ((args args))7977 (if (not (null? args)) (begin (asm-word (car args)) (loop (cdr args)))))7978 (if ofile-asm?7979 (let ()7980 (define (words l)7981 (if (null? l) (list ")") (cons "," (cons (car l) (words (cdr l))))))7982 (apply emit-asm (cons "TRAP2(" (cons num (words args)))))))7983(define (emit-trap3 num)7984 (asm-word (+ 20200 (areg-num table-reg)))7985 (asm-word (trap-offset num))7986 (if ofile-asm? (emit-asm "TRAP3(" num ")")))7987(define (emit-rts) (asm-word 20085) (if ofile-asm? (emit-asm "rts")))7988(define (emit-nop) (asm-word 20081) (if ofile-asm? (emit-asm "nop")))7989(define (emit-jmp opnd)7990 (asm-word (+ 20160 (opnd->mode/reg opnd)))7991 (opnd-ext-rd-long opnd)7992 (if ofile-asm? (emit-asm "jmp" ofile-tab (opnd-str opnd))))7993(define (emit-jmp-glob glob)7994 (asm-word 8814)7995 (asm-ref-glob-jump glob)7996 (asm-word 20177)7997 (if ofile-asm? (emit-asm "JMP_GLOB(" (glob-name glob) ")")))7998(define (emit-jmp-proc num offset)7999 (asm-word 20217)8000 (asm-proc-ref num offset)8001 (if ofile-asm? (emit-asm "JMP_PROC(" num "," offset ")")))8002(define (emit-jmp-prim val offset)8003 (asm-word 20217)8004 (asm-prim-ref val offset)8005 (if ofile-asm? (emit-asm "JMP_PRIM(" (proc-obj-name val) "," offset ")")))8006(define (emit-jsr opnd)8007 (asm-word (+ 20096 (opnd->mode/reg opnd)))8008 (opnd-ext-rd-long opnd)8009 (if ofile-asm? (emit-asm "jsr" ofile-tab (opnd-str opnd))))8010(define (emit-word n)8011 (asm-word n)8012 (if ofile-asm? (emit-asm ".word" ofile-tab n)))8013(define (emit-label lbl)8014 (asm-label lbl #f)8015 (if ofile-asm? (emit-asm* "L" lbl ":")))8016(define (emit-label-subproc lbl parent-lbl label-descr)8017 (asm-align 8 0)8018 (asm-wrel parent-lbl (- 32768 type-procedure))8019 (asm-label lbl label-descr)8020 (if ofile-asm?8021 (begin (emit-asm "SUBPROC(L" parent-lbl ")") (emit-asm* "L" lbl ":"))))8022(define (emit-label-return lbl parent-lbl fs link label-descr)8023 (asm-align 8 4)8024 (asm-word (* fs 4))8025 (asm-word (* (- fs link) 4))8026 (asm-wrel parent-lbl (- 32768 type-procedure))8027 (asm-label lbl label-descr)8028 (if ofile-asm?8029 (begin8030 (emit-asm "RETURN(L" parent-lbl "," fs "," link ")")8031 (emit-asm* "L" lbl ":"))))8032(define (emit-label-task-return lbl parent-lbl fs link label-descr)8033 (asm-align 8 4)8034 (asm-word (+ 32768 (* fs 4)))8035 (asm-word (* (- fs link) 4))8036 (asm-wrel parent-lbl (- 32768 type-procedure))8037 (asm-label lbl label-descr)8038 (if ofile-asm?8039 (begin8040 (emit-asm "TASK_RETURN(L" parent-lbl "," fs "," link ")")8041 (emit-asm* "L" lbl ":"))))8042(define (emit-lbl-ptr lbl)8043 (asm-wrel lbl 0)8044 (if ofile-asm? (emit-asm "LBL_PTR(L" lbl ")")))8045(define (emit-set-glob glob)8046 (asm-set-glob glob)8047 (if ofile-asm? (emit-asm "SET_GLOB(" (glob-name glob) ")")))8048(define (emit-const obj)8049 (let ((n (pos-in-list obj (queue->list asm-const-queue))))8050 (if n8051 (make-pcr const-lbl (* n 4))8052 (let ((m (length (queue->list asm-const-queue))))8053 (queue-put! asm-const-queue obj)8054 (make-pcr const-lbl (* m 4))))))8055(define (emit-stat stat)8056 (asm-word 21177)8057 (asm-stat stat)8058 (if ofile-asm? (emit-asm "STAT(" stat ")")))8059(define (emit-asm . l) (asm-comment (cons ofile-tab l)))8060(define (emit-asm* . l) (asm-comment l))8061(define (emit-muls.l opnd1 opnd2)8062 (asm-m68020-proc)8063 (asm-word (+ 19456 (opnd->mode/reg opnd1)))8064 (asm-word (+ 2048 (* (dreg-num opnd2) 4096)))8065 (opnd-ext-rd-long opnd1)8066 (if ofile-asm?8067 (emit-asm "mulsl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))8068(define (emit-divsl.l opnd1 opnd2 opnd3)8069 (asm-m68020-proc)8070 (asm-word (+ 19520 (opnd->mode/reg opnd1)))8071 (asm-word (+ 2048 (* (dreg-num opnd3) 4096) (dreg-num opnd2)))8072 (opnd-ext-rd-long opnd1)8073 (if ofile-asm?8074 (emit-asm8075 "divsll"8076 ofile-tab8077 (opnd-str opnd1)8078 ","8079 (opnd-str opnd2)8080 ":"8081 (opnd-str opnd3))))8082(define (emit-fint.dx opnd1 opnd2) (emit-fop.dx "int" 1 opnd1 opnd2))8083(define (emit-fsinh.dx opnd1 opnd2) (emit-fop.dx "sinh" 2 opnd1 opnd2))8084(define (emit-fintrz.dx opnd1 opnd2) (emit-fop.dx "intrz" 3 opnd1 opnd2))8085(define (emit-fsqrt.dx opnd1 opnd2) (emit-fop.dx "sqrt" 4 opnd1 opnd2))8086(define (emit-flognp1.dx opnd1 opnd2) (emit-fop.dx "lognp1" 6 opnd1 opnd2))8087(define (emit-fetoxm1.dx opnd1 opnd2) (emit-fop.dx "etoxm1" 8 opnd1 opnd2))8088(define (emit-ftanh.dx opnd1 opnd2) (emit-fop.dx "tanh" 9 opnd1 opnd2))8089(define (emit-fatan.dx opnd1 opnd2) (emit-fop.dx "atan" 10 opnd1 opnd2))8090(define (emit-fasin.dx opnd1 opnd2) (emit-fop.dx "asin" 12 opnd1 opnd2))8091(define (emit-fatanh.dx opnd1 opnd2) (emit-fop.dx "atanh" 13 opnd1 opnd2))8092(define (emit-fsin.dx opnd1 opnd2) (emit-fop.dx "sin" 14 opnd1 opnd2))8093(define (emit-ftan.dx opnd1 opnd2) (emit-fop.dx "tan" 15 opnd1 opnd2))8094(define (emit-fetox.dx opnd1 opnd2) (emit-fop.dx "etox" 16 opnd1 opnd2))8095(define (emit-ftwotox.dx opnd1 opnd2) (emit-fop.dx "twotox" 17 opnd1 opnd2))8096(define (emit-ftentox.dx opnd1 opnd2) (emit-fop.dx "tentox" 18 opnd1 opnd2))8097(define (emit-flogn.dx opnd1 opnd2) (emit-fop.dx "logn" 20 opnd1 opnd2))8098(define (emit-flog10.dx opnd1 opnd2) (emit-fop.dx "log10" 21 opnd1 opnd2))8099(define (emit-flog2.dx opnd1 opnd2) (emit-fop.dx "log2" 22 opnd1 opnd2))8100(define (emit-fabs.dx opnd1 opnd2) (emit-fop.dx "abs" 24 opnd1 opnd2))8101(define (emit-fcosh.dx opnd1 opnd2) (emit-fop.dx "cosh" 25 opnd1 opnd2))8102(define (emit-fneg.dx opnd1 opnd2) (emit-fop.dx "neg" 26 opnd1 opnd2))8103(define (emit-facos.dx opnd1 opnd2) (emit-fop.dx "acos" 28 opnd1 opnd2))8104(define (emit-fcos.dx opnd1 opnd2) (emit-fop.dx "cos" 29 opnd1 opnd2))8105(define (emit-fgetexp.dx opnd1 opnd2) (emit-fop.dx "getexp" 30 opnd1 opnd2))8106(define (emit-fgetman.dx opnd1 opnd2) (emit-fop.dx "getman" 31 opnd1 opnd2))8107(define (emit-fdiv.dx opnd1 opnd2) (emit-fop.dx "div" 32 opnd1 opnd2))8108(define (emit-fmod.dx opnd1 opnd2) (emit-fop.dx "mod" 33 opnd1 opnd2))8109(define (emit-fadd.dx opnd1 opnd2) (emit-fop.dx "add" 34 opnd1 opnd2))8110(define (emit-fmul.dx opnd1 opnd2) (emit-fop.dx "mul" 35 opnd1 opnd2))8111(define (emit-fsgldiv.dx opnd1 opnd2) (emit-fop.dx "sgldiv" 36 opnd1 opnd2))8112(define (emit-frem.dx opnd1 opnd2) (emit-fop.dx "rem" 37 opnd1 opnd2))8113(define (emit-fscale.dx opnd1 opnd2) (emit-fop.dx "scale" 38 opnd1 opnd2))8114(define (emit-fsglmul.dx opnd1 opnd2) (emit-fop.dx "sglmul" 39 opnd1 opnd2))8115(define (emit-fsub.dx opnd1 opnd2) (emit-fop.dx "sub" 40 opnd1 opnd2))8116(define (emit-fcmp.dx opnd1 opnd2) (emit-fop.dx "cmp" 56 opnd1 opnd2))8117(define (emit-fop.dx name code opnd1 opnd2)8118 (asm-m68881-proc)8119 (asm-word (+ 61952 (opnd->mode/reg opnd1)))8120 (asm-word8121 (+ (if (freg? opnd1) (* (freg-num opnd1) 1024) 21504)8122 (* (freg-num opnd2) 128)8123 code))8124 (opnd-ext-rd-long opnd1)8125 (if ofile-asm?8126 (emit-asm8127 "f"8128 name8129 (if (freg? opnd1) "x" "d")8130 ofile-tab8131 (opnd-str opnd1)8132 ","8133 (opnd-str opnd2))))8134(define (emit-fmov.dx opnd1 opnd2)8135 (emit-fmov8136 (if (and (freg? opnd1) (freg? opnd2)) (* (freg-num opnd1) 1024) 21504)8137 opnd18138 opnd2)8139 (if ofile-asm?8140 (emit-asm8141 (if (and (freg? opnd1) (freg? opnd2)) "fmovex" "fmoved")8142 ofile-tab8143 (opnd-str opnd1)8144 ","8145 (opnd-str opnd2))))8146(define (emit-fmov.l opnd1 opnd2)8147 (emit-fmov 16384 opnd1 opnd2)8148 (if ofile-asm?8149 (emit-asm "fmovel" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))8150(define (emit-fmov code opnd1 opnd2)8151 (define (fmov code opnd1 opnd2)8152 (asm-m68881-proc)8153 (asm-word (+ 61952 (opnd->mode/reg opnd1)))8154 (asm-word (+ (* (freg-num opnd2) 128) code))8155 (opnd-ext-rd-long opnd1))8156 (if (freg? opnd2) (fmov code opnd1 opnd2) (fmov (+ code 8192) opnd2 opnd1)))8157(define (emit-fbeq lbl)8158 (asm-m68881-proc)8159 (asm-word 62081)8160 (asm-wrel lbl 0)8161 (if ofile-asm? (emit-asm "fbeq" ofile-tab "L" lbl)))8162(define (emit-fbne lbl)8163 (asm-m68881-proc)8164 (asm-word 62094)8165 (asm-wrel lbl 0)8166 (if ofile-asm? (emit-asm "fbne" ofile-tab "L" lbl)))8167(define (emit-fblt lbl)8168 (asm-m68881-proc)8169 (asm-word 62100)8170 (asm-wrel lbl 0)8171 (if ofile-asm? (emit-asm "fblt" ofile-tab "L" lbl)))8172(define (emit-fbgt lbl)8173 (asm-m68881-proc)8174 (asm-word 62098)8175 (asm-wrel lbl 0)8176 (if ofile-asm? (emit-asm "fbgt" ofile-tab "L" lbl)))8177(define (emit-fble lbl)8178 (asm-m68881-proc)8179 (asm-word 62101)8180 (asm-wrel lbl 0)8181 (if ofile-asm? (emit-asm "fble" ofile-tab "L" lbl)))8182(define (emit-fbge lbl)8183 (asm-m68881-proc)8184 (asm-word 62099)8185 (asm-wrel lbl 0)8186 (if ofile-asm? (emit-asm "fbge" ofile-tab "L" lbl)))8187(define (opnd->mode/reg opnd)8188 (cond ((disp? opnd) (+ 32 (disp-areg opnd)))8189 ((inx? opnd) (+ 40 (inx-areg opnd)))8190 ((pcr? opnd) 58)8191 ((imm? opnd) 60)8192 ((glob? opnd) (+ 32 table-reg))8193 ((freg? opnd) 0)8194 (else opnd)))8195(define (opnd->reg/mode opnd)8196 (let ((x (opnd->mode/reg opnd)))8197 (* (+ (* 8 (remainder x 8)) (quotient x 8)) 64)))8198(define (opnd-ext-rd-long opnd) (opnd-extension opnd #f #f))8199(define (opnd-ext-rd-word opnd) (opnd-extension opnd #f #t))8200(define (opnd-ext-wr-long opnd) (opnd-extension opnd #t #f))8201(define (opnd-ext-wr-word opnd) (opnd-extension opnd #t #t))8202(define (opnd-extension opnd write? word?)8203 (cond ((disp? opnd) (asm-word (disp-offset opnd)))8204 ((inx? opnd)8205 (asm-word8206 (+ (+ (* (inx-ireg opnd) 4096) 2048)8207 (modulo (inx-offset opnd) 256))))8208 ((pcr? opnd) (asm-wrel (pcr-lbl opnd) (pcr-offset opnd)))8209 ((imm? opnd)8210 (if word? (asm-word (imm-val opnd)) (asm-long (imm-val opnd))))8211 ((glob? opnd) (if write? (asm-set-glob opnd) (asm-ref-glob opnd)))))8212(define (opnd-str opnd)8213 (cond ((dreg? opnd)8214 (vector-ref8215 '#("d0" "d1" "d2" "d3" "d4" "d5" "d6" "d7")8216 (dreg-num opnd)))8217 ((areg? opnd)8218 (vector-ref8219 '#("a0" "a1" "a2" "a3" "a4" "a5" "a6" "sp")8220 (areg-num opnd)))8221 ((ind? opnd)8222 (vector-ref8223 '#("a0@" "a1@" "a2@" "a3@" "a4@" "a5@" "a6@" "sp@")8224 (areg-num (ind-areg opnd))))8225 ((pinc? opnd)8226 (vector-ref8227 '#("a0@+" "a1@+" "a2@+" "a3@+" "a4@+" "a5@+" "a6@+" "sp@+")8228 (areg-num (pinc-areg opnd))))8229 ((pdec? opnd)8230 (vector-ref8231 '#("a0@-" "a1@-" "a2@-" "a3@-" "a4@-" "a5@-" "a6@-" "sp@-")8232 (areg-num (pdec-areg opnd))))8233 ((disp? opnd)8234 (string-append8235 (opnd-str (disp-areg opnd))8236 "@("8237 (number->string (disp-offset opnd))8238 ")"))8239 ((inx? opnd)8240 (string-append8241 (opnd-str (inx-areg opnd))8242 "@("8243 (number->string (inx-offset opnd))8244 ","8245 (opnd-str (inx-ireg opnd))8246 ":l)"))8247 ((pcr? opnd)8248 (let ((lbl (pcr-lbl opnd)) (offs (pcr-offset opnd)))8249 (if (= offs 0)8250 (string-append "L" (number->string lbl))8251 (string-append8252 "L"8253 (number->string lbl)8254 "+"8255 (number->string offs)))))8256 ((imm? opnd) (string-append "#" (number->string (imm-val opnd))))8257 ((glob? opnd)8258 (string-append "GLOB(" (symbol->string (glob-name opnd)) ")"))8259 ((freg? opnd)8260 (vector-ref8261 '#("fp0" "fp1" "fp2" "fp3" "fp4" "fp5" "fp6" "fp7")8262 (freg-num opnd)))8263 ((reg-list? opnd)8264 (let loop ((l (reg-list-regs opnd)) (result "[") (sep ""))8265 (if (pair? l)8266 (loop (cdr l) (string-append result sep (opnd-str (car l))) "/")8267 (string-append result "]"))))8268 (else (compiler-internal-error "opnd-str, unknown 'opnd'" opnd))))8269(define (begin! info-port targ)8270 (set! return-reg (make-reg 0))8271 (target-end!-set! targ end!)8272 (target-dump-set! targ dump)8273 (target-nb-regs-set! targ nb-gvm-regs)8274 (target-prim-info-set! targ prim-info)8275 (target-label-info-set! targ label-info)8276 (target-jump-info-set! targ jump-info)8277 (target-proc-result-set! targ (make-reg 1))8278 (target-task-return-set! targ return-reg)8279 (set! *info-port* info-port)8280 '())8281(define (end!) '())8282(define *info-port* '())8283(define nb-gvm-regs 5)8284(define nb-arg-regs 3)8285(define pointer-size 4)8286(define prim-proc-table8287 (map (lambda (x)8288 (cons (string->canonical-symbol (car x))8289 (apply make-proc-obj (car x) #t #f (cdr x))))8290 prim-procs))8291(define (prim-info name)8292 (let ((x (assq name prim-proc-table))) (if x (cdr x) #f)))8293(define (get-prim-info name)8294 (let ((proc (prim-info (string->canonical-symbol name))))8295 (if proc8296 proc8297 (compiler-internal-error "get-prim-info, unknown primitive:" name))))8298(define (label-info min-args nb-parms rest? closed?)8299 (let ((nb-stacked (max 0 (- nb-parms nb-arg-regs))))8300 (define (location-of-parms i)8301 (if (> i nb-parms)8302 '()8303 (cons (cons i8304 (if (> i nb-stacked)8305 (make-reg (- i nb-stacked))8306 (make-stk i)))8307 (location-of-parms (+ i 1)))))8308 (let ((x (cons (cons 'return 0) (location-of-parms 1))))8309 (make-pcontext8310 nb-stacked8311 (if closed?8312 (cons (cons 'closure-env (make-reg (+ nb-arg-regs 1))) x)8313 x)))))8314(define (jump-info nb-args)8315 (let ((nb-stacked (max 0 (- nb-args nb-arg-regs))))8316 (define (location-of-args i)8317 (if (> i nb-args)8318 '()8319 (cons (cons i8320 (if (> i nb-stacked)8321 (make-reg (- i nb-stacked))8322 (make-stk i)))8323 (location-of-args (+ i 1)))))8324 (make-pcontext8325 nb-stacked8326 (cons (cons 'return (make-reg 0)) (location-of-args 1)))))8327(define (closed-var-offset i) (+ (* i pointer-size) 2))8328(define (dump proc filename c-intf options)8329 (if *info-port*8330 (begin (display "Dumping:" *info-port*) (newline *info-port*)))8331 (set! ofile-asm? (memq 'asm options))8332 (set! ofile-stats? (memq 'stats options))8333 (set! debug-info? (memq 'debug options))8334 (set! object-queue (queue-empty))8335 (set! objects-dumped (queue-empty))8336 (ofile.begin! filename add-object)8337 (queue-put! object-queue proc)8338 (queue-put! objects-dumped proc)8339 (let loop ((index 0))8340 (if (not (queue-empty? object-queue))8341 (let ((obj (queue-get! object-queue)))8342 (dump-object obj index)8343 (loop (+ index 1)))))8344 (ofile.end!)8345 (if *info-port* (newline *info-port*))8346 (set! object-queue '())8347 (set! objects-dumped '()))8348(define debug-info? '())8349(define object-queue '())8350(define objects-dumped '())8351(define (add-object obj)8352 (if (and (proc-obj? obj) (not (proc-obj-code obj)))8353 #f8354 (let ((n (pos-in-list obj (queue->list objects-dumped))))8355 (if n8356 n8357 (let ((m (length (queue->list objects-dumped))))8358 (queue-put! objects-dumped obj)8359 (queue-put! object-queue obj)8360 m)))))8361(define (dump-object obj index)8362 (ofile-line "|------------------------------------------------------")8363 (case (obj-type obj)8364 ((pair) (dump-pair obj))8365 ((flonum) (dump-flonum obj))8366 ((subtyped)8367 (case (obj-subtype obj)8368 ((vector) (dump-vector obj))8369 ((symbol) (dump-symbol obj))8370;; ((ratnum) (dump-ratnum obj))8371;; ((cpxnum) (dump-cpxnum obj))8372 ((string) (dump-string obj))8373 ((bignum) (dump-bignum obj))8374 (else8375 (compiler-internal-error8376 "dump-object, can't dump object 'obj':"8377 obj))))8378 ((procedure) (dump-procedure obj))8379 (else8380 (compiler-internal-error "dump-object, can't dump object 'obj':" obj))))8381(define (dump-pair pair)8382 (ofile-long pair-prefix)8383 (ofile-ref (cdr pair))8384 (ofile-ref (car pair)))8385(define (dump-vector v)8386 (ofile-long (+ (* (vector-length v) 1024) (* subtype-vector 8)))8387 (let ((len (vector-length v)))8388 (let loop ((i 0))8389 (if (< i len) (begin (ofile-ref (vector-ref v i)) (loop (+ i 1)))))))8390(define (dump-symbol sym)8391 (compiler-internal-error "dump-symbol, can't dump SYMBOL type"))8392;;(define (dump-ratnum x)8393;; (ofile-long (+ (* 2 1024) (* subtype-ratnum 8)))8394;; (ofile-ref (numerator x))8395;; (ofile-ref (denominator x)))8396;;(define (dump-cpxnum x)8397;; (ofile-long (+ (* 2 1024) (* subtype-cpxnum 8)))8398;; (ofile-ref (real-part x))8399;; (ofile-ref (imag-part x)))8400(define (dump-string s)8401 (ofile-long (+ (* (+ (string-length s) 1) 256) (* subtype-string 8)))8402 (let ((len (string-length s)))8403 (define (ref i) (if (>= i len) 0 (character-encoding (string-ref s i))))8404 (let loop ((i 0))8405 (if (<= i len)8406 (begin8407 (ofile-word (+ (* (ref i) 256) (ref (+ i 1))))8408 (loop (+ i 2)))))))8409(define (dump-flonum x)8410 (let ((bits (flonum->bits x)))8411 (ofile-long flonum-prefix)8412 (ofile-long (quotient bits 4294967296))8413 (ofile-long (modulo bits 4294967296))))8414(define (flonum->inexact-exponential-format x)8415 (define (exp-form-pos x y i)8416 (let ((i*2 (+ i i)))8417 (let ((z (if (and (not (< flonum-e-bias i*2)) (not (< x y)))8418 (exp-form-pos x (* y y) i*2)8419 (cons x 0))))8420 (let ((a (car z)) (b (cdr z)))8421 (let ((i+b (+ i b)))8422 (if (and (not (< flonum-e-bias i+b)) (not (< a y)))8423 (begin (set-car! z (/ a y)) (set-cdr! z i+b)))8424 z)))))8425 (define (exp-form-neg x y i)8426 (let ((i*2 (+ i i)))8427 (let ((z (if (and (< i*2 flonum-e-bias-minus-1) (< x y))8428 (exp-form-neg x (* y y) i*2)8429 (cons x 0))))8430 (let ((a (car z)) (b (cdr z)))8431 (let ((i+b (+ i b)))8432 (if (and (< i+b flonum-e-bias-minus-1) (< a y))8433 (begin (set-car! z (/ a y)) (set-cdr! z i+b)))8434 z)))))8435 (define (exp-form x)8436 (if (< x inexact-+1)8437 (let ((z (exp-form-neg x inexact-+1/2 1)))8438 (set-car! z (* inexact-+2 (car z)))8439 (set-cdr! z (- -1 (cdr z)))8440 z)8441 (exp-form-pos x inexact-+2 1)))8442 (if (negative? x)8443 (let ((z (exp-form (- inexact-0 x))))8444 (set-car! z (- inexact-0 (car z)))8445 z)8446 (exp-form x)))8447(define (flonum->exact-exponential-format x)8448 (let ((z (flonum->inexact-exponential-format x)))8449 (let ((y (car z)))8450 (cond ((not (< y inexact-+2))8451 (set-car! z flonum-+m-min)8452 (set-cdr! z flonum-e-bias-plus-1))8453 ((not (< inexact--2 y))8454 (set-car! z flonum--m-min)8455 (set-cdr! z flonum-e-bias-plus-1))8456 (else8457 (set-car!8458 z8459 (truncate (inexact->exact (* (car z) inexact-m-min))))))8460 (set-cdr! z (- (cdr z) flonum-m-bits))8461 z)))8462(define (flonum->bits x)8463 (define (bits a b)8464 (if (< a flonum-+m-min)8465 a8466 (+ (- a flonum-+m-min)8467 (* (+ (+ b flonum-m-bits) flonum-e-bias) flonum-+m-min))))8468 (let ((z (flonum->exact-exponential-format x)))8469 (let ((a (car z)) (b (cdr z)))8470 (if (negative? a) (+ flonum-sign-bit (bits (- 0 a) b)) (bits a b)))))8471(define flonum-m-bits 52)8472(define flonum-e-bits 11)8473(define flonum-sign-bit 9223372036854775808)8474(define flonum-+m-min 4503599627370496)8475(define flonum--m-min -4503599627370496)8476(define flonum-e-bias 1023)8477(define flonum-e-bias-plus-1 1024)8478(define flonum-e-bias-minus-1 1022)8479(define inexact-m-min (exact->inexact flonum-+m-min))8480(define inexact-+2 (exact->inexact 2))8481(define inexact--2 (exact->inexact -2))8482(define inexact-+1 (exact->inexact 1))8483(define inexact-+1/2 (/ (exact->inexact 1) (exact->inexact 2)))8484(define inexact-0 (exact->inexact 0))8485(define (dump-bignum x)8486 (define radix 16384)8487 (define (integer->digits n)8488 (if (= n 0)8489 '()8490 (cons (remainder n radix) (integer->digits (quotient n radix)))))8491 (let ((l (integer->digits (abs x))))8492 (ofile-long (+ (* (+ (length l) 1) 512) (* subtype-bignum 8)))8493 (if (< x 0) (ofile-word 0) (ofile-word 1))8494 (for-each ofile-word l)))8495(define (dump-procedure proc)8496 (let ((bbs (proc-obj-code proc)))8497 (set! entry-lbl-num (bbs-entry-lbl-num bbs))8498 (set! label-counter (bbs-lbl-counter bbs))8499 (set! var-descr-queue (queue-empty))8500 (set! first-class-label-queue (queue-empty))8501 (set! deferred-code-queue (queue-empty))8502 (if *info-port*8503 (begin8504 (display " #[" *info-port*)8505 (if (proc-obj-primitive? proc)8506 (display "primitive " *info-port*)8507 (display "procedure " *info-port*))8508 (display (proc-obj-name proc) *info-port*)8509 (display "]" *info-port*)))8510 (if (proc-obj-primitive? proc)8511 (ofile-prim-proc (proc-obj-name proc))8512 (ofile-user-proc))8513 (asm.begin!)8514 (let loop ((prev-bb #f) (prev-gvm-instr #f) (l (bbs->code-list bbs)))8515 (if (not (null? l))8516 (let ((pres-bb (code-bb (car l)))8517 (pres-gvm-instr (code-gvm-instr (car l)))8518 (pres-slots-needed (code-slots-needed (car l)))8519 (next-gvm-instr8520 (if (null? (cdr l)) #f (code-gvm-instr (cadr l)))))8521 (if ofile-asm? (asm-comment (car l)))8522 (gen-gvm-instr8523 prev-gvm-instr8524 pres-gvm-instr8525 next-gvm-instr8526 pres-slots-needed)8527 (loop pres-bb pres-gvm-instr (cdr l)))))8528 (asm.end!8529 (if debug-info?8530 (vector (lst->vector (queue->list first-class-label-queue))8531 (lst->vector (queue->list var-descr-queue)))8532 #f))8533 (if *info-port* (newline *info-port*))8534 (set! var-descr-queue '())8535 (set! first-class-label-queue '())8536 (set! deferred-code-queue '())8537 (set! instr-source '())8538 (set! entry-frame '())8539 (set! exit-frame '())))8540(define label-counter (lambda () 0))8541(define entry-lbl-num '())8542(define var-descr-queue '())8543(define first-class-label-queue '())8544(define deferred-code-queue '())8545(define instr-source '())8546(define entry-frame '())8547(define exit-frame '())8548(define (defer-code! thunk) (queue-put! deferred-code-queue thunk))8549(define (gen-deferred-code!)8550 (let loop ()8551 (if (not (queue-empty? deferred-code-queue))8552 (let ((thunk (queue-get! deferred-code-queue))) (thunk) (loop)))))8553(define (add-var-descr! descr)8554 (define (index x l)8555 (let loop ((l l) (i 0))8556 (cond ((not (pair? l)) #f)8557 ((equal? (car l) x) i)8558 (else (loop (cdr l) (+ i 1))))))8559 (let ((n (index descr (queue->list var-descr-queue))))8560 (if n8561 n8562 (let ((m (length (queue->list var-descr-queue))))8563 (queue-put! var-descr-queue descr)8564 m))))8565(define (add-first-class-label! source slots frame)8566 (let loop ((i 0) (l1 slots) (l2 '()))8567 (if (pair? l1)8568 (let ((var (car l1)))8569 (let ((x (frame-live? var frame)))8570 (if (and x (or (pair? x) (not (temp-var? x))))8571 (let ((descr-index8572 (add-var-descr!8573 (if (pair? x)8574 (map (lambda (y) (add-var-descr! (var-name y))) x)8575 (var-name x)))))8576 (loop (+ i 1)8577 (cdr l1)8578 (cons (+ (* i 16384) descr-index) l2)))8579 (loop (+ i 1) (cdr l1) l2))))8580 (let ((label-descr (lst->vector (cons 0 (cons source l2)))))8581 (queue-put! first-class-label-queue label-descr)8582 label-descr))))8583(define (gen-gvm-instr prev-gvm-instr gvm-instr next-gvm-instr sn)8584 (set! instr-source (comment-get (gvm-instr-comment gvm-instr) 'source))8585 (set! exit-frame (gvm-instr-frame gvm-instr))8586 (set! entry-frame (and prev-gvm-instr (gvm-instr-frame prev-gvm-instr)))8587 (case (gvm-instr-type gvm-instr)8588 ((label)8589 (set! entry-frame exit-frame)8590 (set! current-fs (frame-size exit-frame))8591 (case (label-type gvm-instr)8592 ((simple) (gen-label-simple (label-lbl-num gvm-instr) sn))8593 ((entry)8594 (gen-label-entry8595 (label-lbl-num gvm-instr)8596 (label-entry-nb-parms gvm-instr)8597 (label-entry-min gvm-instr)8598 (label-entry-rest? gvm-instr)8599 (label-entry-closed? gvm-instr)8600 sn))8601 ((return) (gen-label-return (label-lbl-num gvm-instr) sn))8602 ((task-entry) (gen-label-task-entry (label-lbl-num gvm-instr) sn))8603 ((task-return) (gen-label-task-return (label-lbl-num gvm-instr) sn))8604 (else (compiler-internal-error "gen-gvm-instr, unknown label type"))))8605 ((apply)8606 (gen-apply8607 (apply-prim gvm-instr)8608 (apply-opnds gvm-instr)8609 (apply-loc gvm-instr)8610 sn))8611 ((copy) (gen-copy (copy-opnd gvm-instr) (copy-loc gvm-instr) sn))8612 ((close) (gen-close (close-parms gvm-instr) sn))8613 ((ifjump)8614 (gen-ifjump8615 (ifjump-test gvm-instr)8616 (ifjump-opnds gvm-instr)8617 (ifjump-true gvm-instr)8618 (ifjump-false gvm-instr)8619 (ifjump-poll? gvm-instr)8620 (if (and next-gvm-instr8621 (memq (label-type next-gvm-instr) '(simple task-entry)))8622 (label-lbl-num next-gvm-instr)8623 #f)))8624 ((jump)8625 (gen-jump8626 (jump-opnd gvm-instr)8627 (jump-nb-args gvm-instr)8628 (jump-poll? gvm-instr)8629 (if (and next-gvm-instr8630 (memq (label-type next-gvm-instr) '(simple task-entry)))8631 (label-lbl-num next-gvm-instr)8632 #f)))8633 (else8634 (compiler-internal-error8635 "gen-gvm-instr, unknown 'gvm-instr':"8636 gvm-instr))))8637(define (reg-in-opnd68 opnd)8638 (cond ((dreg? opnd) opnd)8639 ((areg? opnd) opnd)8640 ((ind? opnd) (ind-areg opnd))8641 ((pinc? opnd) (pinc-areg opnd))8642 ((pdec? opnd) (pdec-areg opnd))8643 ((disp? opnd) (disp-areg opnd))8644 ((inx? opnd) (inx-ireg opnd))8645 (else #f)))8646(define (temp-in-opnd68 opnd)8647 (let ((reg (reg-in-opnd68 opnd)))8648 (if reg8649 (cond ((identical-opnd68? reg dtemp1) reg)8650 ((identical-opnd68? reg atemp1) reg)8651 ((identical-opnd68? reg atemp2) reg)8652 (else #f))8653 #f)))8654(define (pick-atemp keep)8655 (if (and keep (identical-opnd68? keep atemp1)) atemp2 atemp1))8656(define return-reg '())8657(define max-nb-args 1024)8658(define heap-allocation-fudge (* pointer-size (+ (* 2 max-nb-args) 1024)))8659(define intr-flag 0)8660(define ltq-tail 1)8661(define ltq-head 2)8662(define heap-lim 12)8663(define closure-lim 17)8664(define closure-ptr 18)8665(define intr-flag-slot (make-disp* pstate-reg (* pointer-size intr-flag)))8666(define ltq-tail-slot (make-disp* pstate-reg (* pointer-size ltq-tail)))8667(define ltq-head-slot (make-disp* pstate-reg (* pointer-size ltq-head)))8668(define heap-lim-slot (make-disp* pstate-reg (* pointer-size heap-lim)))8669(define closure-lim-slot (make-disp* pstate-reg (* pointer-size closure-lim)))8670(define closure-ptr-slot (make-disp* pstate-reg (* pointer-size closure-ptr)))8671(define touch-trap 1)8672(define non-proc-jump-trap 6)8673(define rest-params-trap 7)8674(define rest-params-closed-trap 8)8675(define wrong-nb-arg1-trap 9)8676(define wrong-nb-arg1-closed-trap 10)8677(define wrong-nb-arg2-trap 11)8678(define wrong-nb-arg2-closed-trap 12)8679(define heap-alloc1-trap 13)8680(define heap-alloc2-trap 14)8681(define closure-alloc-trap 15)8682(define intr-trap 24)8683(define cache-line-length 16)8684(define polling-intermittency '())8685(set! polling-intermittency 10)8686(define (stat-clear!) (set! *stats* (cons 0 '())))8687(define (stat-dump!) (emit-stat (cdr *stats*)))8688(define (stat-add! bin count)8689 (define (add! stats bin count)8690 (set-car! stats (+ (car stats) count))8691 (if (not (null? bin))8692 (let ((x (assoc (car bin) (cdr stats))))8693 (if x8694 (add! (cdr x) (cdr bin) count)8695 (begin8696 (set-cdr! stats (cons (list (car bin) 0) (cdr stats)))8697 (add! (cdadr stats) (cdr bin) count))))))8698 (add! *stats* bin count))8699(define (fetch-stat-add! gvm-opnd) (opnd-stat-add! 'fetch gvm-opnd))8700(define (store-stat-add! gvm-opnd) (opnd-stat-add! 'store gvm-opnd))8701(define (jump-stat-add! gvm-opnd) (opnd-stat-add! 'jump gvm-opnd))8702(define (opnd-stat-add! type opnd)8703 (cond ((reg? opnd) (stat-add! (list 'gvm-opnd 'reg type (reg-num opnd)) 1))8704 ((stk? opnd) (stat-add! (list 'gvm-opnd 'stk type) 1))8705 ((glo? opnd) (stat-add! (list 'gvm-opnd 'glo type (glo-name opnd)) 1))8706 ((clo? opnd)8707 (stat-add! (list 'gvm-opnd 'clo type) 1)8708 (fetch-stat-add! (clo-base opnd)))8709 ((lbl? opnd) (stat-add! (list 'gvm-opnd 'lbl type) 1))8710 ((obj? opnd)8711 (let ((val (obj-val opnd)))8712 (if (number? val)8713 (stat-add! (list 'gvm-opnd 'obj type val) 1)8714 (stat-add! (list 'gvm-opnd 'obj type (obj-type val)) 1))))8715 (else8716 (compiler-internal-error "opnd-stat-add!, unknown 'opnd':" opnd))))8717(define (opnd-stat opnd)8718 (cond ((reg? opnd) 'reg)8719 ((stk? opnd) 'stk)8720 ((glo? opnd) 'glo)8721 ((clo? opnd) 'clo)8722 ((lbl? opnd) 'lbl)8723 ((obj? opnd) 'obj)8724 (else (compiler-internal-error "opnd-stat, unknown 'opnd':" opnd))))8725(define *stats* '())8726(define (move-opnd68-to-loc68 opnd loc)8727 (if (not (identical-opnd68? opnd loc))8728 (if (imm? opnd)8729 (move-n-to-loc68 (imm-val opnd) loc)8730 (emit-move.l opnd loc))))8731(define (move-obj-to-loc68 obj loc)8732 (let ((n (obj-encoding obj)))8733 (if n (move-n-to-loc68 n loc) (emit-move.l (emit-const obj) loc))))8734(define (move-n-to-loc68 n loc)8735 (cond ((= n bits-null) (emit-move.l null-reg loc))8736 ((= n bits-false) (emit-move.l false-reg loc))8737 ((and (dreg? loc) (>= n -128) (<= n 127)) (emit-moveq n loc))8738 ((and (areg? loc) (>= n -32768) (<= n 32767))8739 (emit-move.w (make-imm n) loc))8740 ((and (identical-opnd68? loc pdec-sp) (>= n -32768) (<= n 32767))8741 (emit-pea* n))8742 ((= n 0) (emit-clr.l loc))8743 ((and (not (and (inx? loc) (= (inx-ireg loc) dtemp1)))8744 (>= n -128)8745 (<= n 127))8746 (emit-moveq n dtemp1)8747 (emit-move.l dtemp1 loc))8748 (else (emit-move.l (make-imm n) loc))))8749(define (add-n-to-loc68 n loc)8750 (if (not (= n 0))8751 (cond ((and (>= n -8) (<= n 8))8752 (if (> n 0) (emit-addq.l n loc) (emit-subq.l (- n) loc)))8753 ((and (areg? loc) (>= n -32768) (<= n 32767))8754 (emit-lea (make-disp loc n) loc))8755 ((and (not (identical-opnd68? loc dtemp1)) (>= n -128) (<= n 128))8756 (emit-moveq (- (abs n)) dtemp1)8757 (if (> n 0) (emit-sub.l dtemp1 loc) (emit-add.l dtemp1 loc)))8758 (else (emit-add.l (make-imm n) loc)))))8759(define (power-of-2 n)8760 (let loop ((i 0) (k 1))8761 (cond ((= k n) i) ((> k n) #f) (else (loop (+ i 1) (* k 2))))))8762(define (mul-n-to-reg68 n reg)8763 (if (= n 0)8764 (emit-moveq 0 reg)8765 (let ((abs-n (abs n)))8766 (if (= abs-n 1)8767 (if (< n 0) (emit-neg.l reg))8768 (let ((shift (power-of-2 abs-n)))8769 (if shift8770 (let ((m (min shift 32)))8771 (if (or (<= m 8) (identical-opnd68? reg dtemp1))8772 (let loop ((i m))8773 (if (> i 0)8774 (begin8775 (emit-asl.l (make-imm (min i 8)) reg)8776 (loop (- i 8)))))8777 (begin (emit-moveq m dtemp1) (emit-asl.l dtemp1 reg)))8778 (if (< n 0) (emit-neg.l reg)))8779 (emit-muls.l (make-imm n) reg)))))))8780(define (div-n-to-reg68 n reg)8781 (let ((abs-n (abs n)))8782 (if (= abs-n 1)8783 (if (< n 0) (emit-neg.l reg))8784 (let ((shift (power-of-2 abs-n)))8785 (if shift8786 (let ((m (min shift 32)) (lbl (new-lbl!)))8787 (emit-move.l reg reg)8788 (emit-bpl lbl)8789 (add-n-to-loc68 (* (- abs-n 1) 8) reg)8790 (emit-label lbl)8791 (if (or (<= m 8) (identical-opnd68? reg dtemp1))8792 (let loop ((i m))8793 (if (> i 0)8794 (begin8795 (emit-asr.l (make-imm (min i 8)) reg)8796 (loop (- i 8)))))8797 (begin (emit-moveq m dtemp1) (emit-asr.l dtemp1 reg)))8798 (if (< n 0) (emit-neg.l reg)))8799 (emit-divsl.l (make-imm n) reg reg))))))8800(define (cmp-n-to-opnd68 n opnd)8801 (cond ((= n bits-null) (emit-cmp.l opnd null-reg) #f)8802 ((= n bits-false) (emit-cmp.l opnd false-reg) #f)8803 ((or (pcr? opnd) (imm? opnd))8804 (if (= n 0)8805 (begin (emit-move.l opnd dtemp1) #t)8806 (begin8807 (move-opnd68-to-loc68 opnd atemp1)8808 (if (and (>= n -32768) (<= n 32767))8809 (emit-cmp.w (make-imm n) atemp1)8810 (emit-cmp.l (make-imm n) atemp1))8811 #t)))8812 ((= n 0) (emit-move.l opnd dtemp1) #t)8813 ((and (>= n -128) (<= n 127) (not (identical-opnd68? opnd dtemp1)))8814 (emit-moveq n dtemp1)8815 (emit-cmp.l opnd dtemp1)8816 #f)8817 (else (emit-cmp.l (make-imm n) opnd) #t)))8818(define current-fs '())8819(define (adjust-current-fs n) (set! current-fs (+ current-fs n)))8820(define (new-lbl!) (label-counter))8821(define (needed? loc sn) (and loc (if (stk? loc) (<= (stk-num loc) sn) #t)))8822(define (sn-opnd opnd sn)8823 (cond ((stk? opnd) (max (stk-num opnd) sn))8824 ((clo? opnd) (sn-opnd (clo-base opnd) sn))8825 (else sn)))8826(define (sn-opnds opnds sn)8827 (if (null? opnds) sn (sn-opnd (car opnds) (sn-opnds (cdr opnds) sn))))8828(define (sn-opnd68 opnd sn)8829 (cond ((and (disp*? opnd) (identical-opnd68? (disp*-areg opnd) sp-reg))8830 (max (disp*-offset opnd) sn))8831 ((identical-opnd68? opnd pdec-sp) (max (+ current-fs 1) sn))8832 ((identical-opnd68? opnd pinc-sp) (max current-fs sn))8833 (else sn)))8834(define (resize-frame n)8835 (let ((x (- n current-fs)))8836 (adjust-current-fs x)8837 (add-n-to-loc68 (* (- pointer-size) x) sp-reg)))8838(define (shrink-frame n)8839 (cond ((< n current-fs) (resize-frame n))8840 ((> n current-fs)8841 (compiler-internal-error "shrink-frame, can't increase frame size"))))8842(define (make-top-of-frame n sn)8843 (if (and (< n current-fs) (>= n sn)) (resize-frame n)))8844(define (make-top-of-frame-if-stk-opnd68 opnd sn)8845 (if (frame-base-rel? opnd)8846 (make-top-of-frame (frame-base-rel-slot opnd) sn)))8847(define (make-top-of-frame-if-stk-opnds68 opnd1 opnd2 sn)8848 (if (frame-base-rel? opnd1)8849 (let ((slot1 (frame-base-rel-slot opnd1)))8850 (if (frame-base-rel? opnd2)8851 (make-top-of-frame (max (frame-base-rel-slot opnd2) slot1) sn)8852 (make-top-of-frame slot1 sn)))8853 (if (frame-base-rel? opnd2)8854 (make-top-of-frame (frame-base-rel-slot opnd2) sn))))8855(define (opnd68->true-opnd68 opnd sn)8856 (if (frame-base-rel? opnd)8857 (let ((slot (frame-base-rel-slot opnd)))8858 (cond ((> slot current-fs) (adjust-current-fs 1) pdec-sp)8859 ((and (= slot current-fs) (< sn current-fs))8860 (adjust-current-fs -1)8861 pinc-sp)8862 (else (make-disp* sp-reg (* pointer-size (- current-fs slot))))))8863 opnd))8864(define (move-opnd68-to-any-areg opnd keep sn)8865 (if (areg? opnd)8866 opnd8867 (let ((areg (pick-atemp keep)))8868 (make-top-of-frame-if-stk-opnd68 opnd sn)8869 (move-opnd68-to-loc68 (opnd68->true-opnd68 opnd sn) areg)8870 areg)))8871(define (clo->opnd68 opnd keep sn)8872 (let ((base (clo-base opnd)) (offs (closed-var-offset (clo-index opnd))))8873 (if (lbl? base) (make-pcr (lbl-num base) offs) (clo->loc68 opnd keep sn))))8874(define (clo->loc68 opnd keep sn)8875 (let ((base (clo-base opnd)) (offs (closed-var-offset (clo-index opnd))))8876 (cond ((eq? base return-reg) (make-disp* (reg->reg68 base) offs))8877 ((obj? base)8878 (let ((areg (pick-atemp keep)))8879 (move-obj-to-loc68 (obj-val base) areg)8880 (make-disp* areg offs)))8881 (else8882 (let ((areg (pick-atemp keep)))8883 (move-opnd-to-loc68 base areg sn)8884 (make-disp* areg offs))))))8885(define (reg->reg68 reg) (reg-num->reg68 (reg-num reg)))8886(define (reg-num->reg68 num)8887 (if (= num 0) (make-areg gvm-reg0) (make-dreg (+ (- num 1) gvm-reg1))))8888(define (opnd->opnd68 opnd keep sn)8889 (cond ((lbl? opnd)8890 (let ((areg (pick-atemp keep)))8891 (emit-lea (make-pcr (lbl-num opnd) 0) areg)8892 areg))8893 ((obj? opnd)8894 (let ((val (obj-val opnd)))8895 (if (proc-obj? val)8896 (let ((num (add-object val)) (areg (pick-atemp keep)))8897 (if num (emit-move-proc num areg) (emit-move-prim val areg))8898 areg)8899 (let ((n (obj-encoding val)))8900 (if n (make-imm n) (emit-const val))))))8901 ((clo? opnd) (clo->opnd68 opnd keep sn))8902 (else (loc->loc68 opnd keep sn))))8903(define (loc->loc68 loc keep sn)8904 (cond ((reg? loc) (reg->reg68 loc))8905 ((stk? loc) (make-frame-base-rel (stk-num loc)))8906 ((glo? loc) (make-glob (glo-name loc)))8907 ((clo? loc) (clo->loc68 loc keep sn))8908 (else (compiler-internal-error "loc->loc68, unknown 'loc':" loc))))8909(define (move-opnd68-to-loc opnd loc sn)8910 (cond ((reg? loc)8911 (make-top-of-frame-if-stk-opnd68 opnd sn)8912 (move-opnd68-to-loc68 (opnd68->true-opnd68 opnd sn) (reg->reg68 loc)))8913 ((stk? loc)8914 (let* ((loc-slot (stk-num loc))8915 (sn-after-opnd1 (if (< loc-slot sn) sn (- loc-slot 1))))8916 (if (> current-fs loc-slot)8917 (make-top-of-frame8918 (if (frame-base-rel? opnd)8919 (let ((opnd-slot (frame-base-rel-slot opnd)))8920 (if (>= opnd-slot (- loc-slot 1)) opnd-slot loc-slot))8921 loc-slot)8922 sn-after-opnd1))8923 (let* ((opnd1 (opnd68->true-opnd68 opnd sn-after-opnd1))8924 (opnd2 (opnd68->true-opnd688925 (make-frame-base-rel loc-slot)8926 sn)))8927 (move-opnd68-to-loc68 opnd1 opnd2))))8928 ((glo? loc)8929 (make-top-of-frame-if-stk-opnd68 opnd sn)8930 (move-opnd68-to-loc688931 (opnd68->true-opnd68 opnd sn)8932 (make-glob (glo-name loc))))8933 ((clo? loc)8934 (let ((clo (clo->loc688935 loc8936 (temp-in-opnd68 opnd)8937 (sn-opnd68 opnd sn))))8938 (make-top-of-frame-if-stk-opnd68 opnd sn)8939 (move-opnd68-to-loc68 (opnd68->true-opnd68 opnd sn) clo)))8940 (else8941 (compiler-internal-error "move-opnd68-to-loc, unknown 'loc':" loc))))8942(define (move-opnd-to-loc68 opnd loc68 sn)8943 (if (and (lbl? opnd) (areg? loc68))8944 (emit-lea (make-pcr (lbl-num opnd) 0) loc68)8945 (let* ((sn-after-opnd68 (sn-opnd68 loc68 sn))8946 (opnd68 (opnd->opnd688947 opnd8948 (temp-in-opnd68 loc68)8949 sn-after-opnd68)))8950 (make-top-of-frame-if-stk-opnds68 opnd68 loc68 sn)8951 (let* ((opnd68* (opnd68->true-opnd68 opnd68 sn-after-opnd68))8952 (loc68* (opnd68->true-opnd68 loc68 sn)))8953 (move-opnd68-to-loc68 opnd68* loc68*)))))8954(define (copy-opnd-to-loc opnd loc sn)8955 (if (and (lbl? opnd) (eq? loc return-reg))8956 (emit-lea (make-pcr (lbl-num opnd) 0) (reg->reg68 loc))8957 (move-opnd68-to-loc (opnd->opnd68 opnd #f (sn-opnd loc sn)) loc sn)))8958(define (touch-reg68-to-reg68 src dst)8959 (define (trap-to-touch-handler dreg lbl)8960 (if ofile-stats?8961 (emit-stat8962 '((touch 08963 (determined-placeholder -1)8964 (undetermined-placeholder 1)))))8965 (gen-trap8966 instr-source8967 entry-frame8968 #t8969 dreg8970 (+ touch-trap (dreg-num dreg))8971 lbl))8972 (define (touch-dreg-to-reg src dst)8973 (let ((lbl1 (new-lbl!)))8974 (emit-btst src placeholder-reg)8975 (emit-bne lbl1)8976 (if ofile-stats?8977 (emit-stat8978 '((touch 0 (non-placeholder -1) (determined-placeholder 1)))))8979 (trap-to-touch-handler src lbl1)8980 (move-opnd68-to-loc68 src dst)))8981 (define (touch-areg-to-dreg src dst)8982 (let ((lbl1 (new-lbl!)))8983 (emit-move.l src dst)8984 (emit-btst dst placeholder-reg)8985 (emit-bne lbl1)8986 (if ofile-stats?8987 (emit-stat8988 '((touch 0 (non-placeholder -1) (determined-placeholder 1)))))8989 (trap-to-touch-handler dst lbl1)))8990 (if ofile-stats? (emit-stat '((touch 1 (non-placeholder 1)))))8991 (cond ((dreg? src) (touch-dreg-to-reg src dst))8992 ((dreg? dst) (touch-areg-to-dreg src dst))8993 (else (emit-move.l src dtemp1) (touch-dreg-to-reg dtemp1 dst))))8994(define (touch-opnd-to-any-reg68 opnd sn)8995 (if (reg? opnd)8996 (let ((reg (reg->reg68 opnd))) (touch-reg68-to-reg68 reg reg) reg)8997 (let ((opnd68 (opnd->opnd68 opnd #f sn)))8998 (make-top-of-frame-if-stk-opnd68 opnd68 sn)8999 (move-opnd68-to-loc68 (opnd68->true-opnd68 opnd68 sn) dtemp1)9000 (touch-reg68-to-reg68 dtemp1 dtemp1)9001 dtemp1)))9002(define (touch-opnd-to-loc opnd loc sn)9003 (if (reg? opnd)9004 (let ((reg68 (reg->reg68 opnd)))9005 (if (reg? loc)9006 (touch-reg68-to-reg68 reg68 (reg->reg68 loc))9007 (begin9008 (touch-reg68-to-reg68 reg68 reg68)9009 (move-opnd68-to-loc reg68 loc sn))))9010 (if (reg? loc)9011 (let ((reg68 (reg->reg68 loc)))9012 (move-opnd-to-loc68 opnd reg68 sn)9013 (touch-reg68-to-reg68 reg68 reg68))9014 (let ((reg68 (touch-opnd-to-any-reg68 opnd sn)))9015 (move-opnd68-to-loc reg68 loc sn)))))9016(define (gen-trap source frame save-live? not-save-reg num lbl)9017 (define (adjust-slots l n)9018 (cond ((= n 0) (append l '()))9019 ((< n 0) (adjust-slots (cdr l) (+ n 1)))9020 (else (adjust-slots (cons empty-var l) (- n 1)))))9021 (define (set-slot! slots i x)9022 (let loop ((l slots) (n (- (length slots) i)))9023 (if (> n 0) (loop (cdr l) (- n 1)) (set-car! l x))))9024 (let ((ret-slot (frame-first-empty-slot frame)))9025 (let loop1 ((save1 '()) (save2 #f) (regs (frame-regs frame)) (i 0))9026 (if (pair? regs)9027 (let ((var (car regs)))9028 (if (eq? var ret-var)9029 (let ((x (cons (reg->reg68 (make-reg i)) var)))9030 (if (> ret-slot current-fs)9031 (loop1 (cons x save1) save2 (cdr regs) (+ i 1))9032 (loop1 save1 x (cdr regs) (+ i 1))))9033 (if (and save-live?9034 (frame-live? var frame)9035 (not (eqv? not-save-reg (reg->reg68 (make-reg i)))))9036 (loop1 (cons (cons (reg->reg68 (make-reg i)) var) save1)9037 save29038 (cdr regs)9039 (+ i 1))9040 (loop1 save1 save2 (cdr regs) (+ i 1)))))9041 (let ((order (sort-list save1 (lambda (x y) (< (car x) (car y))))))9042 (let ((slots (append (map cdr order)9043 (adjust-slots9044 (frame-slots frame)9045 (- current-fs (frame-size frame)))))9046 (reg-list (map car order))9047 (nb-regs (length order)))9048 (define (trap)9049 (emit-trap2 num '())9050 (gen-label-return*9051 (new-lbl!)9052 (add-first-class-label! source slots frame)9053 slots9054 0))9055 (if save29056 (begin9057 (emit-move.l9058 (car save2)9059 (make-disp*9060 sp-reg9061 (* pointer-size (- current-fs ret-slot))))9062 (set-slot! slots ret-slot (cdr save2))))9063 (if (> (length order) 2)9064 (begin9065 (emit-movem.l reg-list pdec-sp)9066 (trap)9067 (emit-movem.l pinc-sp reg-list))9068 (let loop2 ((l (reverse reg-list)))9069 (if (pair? l)9070 (let ((reg (car l)))9071 (emit-move.l reg pdec-sp)9072 (loop2 (cdr l))9073 (emit-move.l pinc-sp reg))9074 (trap))))9075 (if save29076 (emit-move.l9077 (make-disp* sp-reg (* pointer-size (- current-fs ret-slot)))9078 (car save2)))9079 (emit-label lbl)))))))9080(define (gen-label-simple lbl sn)9081 (if ofile-stats?9082 (begin (stat-clear!) (stat-add! '(gvm-instr label simple) 1)))9083 (set! pointers-allocated 0)9084 (emit-label lbl))9085(define (gen-label-entry lbl nb-parms min rest? closed? sn)9086 (if ofile-stats?9087 (begin9088 (stat-clear!)9089 (stat-add!9090 (list 'gvm-instr9091 'label9092 'entry9093 nb-parms9094 min9095 (if rest? 'rest 'not-rest)9096 (if closed? 'closed 'not-closed))9097 1)))9098 (set! pointers-allocated 0)9099 (let ((label-descr (add-first-class-label! instr-source '() exit-frame)))9100 (if (= lbl entry-lbl-num)9101 (emit-label lbl)9102 (emit-label-subproc lbl entry-lbl-num label-descr)))9103 (let* ((nb-parms* (if rest? (- nb-parms 1) nb-parms))9104 (dispatch-lbls (make-vector (+ (- nb-parms min) 1)))9105 (optional-lbls (make-vector (+ (- nb-parms min) 1))))9106 (let loop ((i min))9107 (if (<= i nb-parms)9108 (let ((lbl (new-lbl!)))9109 (vector-set! optional-lbls (- nb-parms i) lbl)9110 (vector-set!9111 dispatch-lbls9112 (- nb-parms i)9113 (if (or (>= i nb-parms) (<= nb-parms nb-arg-regs))9114 lbl9115 (new-lbl!)))9116 (loop (+ i 1)))))9117 (if closed?9118 (let ((closure-reg (reg-num->reg68 (+ nb-arg-regs 1))))9119 (emit-move.l pinc-sp closure-reg)9120 (emit-subq.l 6 closure-reg)9121 (if (or (and (<= min 1) (<= 1 nb-parms*))9122 (and (<= min 2) (<= 2 nb-parms*)))9123 (emit-move.w dtemp1 dtemp1))))9124 (if (and (<= min 2) (<= 2 nb-parms*))9125 (emit-beq (vector-ref dispatch-lbls (- nb-parms 2))))9126 (if (and (<= min 1) (<= 1 nb-parms*))9127 (emit-bmi (vector-ref dispatch-lbls (- nb-parms 1))))9128 (let loop ((i min))9129 (if (<= i nb-parms*)9130 (begin9131 (if (not (or (= i 1) (= i 2)))9132 (begin9133 (emit-cmp.w (make-imm (encode-arg-count i)) arg-count-reg)9134 (emit-beq (vector-ref dispatch-lbls (- nb-parms i)))))9135 (loop (+ i 1)))))9136 (cond (rest?9137 (emit-trap19138 (if closed? rest-params-closed-trap rest-params-trap)9139 (list min nb-parms*))9140 (if (not closed?) (emit-lbl-ptr lbl))9141 (set! pointers-allocated 1)9142 (gen-guarantee-fudge)9143 (emit-bra (vector-ref optional-lbls 0)))9144 ((= min nb-parms*)9145 (emit-trap19146 (if closed? wrong-nb-arg1-closed-trap wrong-nb-arg1-trap)9147 (list nb-parms*))9148 (if (not closed?) (emit-lbl-ptr lbl)))9149 (else9150 (emit-trap19151 (if closed? wrong-nb-arg2-closed-trap wrong-nb-arg2-trap)9152 (list min nb-parms*))9153 (if (not closed?) (emit-lbl-ptr lbl))))9154 (if (> nb-parms nb-arg-regs)9155 (let loop1 ((i (- nb-parms 1)))9156 (if (>= i min)9157 (let ((nb-stacked (if (<= i nb-arg-regs) 0 (- i nb-arg-regs))))9158 (emit-label (vector-ref dispatch-lbls (- nb-parms i)))9159 (let loop2 ((j 1))9160 (if (and (<= j nb-arg-regs)9161 (<= j i)9162 (<= j (- (- nb-parms nb-arg-regs) nb-stacked)))9163 (begin9164 (emit-move.l (reg-num->reg68 j) pdec-sp)9165 (loop2 (+ j 1)))9166 (let loop3 ((k j))9167 (if (and (<= k nb-arg-regs) (<= k i))9168 (begin9169 (emit-move.l9170 (reg-num->reg68 k)9171 (reg-num->reg68 (+ (- k j) 1)))9172 (loop3 (+ k 1)))))))9173 (if (> i min)9174 (emit-bra (vector-ref optional-lbls (- nb-parms i))))9175 (loop1 (- i 1))))))9176 (let loop ((i min))9177 (if (<= i nb-parms)9178 (let ((val (if (= i nb-parms*) bits-null bits-unass)))9179 (emit-label (vector-ref optional-lbls (- nb-parms i)))9180 (cond ((> (- nb-parms i) nb-arg-regs)9181 (move-n-to-loc68 val pdec-sp))9182 ((< i nb-parms)9183 (move-n-to-loc689184 val9185 (reg-num->reg68 (parm->reg-num (+ i 1) nb-parms)))))9186 (loop (+ i 1)))))))9187(define (encode-arg-count n) (cond ((= n 1) -1) ((= n 2) 0) (else (+ n 1))))9188(define (parm->reg-num i nb-parms)9189 (if (<= nb-parms nb-arg-regs) i (+ i (- nb-arg-regs nb-parms))))9190(define (no-arg-check-entry-offset proc nb-args)9191 (let ((x (proc-obj-call-pat proc)))9192 (if (and (pair? x) (null? (cdr x)))9193 (let ((arg-count (car x)))9194 (if (= arg-count nb-args)9195 (if (or (= arg-count 1) (= arg-count 2)) 10 14)9196 0))9197 0)))9198(define (gen-label-return lbl sn)9199 (if ofile-stats?9200 (begin (stat-clear!) (stat-add! '(gvm-instr label return) 1)))9201 (set! pointers-allocated 0)9202 (let ((slots (frame-slots exit-frame)))9203 (gen-label-return*9204 lbl9205 (add-first-class-label! instr-source slots exit-frame)9206 slots9207 0)))9208(define (gen-label-return* lbl label-descr slots extra)9209 (let ((i (pos-in-list ret-var slots)))9210 (if i9211 (let* ((fs (length slots)) (link (- fs i)))9212 (emit-label-return lbl entry-lbl-num (+ fs extra) link label-descr))9213 (compiler-internal-error9214 "gen-label-return*, no return address in frame"))))9215(define (gen-label-task-entry lbl sn)9216 (if ofile-stats?9217 (begin (stat-clear!) (stat-add! '(gvm-instr label task-entry) 1)))9218 (set! pointers-allocated 0)9219 (emit-label lbl)9220 (if (= current-fs 0)9221 (begin9222 (emit-move.l (reg->reg68 return-reg) pdec-sp)9223 (emit-move.l sp-reg (make-pinc ltq-tail-reg)))9224 (begin9225 (emit-move.l sp-reg atemp1)9226 (emit-move.l (make-pinc atemp1) pdec-sp)9227 (let loop ((i (- current-fs 1)))9228 (if (> i 0)9229 (begin9230 (emit-move.l (make-pinc atemp1) (make-disp atemp1 -8))9231 (loop (- i 1)))))9232 (emit-move.l (reg->reg68 return-reg) (make-pdec atemp1))9233 (emit-move.l atemp1 (make-pinc ltq-tail-reg))))9234 (emit-move.l ltq-tail-reg ltq-tail-slot))9235(define (gen-label-task-return lbl sn)9236 (if ofile-stats?9237 (begin (stat-clear!) (stat-add! '(gvm-instr label task-return) 1)))9238 (set! pointers-allocated 0)9239 (let ((slots (frame-slots exit-frame)))9240 (set! current-fs (+ current-fs 1))9241 (let ((dummy-lbl (new-lbl!)) (skip-lbl (new-lbl!)))9242 (gen-label-return*9243 dummy-lbl9244 (add-first-class-label! instr-source slots exit-frame)9245 slots9246 1)9247 (emit-bra skip-lbl)9248 (gen-label-task-return*9249 lbl9250 (add-first-class-label! instr-source slots exit-frame)9251 slots9252 1)9253 (emit-subq.l pointer-size ltq-tail-reg)9254 (emit-label skip-lbl))))9255(define (gen-label-task-return* lbl label-descr slots extra)9256 (let ((i (pos-in-list ret-var slots)))9257 (if i9258 (let* ((fs (length slots)) (link (- fs i)))9259 (emit-label-task-return9260 lbl9261 entry-lbl-num9262 (+ fs extra)9263 link9264 label-descr))9265 (compiler-internal-error9266 "gen-label-task-return*, no return address in frame"))))9267(define (gen-apply prim opnds loc sn)9268 (if ofile-stats?9269 (begin9270 (stat-add!9271 (list 'gvm-instr9272 'apply9273 (string->canonical-symbol (proc-obj-name prim))9274 (map opnd-stat opnds)9275 (if loc (opnd-stat loc) #f))9276 1)9277 (for-each fetch-stat-add! opnds)9278 (if loc (store-stat-add! loc))))9279 (let ((x (proc-obj-inlinable prim)))9280 (if (not x)9281 (compiler-internal-error "gen-APPLY, unknown 'prim':" prim)9282 (if (or (needed? loc sn) (car x)) ((cdr x) opnds loc sn)))))9283(define (define-apply name side-effects? proc)9284 (let ((prim (get-prim-info name)))9285 (proc-obj-inlinable-set! prim (cons side-effects? proc))))9286(define (gen-copy opnd loc sn)9287 (if ofile-stats?9288 (begin9289 (stat-add! (list 'gvm-instr 'copy (opnd-stat opnd) (opnd-stat loc)) 1)9290 (fetch-stat-add! opnd)9291 (store-stat-add! loc)))9292 (if (needed? loc sn) (copy-opnd-to-loc opnd loc sn)))9293(define (gen-close parms sn)9294 (define (size->bytes size)9295 (* (quotient9296 (+ (* (+ size 2) pointer-size) (- cache-line-length 1))9297 cache-line-length)9298 cache-line-length))9299 (define (parms->bytes parms)9300 (if (null? parms)9301 09302 (+ (size->bytes (length (closure-parms-opnds (car parms))))9303 (parms->bytes (cdr parms)))))9304 (if ofile-stats?9305 (begin9306 (for-each9307 (lambda (x)9308 (stat-add!9309 (list 'gvm-instr9310 'close9311 (opnd-stat (closure-parms-loc x))9312 (map opnd-stat (closure-parms-opnds x)))9313 1)9314 (store-stat-add! (closure-parms-loc x))9315 (fetch-stat-add! (make-lbl (closure-parms-lbl x)))9316 (for-each fetch-stat-add! (closure-parms-opnds x)))9317 parms)))9318 (let ((total-space-needed (parms->bytes parms)) (lbl1 (new-lbl!)))9319 (emit-move.l closure-ptr-slot atemp2)9320 (move-n-to-loc68 total-space-needed dtemp1)9321 (emit-sub.l dtemp1 atemp2)9322 (emit-cmp.l closure-lim-slot atemp2)9323 (emit-bcc lbl1)9324 (gen-trap instr-source entry-frame #f #f closure-alloc-trap lbl1)9325 (emit-move.l atemp2 closure-ptr-slot)9326 (let* ((opnds* (apply append (map closure-parms-opnds parms)))9327 (sn* (sn-opnds opnds* sn)))9328 (let loop1 ((parms parms))9329 (let ((loc (closure-parms-loc (car parms)))9330 (size (length (closure-parms-opnds (car parms))))9331 (rest (cdr parms)))9332 (if (= size 1)9333 (emit-addq.l type-procedure atemp2)9334 (emit-move.w9335 (make-imm (+ 32768 (* (+ size 1) 4)))9336 (make-pinc atemp2)))9337 (move-opnd68-to-loc9338 atemp29339 loc9340 (sn-opnds (map closure-parms-loc rest) sn*))9341 (if (null? rest)9342 (add-n-to-loc689343 (+ (- (size->bytes size) total-space-needed) 2)9344 atemp2)9345 (begin9346 (add-n-to-loc68 (- (size->bytes size) type-procedure) atemp2)9347 (loop1 rest)))))9348 (let loop2 ((parms parms))9349 (let* ((opnds (closure-parms-opnds (car parms)))9350 (lbl (closure-parms-lbl (car parms)))9351 (size (length opnds))9352 (rest (cdr parms)))9353 (emit-lea (make-pcr lbl 0) atemp1)9354 (emit-move.l atemp1 (make-pinc atemp2))9355 (let loop3 ((opnds opnds))9356 (if (not (null? opnds))9357 (let ((sn** (sn-opnds9358 (apply append (map closure-parms-opnds rest))9359 sn)))9360 (move-opnd-to-loc689361 (car opnds)9362 (make-pinc atemp2)9363 (sn-opnds (cdr opnds) sn**))9364 (loop3 (cdr opnds)))))9365 (if (not (null? rest))9366 (begin9367 (add-n-to-loc689368 (- (size->bytes size) (* (+ size 1) pointer-size))9369 atemp2)9370 (loop2 rest))))))))9371(define (gen-ifjump test opnds true-lbl false-lbl poll? next-lbl)9372 (if ofile-stats?9373 (begin9374 (stat-add!9375 (list 'gvm-instr9376 'ifjump9377 (string->canonical-symbol (proc-obj-name test))9378 (map opnd-stat opnds)9379 (if poll? 'poll 'not-poll))9380 1)9381 (for-each fetch-stat-add! opnds)9382 (stat-dump!)))9383 (let ((proc (proc-obj-test test)))9384 (if proc9385 (gen-ifjump* proc opnds true-lbl false-lbl poll? next-lbl)9386 (compiler-internal-error "gen-IFJUMP, unknown 'test':" test))))9387(define (gen-ifjump* proc opnds true-lbl false-lbl poll? next-lbl)9388 (let ((fs (frame-size exit-frame)))9389 (define (double-branch)9390 (proc #t opnds false-lbl fs)9391 (if ofile-stats?9392 (emit-stat9393 '((gvm-instr.ifjump.fall-through 1)9394 (gvm-instr.ifjump.double-branch 1))))9395 (emit-bra true-lbl)9396 (gen-deferred-code!))9397 (gen-guarantee-fudge)9398 (if poll? (gen-poll))9399 (if next-lbl9400 (cond ((= true-lbl next-lbl)9401 (proc #t opnds false-lbl fs)9402 (if ofile-stats?9403 (emit-stat '((gvm-instr.ifjump.fall-through 1)))))9404 ((= false-lbl next-lbl)9405 (proc #f opnds true-lbl fs)9406 (if ofile-stats?9407 (emit-stat '((gvm-instr.ifjump.fall-through 1)))))9408 (else (double-branch)))9409 (double-branch))))9410(define (define-ifjump name proc)9411 (define-apply9412 name9413 #f9414 (lambda (opnds loc sn)9415 (let ((true-lbl (new-lbl!))9416 (cont-lbl (new-lbl!))9417 (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))9418 (reg->reg68 loc)9419 dtemp1)))9420 (proc #f opnds true-lbl current-fs)9421 (move-n-to-loc68 bits-false reg68)9422 (emit-bra cont-lbl)9423 (emit-label true-lbl)9424 (move-n-to-loc68 bits-true reg68)9425 (emit-label cont-lbl)9426 (move-opnd68-to-loc reg68 loc sn))))9427 (proc-obj-test-set! (get-prim-info name) proc))9428(define (gen-jump opnd nb-args poll? next-lbl)9429 (let ((fs (frame-size exit-frame)))9430 (if ofile-stats?9431 (begin9432 (stat-add!9433 (list 'gvm-instr9434 'jump9435 (opnd-stat opnd)9436 nb-args9437 (if poll? 'poll 'not-poll))9438 1)9439 (jump-stat-add! opnd)9440 (if (and (lbl? opnd) next-lbl (= next-lbl (lbl-num opnd)))9441 (stat-add! '(gvm-instr.jump.fall-through) 1))9442 (stat-dump!)))9443 (gen-guarantee-fudge)9444 (cond ((glo? opnd)9445 (if poll? (gen-poll))9446 (setup-jump fs nb-args)9447 (emit-jmp-glob (make-glob (glo-name opnd)))9448 (gen-deferred-code!))9449 ((and (stk? opnd) (= (stk-num opnd) (+ fs 1)) (not nb-args))9450 (if poll? (gen-poll))9451 (setup-jump (+ fs 1) nb-args)9452 (emit-rts)9453 (gen-deferred-code!))9454 ((lbl? opnd)9455 (if (and poll?9456 (= fs current-fs)9457 (not nb-args)9458 (not (and next-lbl (= next-lbl (lbl-num opnd)))))9459 (gen-poll-branch (lbl-num opnd))9460 (begin9461 (if poll? (gen-poll))9462 (setup-jump fs nb-args)9463 (if (not (and next-lbl (= next-lbl (lbl-num opnd))))9464 (emit-bra (lbl-num opnd))))))9465 ((obj? opnd)9466 (if poll? (gen-poll))9467 (let ((val (obj-val opnd)))9468 (if (proc-obj? val)9469 (let ((num (add-object val))9470 (offset (no-arg-check-entry-offset val nb-args)))9471 (setup-jump fs (if (<= offset 0) nb-args #f))9472 (if num9473 (emit-jmp-proc num offset)9474 (emit-jmp-prim val offset))9475 (gen-deferred-code!))9476 (gen-jump* (opnd->opnd68 opnd #f fs) fs nb-args))))9477 (else9478 (if poll? (gen-poll))9479 (gen-jump* (opnd->opnd68 opnd #f fs) fs nb-args)))))9480(define (gen-jump* opnd fs nb-args)9481 (if nb-args9482 (let ((lbl (new-lbl!)))9483 (make-top-of-frame-if-stk-opnd68 opnd fs)9484 (move-opnd68-to-loc68 (opnd68->true-opnd68 opnd fs) atemp1)9485 (shrink-frame fs)9486 (emit-move.l atemp1 dtemp1)9487 (emit-addq.w (modulo (- type-pair type-procedure) 8) dtemp1)9488 (emit-btst dtemp1 pair-reg)9489 (emit-beq lbl)9490 (move-n-to-loc68 (encode-arg-count nb-args) arg-count-reg)9491 (emit-trap3 non-proc-jump-trap)9492 (emit-label lbl)9493 (move-n-to-loc68 (encode-arg-count nb-args) arg-count-reg)9494 (emit-jmp (make-ind atemp1)))9495 (let ((areg (move-opnd68-to-any-areg opnd #f fs)))9496 (setup-jump fs nb-args)9497 (emit-jmp (make-ind areg))))9498 (gen-deferred-code!))9499(define (setup-jump fs nb-args)9500 (shrink-frame fs)9501 (if nb-args (move-n-to-loc68 (encode-arg-count nb-args) arg-count-reg)))9502(define (gen-poll)9503 (let ((lbl (new-lbl!)))9504 (emit-dbra poll-timer-reg lbl)9505 (emit-moveq (- polling-intermittency 1) poll-timer-reg)9506 (emit-cmp.l intr-flag-slot sp-reg)9507 (emit-bcc lbl)9508 (gen-trap instr-source entry-frame #f #f intr-trap lbl)))9509(define (gen-poll-branch lbl)9510 (emit-dbra poll-timer-reg lbl)9511 (emit-moveq (- polling-intermittency 1) poll-timer-reg)9512 (emit-cmp.l intr-flag-slot sp-reg)9513 (emit-bcc lbl)9514 (gen-trap instr-source entry-frame #f #f intr-trap (new-lbl!))9515 (emit-bra lbl))9516(define (make-gen-slot-ref slot type)9517 (lambda (opnds loc sn)9518 (let ((sn-loc (sn-opnd loc sn)) (opnd (car opnds)))9519 (move-opnd-to-loc68 opnd atemp1 sn-loc)9520 (move-opnd68-to-loc9521 (make-disp* atemp1 (- (* slot pointer-size) type))9522 loc9523 sn))))9524(define (make-gen-slot-set! slot type)9525 (lambda (opnds loc sn)9526 (let ((sn-loc (if loc (sn-opnd loc sn) sn)))9527 (let* ((first-opnd (car opnds))9528 (second-opnd (cadr opnds))9529 (sn-second-opnd (sn-opnd second-opnd sn-loc)))9530 (move-opnd-to-loc68 first-opnd atemp1 sn-second-opnd)9531 (move-opnd-to-loc689532 second-opnd9533 (make-disp* atemp1 (- (* slot pointer-size) type))9534 sn-loc)9535 (if loc9536 (if (not (eq? first-opnd loc))9537 (move-opnd68-to-loc atemp1 loc sn)))))))9538(define (gen-cons opnds loc sn)9539 (let ((sn-loc (sn-opnd loc sn)))9540 (let ((first-opnd (car opnds)) (second-opnd (cadr opnds)))9541 (gen-guarantee-space 2)9542 (if (contains-opnd? loc second-opnd)9543 (let ((sn-second-opnd (sn-opnd second-opnd sn-loc)))9544 (move-opnd-to-loc68 first-opnd (make-pdec heap-reg) sn-second-opnd)9545 (move-opnd68-to-loc68 heap-reg atemp2)9546 (move-opnd-to-loc68 second-opnd (make-pdec heap-reg) sn-loc)9547 (move-opnd68-to-loc atemp2 loc sn))9548 (let* ((sn-second-opnd (sn-opnd second-opnd sn))9549 (sn-loc (sn-opnd loc sn-second-opnd)))9550 (move-opnd-to-loc68 first-opnd (make-pdec heap-reg) sn-loc)9551 (move-opnd68-to-loc heap-reg loc sn-second-opnd)9552 (move-opnd-to-loc68 second-opnd (make-pdec heap-reg) sn))))))9553(define (make-gen-apply-c...r pattern)9554 (lambda (opnds loc sn)9555 (let ((sn-loc (sn-opnd loc sn)) (opnd (car opnds)))9556 (move-opnd-to-loc68 opnd atemp1 sn-loc)9557 (let loop ((pattern pattern))9558 (if (<= pattern 3)9559 (if (= pattern 3)9560 (move-opnd68-to-loc (make-pdec atemp1) loc sn)9561 (move-opnd68-to-loc (make-ind atemp1) loc sn))9562 (begin9563 (if (odd? pattern)9564 (emit-move.l (make-pdec atemp1) atemp1)9565 (emit-move.l (make-ind atemp1) atemp1))9566 (loop (quotient pattern 2))))))))9567(define (gen-set-car! opnds loc sn)9568 (let ((sn-loc (if loc (sn-opnd loc sn) sn)))9569 (let* ((first-opnd (car opnds))9570 (second-opnd (cadr opnds))9571 (sn-second-opnd (sn-opnd second-opnd sn-loc)))9572 (move-opnd-to-loc68 first-opnd atemp1 sn-second-opnd)9573 (move-opnd-to-loc68 second-opnd (make-ind atemp1) sn-loc)9574 (if (and loc (not (eq? first-opnd loc)))9575 (move-opnd68-to-loc atemp1 loc sn)))))9576(define (gen-set-cdr! opnds loc sn)9577 (let ((sn-loc (if loc (sn-opnd loc sn) sn)))9578 (let* ((first-opnd (car opnds))9579 (second-opnd (cadr opnds))9580 (sn-second-opnd (sn-opnd second-opnd sn-loc)))9581 (move-opnd-to-loc68 first-opnd atemp1 sn-second-opnd)9582 (if (and loc (not (eq? first-opnd loc)))9583 (move-opnd-to-loc689584 second-opnd9585 (make-disp atemp1 (- pointer-size))9586 sn-loc)9587 (move-opnd-to-loc68 second-opnd (make-pdec atemp1) sn-loc))9588 (if (and loc (not (eq? first-opnd loc)))9589 (move-opnd68-to-loc atemp1 loc sn)))))9590(define (commut-oper gen opnds loc sn self? accum-self accum-other)9591 (if (null? opnds)9592 (gen (reverse accum-self) (reverse accum-other) loc sn self?)9593 (let ((opnd (car opnds)) (rest (cdr opnds)))9594 (cond ((and (not self?) (eq? opnd loc))9595 (commut-oper gen rest loc sn #t accum-self accum-other))9596 ((contains-opnd? loc opnd)9597 (commut-oper9598 gen9599 rest9600 loc9601 sn9602 self?9603 (cons opnd accum-self)9604 accum-other))9605 (else9606 (commut-oper9607 gen9608 rest9609 loc9610 sn9611 self?9612 accum-self9613 (cons opnd accum-other)))))))9614(define (gen-add-in-place opnds loc68 sn)9615 (if (not (null? opnds))9616 (let* ((first-opnd (car opnds))9617 (other-opnds (cdr opnds))9618 (sn-other-opnds (sn-opnds other-opnds sn))9619 (sn-first-opnd (sn-opnd first-opnd sn-other-opnds))9620 (opnd68 (opnd->opnd689621 first-opnd9622 (temp-in-opnd68 loc68)9623 (sn-opnd68 loc68 sn))))9624 (make-top-of-frame-if-stk-opnds68 opnd68 loc68 sn-other-opnds)9625 (if (imm? opnd68)9626 (add-n-to-loc689627 (imm-val opnd68)9628 (opnd68->true-opnd68 loc68 sn-other-opnds))9629 (let ((opnd68* (opnd68->true-opnd68 opnd68 sn-other-opnds)))9630 (if (or (dreg? opnd68) (reg68? loc68))9631 (emit-add.l9632 opnd68*9633 (opnd68->true-opnd68 loc68 sn-other-opnds))9634 (begin9635 (move-opnd68-to-loc68 opnd68* dtemp1)9636 (emit-add.l9637 dtemp19638 (opnd68->true-opnd68 loc68 sn-other-opnds))))))9639 (gen-add-in-place other-opnds loc68 sn))))9640(define (gen-add self-opnds other-opnds loc sn self?)9641 (let* ((opnds (append self-opnds other-opnds))9642 (first-opnd (car opnds))9643 (other-opnds (cdr opnds))9644 (sn-other-opnds (sn-opnds other-opnds sn))9645 (sn-first-opnd (sn-opnd first-opnd sn-other-opnds)))9646 (if (<= (length self-opnds) 1)9647 (let ((loc68 (loc->loc68 loc #f sn-first-opnd)))9648 (if self?9649 (gen-add-in-place opnds loc68 sn)9650 (begin9651 (move-opnd-to-loc68 first-opnd loc68 sn-other-opnds)9652 (gen-add-in-place other-opnds loc68 sn))))9653 (begin9654 (move-opnd-to-loc68 first-opnd dtemp1 (sn-opnd loc sn-other-opnds))9655 (gen-add-in-place other-opnds dtemp1 (sn-opnd loc sn))9656 (if self?9657 (let ((loc68 (loc->loc68 loc dtemp1 sn)))9658 (make-top-of-frame-if-stk-opnd68 loc68 sn)9659 (emit-add.l dtemp1 (opnd68->true-opnd68 loc68 sn)))9660 (move-opnd68-to-loc dtemp1 loc sn))))))9661(define (gen-sub-in-place opnds loc68 sn)9662 (if (not (null? opnds))9663 (let* ((first-opnd (car opnds))9664 (other-opnds (cdr opnds))9665 (sn-other-opnds (sn-opnds other-opnds sn))9666 (sn-first-opnd (sn-opnd first-opnd sn-other-opnds))9667 (opnd68 (opnd->opnd689668 first-opnd9669 (temp-in-opnd68 loc68)9670 (sn-opnd68 loc68 sn))))9671 (make-top-of-frame-if-stk-opnds68 opnd68 loc68 sn-other-opnds)9672 (if (imm? opnd68)9673 (add-n-to-loc689674 (- (imm-val opnd68))9675 (opnd68->true-opnd68 loc68 sn-other-opnds))9676 (let ((opnd68* (opnd68->true-opnd68 opnd68 sn-other-opnds)))9677 (if (or (dreg? opnd68) (reg68? loc68))9678 (emit-sub.l9679 opnd68*9680 (opnd68->true-opnd68 loc68 sn-other-opnds))9681 (begin9682 (move-opnd68-to-loc68 opnd68* dtemp1)9683 (emit-sub.l9684 dtemp19685 (opnd68->true-opnd68 loc68 sn-other-opnds))))))9686 (gen-sub-in-place other-opnds loc68 sn))))9687(define (gen-sub first-opnd other-opnds loc sn self-opnds?)9688 (if (null? other-opnds)9689 (if (and (or (reg? loc) (stk? loc)) (not (eq? loc return-reg)))9690 (begin9691 (copy-opnd-to-loc first-opnd loc (sn-opnd loc sn))9692 (let ((loc68 (loc->loc68 loc #f sn)))9693 (make-top-of-frame-if-stk-opnd68 loc68 sn)9694 (emit-neg.l (opnd68->true-opnd68 loc68 sn))))9695 (begin9696 (move-opnd-to-loc68 first-opnd dtemp1 (sn-opnd loc sn))9697 (emit-neg.l dtemp1)9698 (move-opnd68-to-loc dtemp1 loc sn)))9699 (let* ((sn-other-opnds (sn-opnds other-opnds sn))9700 (sn-first-opnd (sn-opnd first-opnd sn-other-opnds)))9701 (if (and (not self-opnds?) (or (reg? loc) (stk? loc)))9702 (let ((loc68 (loc->loc68 loc #f sn-first-opnd)))9703 (if (not (eq? first-opnd loc))9704 (move-opnd-to-loc68 first-opnd loc68 sn-other-opnds))9705 (gen-sub-in-place other-opnds loc68 sn))9706 (begin9707 (move-opnd-to-loc689708 first-opnd9709 dtemp19710 (sn-opnd loc sn-other-opnds))9711 (gen-sub-in-place other-opnds dtemp1 (sn-opnd loc sn))9712 (move-opnd68-to-loc dtemp1 loc sn))))))9713(define (gen-mul-in-place opnds reg68 sn)9714 (if (not (null? opnds))9715 (let* ((first-opnd (car opnds))9716 (other-opnds (cdr opnds))9717 (sn-other-opnds (sn-opnds other-opnds sn))9718 (opnd68 (opnd->opnd68 first-opnd (temp-in-opnd68 reg68) sn)))9719 (make-top-of-frame-if-stk-opnd68 opnd68 sn-other-opnds)9720 (if (imm? opnd68)9721 (mul-n-to-reg68 (quotient (imm-val opnd68) 8) reg68)9722 (begin9723 (emit-asr.l (make-imm 3) reg68)9724 (emit-muls.l (opnd68->true-opnd68 opnd68 sn-other-opnds) reg68)))9725 (gen-mul-in-place other-opnds reg68 sn))))9726(define (gen-mul self-opnds other-opnds loc sn self?)9727 (let* ((opnds (append self-opnds other-opnds))9728 (first-opnd (car opnds))9729 (other-opnds (cdr opnds))9730 (sn-other-opnds (sn-opnds other-opnds sn))9731 (sn-first-opnd (sn-opnd first-opnd sn-other-opnds)))9732 (if (null? self-opnds)9733 (let ((loc68 (loc->loc68 loc #f sn-first-opnd)))9734 (if self?9735 (gen-mul-in-place opnds loc68 sn)9736 (begin9737 (move-opnd-to-loc68 first-opnd loc68 sn-other-opnds)9738 (gen-mul-in-place other-opnds loc68 sn))))9739 (begin9740 (move-opnd-to-loc68 first-opnd dtemp1 (sn-opnd loc sn-other-opnds))9741 (gen-mul-in-place other-opnds dtemp1 (sn-opnd loc sn))9742 (if self?9743 (let ((loc68 (loc->loc68 loc dtemp1 sn)))9744 (make-top-of-frame-if-stk-opnd68 loc68 sn)9745 (emit-asr.l (make-imm 3) dtemp1)9746 (emit-muls.l dtemp1 (opnd68->true-opnd68 loc68 sn)))9747 (move-opnd68-to-loc dtemp1 loc sn))))))9748(define (gen-div-in-place opnds reg68 sn)9749 (if (not (null? opnds))9750 (let* ((first-opnd (car opnds))9751 (other-opnds (cdr opnds))9752 (sn-other-opnds (sn-opnds other-opnds sn))9753 (sn-first-opnd (sn-opnd first-opnd sn-other-opnds))9754 (opnd68 (opnd->opnd68 first-opnd (temp-in-opnd68 reg68) sn)))9755 (make-top-of-frame-if-stk-opnd68 opnd68 sn-other-opnds)9756 (if (imm? opnd68)9757 (let ((n (quotient (imm-val opnd68) 8)))9758 (div-n-to-reg68 n reg68)9759 (if (> (abs n) 1) (emit-and.w (make-imm -8) reg68)))9760 (let ((opnd68* (opnd68->true-opnd68 opnd68 sn-other-opnds)))9761 (emit-divsl.l opnd68* reg68 reg68)9762 (emit-asl.l (make-imm 3) reg68)))9763 (gen-div-in-place other-opnds reg68 sn))))9764(define (gen-div first-opnd other-opnds loc sn self-opnds?)9765 (if (null? other-opnds)9766 (begin9767 (move-opnd-to-loc68 first-opnd pdec-sp (sn-opnd loc sn))9768 (emit-moveq 8 dtemp1)9769 (emit-divsl.l pinc-sp dtemp1 dtemp1)9770 (emit-asl.l (make-imm 3) dtemp1)9771 (emit-and.w (make-imm -8) dtemp1)9772 (move-opnd68-to-loc dtemp1 loc sn))9773 (let* ((sn-other-opnds (sn-opnds other-opnds sn))9774 (sn-first-opnd (sn-opnd first-opnd sn-other-opnds)))9775 (if (and (reg? loc) (not self-opnds?) (not (eq? loc return-reg)))9776 (let ((reg68 (reg->reg68 loc)))9777 (if (not (eq? first-opnd loc))9778 (move-opnd-to-loc68 first-opnd reg68 sn-other-opnds))9779 (gen-div-in-place other-opnds reg68 sn))9780 (begin9781 (move-opnd-to-loc689782 first-opnd9783 dtemp19784 (sn-opnd loc sn-other-opnds))9785 (gen-div-in-place other-opnds dtemp1 (sn-opnd loc sn))9786 (move-opnd68-to-loc dtemp1 loc sn))))))9787(define (gen-rem first-opnd second-opnd loc sn)9788 (let* ((sn-loc (sn-opnd loc sn))9789 (sn-second-opnd (sn-opnd second-opnd sn-loc)))9790 (move-opnd-to-loc68 first-opnd dtemp1 sn-second-opnd)9791 (let ((opnd68 (opnd->opnd68 second-opnd #f sn-loc))9792 (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))9793 (reg->reg68 loc)9794 false-reg)))9795 (make-top-of-frame-if-stk-opnd68 opnd68 sn-loc)9796 (let ((opnd68* (if (areg? opnd68)9797 (begin (emit-move.l opnd68 reg68) reg68)9798 (opnd68->true-opnd68 opnd68 sn-loc))))9799 (emit-divsl.l opnd68* reg68 dtemp1))9800 (move-opnd68-to-loc reg68 loc sn)9801 (if (not (and (reg? loc) (not (eq? loc return-reg))))9802 (emit-move.l (make-imm bits-false) false-reg)))))9803(define (gen-mod first-opnd second-opnd loc sn)9804 (let* ((sn-loc (sn-opnd loc sn))9805 (sn-first-opnd (sn-opnd first-opnd sn-loc))9806 (sn-second-opnd (sn-opnd second-opnd sn-first-opnd))9807 (opnd68 (opnd->opnd68 second-opnd #f sn-second-opnd)))9808 (define (general-case)9809 (let ((lbl1 (new-lbl!))9810 (lbl2 (new-lbl!))9811 (lbl3 (new-lbl!))9812 (opnd68** (opnd68->true-opnd68 opnd68 sn-second-opnd))9813 (opnd68* (opnd68->true-opnd689814 (opnd->opnd68 first-opnd #f sn-second-opnd)9815 sn-second-opnd)))9816 (move-opnd68-to-loc68 opnd68* dtemp1)9817 (move-opnd68-to-loc68 opnd68** false-reg)9818 (emit-divsl.l false-reg false-reg dtemp1)9819 (emit-move.l false-reg false-reg)9820 (emit-beq lbl3)9821 (move-opnd68-to-loc68 opnd68* dtemp1)9822 (emit-bmi lbl1)9823 (move-opnd68-to-loc68 opnd68** dtemp1)9824 (emit-bpl lbl3)9825 (emit-bra lbl2)9826 (emit-label lbl1)9827 (move-opnd68-to-loc68 opnd68** dtemp1)9828 (emit-bmi lbl3)9829 (emit-label lbl2)9830 (emit-add.l dtemp1 false-reg)9831 (emit-label lbl3)9832 (move-opnd68-to-loc false-reg loc sn)9833 (emit-move.l (make-imm bits-false) false-reg)))9834 (make-top-of-frame-if-stk-opnd68 opnd68 sn-first-opnd)9835 (if (imm? opnd68)9836 (let ((n (quotient (imm-val opnd68) 8)))9837 (if (> n 0)9838 (let ((shift (power-of-2 n)))9839 (if shift9840 (let ((reg68 (if (and (reg? loc)9841 (not (eq? loc return-reg)))9842 (reg->reg68 loc)9843 dtemp1)))9844 (move-opnd-to-loc68 first-opnd reg68 sn-loc)9845 (emit-and.l (make-imm (* (- n 1) 8)) reg68)9846 (move-opnd68-to-loc reg68 loc sn))9847 (general-case)))9848 (general-case)))9849 (general-case))))9850(define (gen-op emit-op dst-ok?)9851 (define (gen-op-in-place opnds loc68 sn)9852 (if (not (null? opnds))9853 (let* ((first-opnd (car opnds))9854 (other-opnds (cdr opnds))9855 (sn-other-opnds (sn-opnds other-opnds sn))9856 (sn-first-opnd (sn-opnd first-opnd sn-other-opnds))9857 (opnd68 (opnd->opnd689858 first-opnd9859 (temp-in-opnd68 loc68)9860 (sn-opnd68 loc68 sn))))9861 (make-top-of-frame-if-stk-opnds68 opnd68 loc68 sn-other-opnds)9862 (if (imm? opnd68)9863 (emit-op opnd68 (opnd68->true-opnd68 loc68 sn-other-opnds))9864 (let ((opnd68* (opnd68->true-opnd68 opnd68 sn-other-opnds)))9865 (if (or (dreg? opnd68) (dst-ok? loc68))9866 (emit-op opnd68*9867 (opnd68->true-opnd68 loc68 sn-other-opnds))9868 (begin9869 (move-opnd68-to-loc68 opnd68* dtemp1)9870 (emit-op dtemp19871 (opnd68->true-opnd68 loc68 sn-other-opnds))))))9872 (gen-op-in-place other-opnds loc68 sn))))9873 (lambda (self-opnds other-opnds loc sn self?)9874 (let* ((opnds (append self-opnds other-opnds))9875 (first-opnd (car opnds))9876 (other-opnds (cdr opnds))9877 (sn-other-opnds (sn-opnds other-opnds sn))9878 (sn-first-opnd (sn-opnd first-opnd sn-other-opnds)))9879 (if (<= (length self-opnds) 1)9880 (let ((loc68 (loc->loc68 loc #f sn-first-opnd)))9881 (if self?9882 (gen-op-in-place opnds loc68 sn)9883 (begin9884 (move-opnd-to-loc68 first-opnd loc68 sn-other-opnds)9885 (gen-op-in-place other-opnds loc68 sn))))9886 (begin9887 (move-opnd-to-loc68 first-opnd dtemp1 (sn-opnd loc sn-other-opnds))9888 (gen-op-in-place other-opnds dtemp1 (sn-opnd loc sn))9889 (if self?9890 (let ((loc68 (loc->loc68 loc dtemp1 sn)))9891 (make-top-of-frame-if-stk-opnd68 loc68 sn)9892 (emit-op dtemp1 (opnd68->true-opnd68 loc68 sn)))9893 (move-opnd68-to-loc dtemp1 loc sn)))))))9894(define gen-logior (gen-op emit-or.l dreg?))9895(define gen-logxor (gen-op emit-eor.l (lambda (x) #f)))9896(define gen-logand (gen-op emit-and.l dreg?))9897(define (gen-shift right-shift)9898 (lambda (opnds loc sn)9899 (let ((sn-loc (sn-opnd loc sn)))9900 (let* ((opnd1 (car opnds))9901 (opnd2 (cadr opnds))9902 (sn-opnd1 (sn-opnd opnd1 sn-loc))9903 (o2 (opnd->opnd68 opnd2 #f sn-opnd1)))9904 (make-top-of-frame-if-stk-opnd68 o2 sn-opnd1)9905 (if (imm? o2)9906 (let* ((reg68 (if (and (reg? loc) (not (eq? loc return-reg)))9907 (reg->reg68 loc)9908 dtemp1))9909 (n (quotient (imm-val o2) 8))9910 (emit-shft (if (> n 0) emit-lsl.l right-shift)))9911 (move-opnd-to-loc68 opnd1 reg68 sn-loc)9912 (let loop ((i (min (abs n) 29)))9913 (if (> i 0)9914 (begin9915 (emit-shft (make-imm (min i 8)) reg68)9916 (loop (- i 8)))))9917 (if (< n 0) (emit-and.w (make-imm -8) reg68))9918 (move-opnd68-to-loc reg68 loc sn))9919 (let* ((reg68 (if (and (reg? loc) (not (eq? loc return-reg)))9920 (reg->reg68 loc)9921 dtemp1))9922 (reg68* (if (and (reg? loc) (not (eq? loc return-reg)))9923 dtemp19924 false-reg))9925 (lbl1 (new-lbl!))9926 (lbl2 (new-lbl!)))9927 (emit-move.l (opnd68->true-opnd68 o2 sn-opnd1) reg68*)9928 (move-opnd-to-loc68 opnd1 reg68 sn-loc)9929 (emit-asr.l (make-imm 3) reg68*)9930 (emit-bmi lbl1)9931 (emit-lsl.l reg68* reg68)9932 (emit-bra lbl2)9933 (emit-label lbl1)9934 (emit-neg.l reg68*)9935 (right-shift reg68* reg68)9936 (emit-and.w (make-imm -8) reg68)9937 (emit-label lbl2)9938 (move-opnd68-to-loc reg68 loc sn)9939 (if (not (and (reg? loc) (not (eq? loc return-reg))))9940 (emit-move.l (make-imm bits-false) false-reg))))))))9941(define (flo-oper oper1 oper2 opnds loc sn)9942 (gen-guarantee-space 2)9943 (move-opnd-to-loc689944 (car opnds)9945 atemp19946 (sn-opnds (cdr opnds) (sn-opnd loc sn)))9947 (oper1 (make-disp* atemp1 (- type-flonum)) ftemp1)9948 (let loop ((opnds (cdr opnds)))9949 (if (not (null? opnds))9950 (let* ((opnd (car opnds))9951 (other-opnds (cdr opnds))9952 (sn-other-opnds (sn-opnds other-opnds sn)))9953 (move-opnd-to-loc68 opnd atemp1 sn-other-opnds)9954 (oper2 (make-disp* atemp1 (- type-flonum)) ftemp1)9955 (loop (cdr opnds)))))9956 (add-n-to-loc68 (* -2 pointer-size) heap-reg)9957 (emit-fmov.dx ftemp1 (make-ind heap-reg))9958 (let ((reg68 (if (reg? loc) (reg->reg68 loc) atemp1)))9959 (emit-move.l heap-reg reg68)9960 (emit-addq.l type-flonum reg68))9961 (if (not (reg? loc)) (move-opnd68-to-loc atemp1 loc sn)))9962(define (gen-make-placeholder opnds loc sn)9963 (let ((sn-loc (sn-opnd loc sn)))9964 (let ((opnd (car opnds)))9965 (gen-guarantee-space 4)9966 (emit-clr.l (make-pdec heap-reg))9967 (move-opnd-to-loc68 opnd (make-pdec heap-reg) sn-loc)9968 (emit-move.l null-reg (make-pdec heap-reg))9969 (move-opnd68-to-loc68 heap-reg atemp2)9970 (emit-addq.l (modulo (- type-placeholder type-pair) 8) atemp2)9971 (emit-move.l atemp2 (make-pdec heap-reg))9972 (move-opnd68-to-loc atemp2 loc sn))))9973(define (gen-subprocedure-id opnds loc sn)9974 (let ((sn-loc (sn-opnd loc sn))9975 (opnd (car opnds))9976 (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))9977 (reg->reg68 loc)9978 dtemp1)))9979 (move-opnd-to-loc68 opnd atemp1 sn-loc)9980 (move-n-to-loc68 32768 reg68)9981 (emit-sub.w (make-disp* atemp1 -2) reg68)9982 (move-opnd68-to-loc reg68 loc sn)))9983(define (gen-subprocedure-parent opnds loc sn)9984 (let ((sn-loc (sn-opnd loc sn)) (opnd (car opnds)))9985 (move-opnd-to-loc68 opnd atemp1 sn-loc)9986 (emit-add.w (make-disp* atemp1 -2) atemp1)9987 (add-n-to-loc68 -32768 atemp1)9988 (move-opnd68-to-loc atemp1 loc sn)))9989(define (gen-return-fs opnds loc sn)9990 (let ((sn-loc (sn-opnd loc sn))9991 (opnd (car opnds))9992 (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))9993 (reg->reg68 loc)9994 dtemp1))9995 (lbl (new-lbl!)))9996 (move-opnd-to-loc68 opnd atemp1 sn-loc)9997 (emit-moveq 0 reg68)9998 (emit-move.w (make-disp* atemp1 -6) reg68)9999 (emit-beq lbl)10000 (emit-and.w (make-imm 32767) reg68)10001 (emit-subq.l 8 reg68)10002 (emit-label lbl)10003 (emit-addq.l 8 reg68)10004 (emit-asl.l (make-imm 1) reg68)10005 (move-opnd68-to-loc reg68 loc sn)))10006(define (gen-return-link opnds loc sn)10007 (let ((sn-loc (sn-opnd loc sn))10008 (opnd (car opnds))10009 (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))10010 (reg->reg68 loc)10011 dtemp1))10012 (lbl (new-lbl!)))10013 (move-opnd-to-loc68 opnd atemp1 sn-loc)10014 (emit-moveq 0 reg68)10015 (emit-move.w (make-disp* atemp1 -6) reg68)10016 (emit-beq lbl)10017 (emit-and.w (make-imm 32767) reg68)10018 (emit-subq.l 8 reg68)10019 (emit-label lbl)10020 (emit-addq.l 8 reg68)10021 (emit-sub.w (make-disp* atemp1 -4) reg68)10022 (emit-asl.l (make-imm 1) reg68)10023 (move-opnd68-to-loc reg68 loc sn)))10024(define (gen-procedure-info opnds loc sn)10025 (let ((sn-loc (sn-opnd loc sn)) (opnd (car opnds)))10026 (move-opnd-to-loc68 opnd atemp1 sn-loc)10027 (emit-add.w (make-disp* atemp1 -2) atemp1)10028 (move-opnd68-to-loc (make-disp* atemp1 (- 32768 6)) loc sn)))10029(define (gen-guarantee-space n)10030 (set! pointers-allocated (+ pointers-allocated n))10031 (if (> pointers-allocated heap-allocation-fudge)10032 (begin (gen-guarantee-fudge) (set! pointers-allocated n))))10033(define (gen-guarantee-fudge)10034 (if (> pointers-allocated 0)10035 (let ((lbl (new-lbl!)))10036 (emit-cmp.l heap-lim-slot heap-reg)10037 (emit-bcc lbl)10038 (gen-trap instr-source entry-frame #f #f heap-alloc1-trap lbl)10039 (set! pointers-allocated 0))))10040(define pointers-allocated '())10041(define (gen-type opnds loc sn)10042 (let* ((sn-loc (sn-opnd loc sn))10043 (opnd (car opnds))10044 (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))10045 (reg->reg68 loc)10046 dtemp1)))10047 (move-opnd-to-loc68 opnd reg68 sn-loc)10048 (emit-and.l (make-imm 7) reg68)10049 (emit-asl.l (make-imm 3) reg68)10050 (move-opnd68-to-loc reg68 loc sn)))10051(define (gen-type-cast opnds loc sn)10052 (let ((sn-loc (if loc (sn-opnd loc sn) sn)))10053 (let ((first-opnd (car opnds)) (second-opnd (cadr opnds)))10054 (let* ((sn-loc (if (and loc (not (eq? first-opnd loc))) sn-loc sn))10055 (o1 (opnd->opnd68 first-opnd #f (sn-opnd second-opnd sn-loc)))10056 (o2 (opnd->opnd68 second-opnd (temp-in-opnd68 o1) sn-loc))10057 (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))10058 (reg->reg68 loc)10059 dtemp1)))10060 (make-top-of-frame-if-stk-opnds68 o1 o2 sn-loc)10061 (move-opnd68-to-loc6810062 (opnd68->true-opnd68 o1 (sn-opnd68 o2 sn-loc))10063 reg68)10064 (emit-and.w (make-imm -8) reg68)10065 (if (imm? o2)10066 (let ((n (quotient (imm-val o2) 8)))10067 (if (> n 0) (emit-addq.w n reg68)))10068 (begin10069 (move-opnd68-to-loc68 (opnd68->true-opnd68 o2 sn-loc) atemp1)10070 (emit-exg atemp1 reg68)10071 (emit-asr.l (make-imm 3) reg68)10072 (emit-add.l atemp1 reg68)))10073 (move-opnd68-to-loc reg68 loc sn)))))10074(define (gen-subtype opnds loc sn)10075 (let ((sn-loc (sn-opnd loc sn))10076 (opnd (car opnds))10077 (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))10078 (reg->reg68 loc)10079 dtemp1)))10080 (move-opnd-to-loc68 opnd atemp1 sn-loc)10081 (emit-moveq 0 reg68)10082 (emit-move.b (make-ind atemp1) reg68)10083 (move-opnd68-to-loc reg68 loc sn)))10084(define (gen-subtype-set! opnds loc sn)10085 (let ((sn-loc (if loc (sn-opnd loc sn) sn)))10086 (let ((first-opnd (car opnds)) (second-opnd (cadr opnds)))10087 (let* ((sn-loc (if (and loc (not (eq? first-opnd loc))) sn-loc sn))10088 (o1 (opnd->opnd68 first-opnd #f (sn-opnd second-opnd sn-loc)))10089 (o2 (opnd->opnd68 second-opnd (temp-in-opnd68 o1) sn-loc)))10090 (make-top-of-frame-if-stk-opnds68 o1 o2 sn-loc)10091 (move-opnd68-to-loc6810092 (opnd68->true-opnd68 o1 (sn-opnd68 o2 sn-loc))10093 atemp1)10094 (if (imm? o2)10095 (emit-move.b (make-imm (imm-val o2)) (make-ind atemp1))10096 (begin10097 (move-opnd68-to-loc68 (opnd68->true-opnd68 o2 sn-loc) dtemp1)10098 (emit-move.b dtemp1 (make-ind atemp1))))10099 (if (and loc (not (eq? first-opnd loc)))10100 (move-opnd68-to-loc atemp1 loc sn))))))10101(define (vector-select kind vector string vector8 vector16)10102 (case kind10103 ((string) string)10104 ((vector8) vector8)10105 ((vector16) vector16)10106 (else vector)))10107(define (obj-vector? kind) (vector-select kind #t #f #f #f))10108(define (make-gen-vector kind)10109 (lambda (opnds loc sn)10110 (let ((sn-loc (if loc (sn-opnd loc sn) sn)))10111 (let* ((n (length opnds))10112 (bytes (+ pointer-size10113 (* (vector-select kind 4 1 1 2)10114 (+ n (if (eq? kind 'string) 1 0)))))10115 (adjust (modulo (- bytes) 8)))10116 (gen-guarantee-space10117 (quotient (* (quotient (+ bytes (- 8 1)) 8) 8) pointer-size))10118 (if (not (= adjust 0)) (emit-subq.l adjust heap-reg))10119 (if (eq? kind 'string) (emit-move.b (make-imm 0) (make-pdec heap-reg)))10120 (let loop ((opnds (reverse opnds)))10121 (if (pair? opnds)10122 (let* ((o (car opnds)) (sn-o (sn-opnds (cdr opnds) sn-loc)))10123 (if (eq? kind 'vector)10124 (move-opnd-to-loc68 o (make-pdec heap-reg) sn-o)10125 (begin10126 (move-opnd-to-loc68 o dtemp1 sn-o)10127 (emit-asr.l (make-imm 3) dtemp1)10128 (if (eq? kind 'vector16)10129 (emit-move.w dtemp1 (make-pdec heap-reg))10130 (emit-move.b dtemp1 (make-pdec heap-reg)))))10131 (loop (cdr opnds)))))10132 (emit-move.l10133 (make-imm10134 (+ (* 256 (- bytes pointer-size))10135 (* 8 (if (eq? kind 'vector) subtype-vector subtype-string))))10136 (make-pdec heap-reg))10137 (if loc10138 (begin10139 (emit-lea (make-disp* heap-reg type-subtyped) atemp2)10140 (move-opnd68-to-loc atemp2 loc sn)))))))10141(define (make-gen-vector-length kind)10142 (lambda (opnds loc sn)10143 (let ((sn-loc (sn-opnd loc sn))10144 (opnd (car opnds))10145 (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))10146 (reg->reg68 loc)10147 dtemp1)))10148 (move-opnd-to-loc68 opnd atemp1 sn-loc)10149 (move-opnd68-to-loc68 (make-disp* atemp1 (- type-subtyped)) reg68)10150 (emit-lsr.l (make-imm (vector-select kind 7 5 5 6)) reg68)10151 (if (not (eq? kind 'vector))10152 (begin10153 (emit-and.w (make-imm -8) reg68)10154 (if (eq? kind 'string) (emit-subq.l 8 reg68))))10155 (move-opnd68-to-loc reg68 loc sn))))10156(define (make-gen-vector-ref kind)10157 (lambda (opnds loc sn)10158 (let ((sn-loc (sn-opnd loc sn)))10159 (let ((first-opnd (car opnds))10160 (second-opnd (cadr opnds))10161 (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))10162 (reg->reg68 loc)10163 dtemp1)))10164 (let* ((o2 (opnd->opnd68 second-opnd #f (sn-opnd first-opnd sn-loc)))10165 (o1 (opnd->opnd68 first-opnd (temp-in-opnd68 o2) sn-loc)))10166 (make-top-of-frame-if-stk-opnds68 o1 o2 sn-loc)10167 (let* ((offset (if (eq? kind 'closure)10168 (- pointer-size type-procedure)10169 (- pointer-size type-subtyped)))10170 (loc68 (if (imm? o2)10171 (begin10172 (move-opnd68-to-loc6810173 (opnd68->true-opnd68 o1 sn-loc)10174 atemp1)10175 (make-disp*10176 atemp110177 (+ (quotient10178 (imm-val o2)10179 (vector-select kind 2 8 8 4))10180 offset)))10181 (begin10182 (move-opnd68-to-loc6810183 (opnd68->true-opnd68 o2 (sn-opnd68 o1 sn-loc))10184 dtemp1)10185 (emit-asr.l10186 (make-imm (vector-select kind 1 3 3 2))10187 dtemp1)10188 (move-opnd68-to-loc6810189 (opnd68->true-opnd68 o1 sn-loc)10190 atemp1)10191 (if (and (identical-opnd68? reg68 dtemp1)10192 (not (obj-vector? kind)))10193 (begin10194 (emit-move.l dtemp1 atemp2)10195 (make-inx atemp1 atemp2 offset))10196 (make-inx atemp1 dtemp1 offset))))))10197 (if (not (obj-vector? kind)) (emit-moveq 0 reg68))10198 (case kind10199 ((string vector8) (emit-move.b loc68 reg68))10200 ((vector16) (emit-move.w loc68 reg68))10201 (else (emit-move.l loc68 reg68)))10202 (if (not (obj-vector? kind))10203 (begin10204 (emit-asl.l (make-imm 3) reg68)10205 (if (eq? kind 'string) (emit-addq.w type-special reg68))))10206 (move-opnd68-to-loc reg68 loc sn)))))))10207(define (make-gen-vector-set! kind)10208 (lambda (opnds loc sn)10209 (let ((sn-loc (if loc (sn-opnd loc sn) sn)))10210 (let ((first-opnd (car opnds))10211 (second-opnd (cadr opnds))10212 (third-opnd (caddr opnds)))10213 (let* ((sn-loc (if (and loc (not (eq? first-opnd loc)))10214 (sn-opnd first-opnd sn-loc)10215 sn))10216 (sn-third-opnd (sn-opnd third-opnd sn-loc))10217 (o2 (opnd->opnd6810218 second-opnd10219 #f10220 (sn-opnd first-opnd sn-third-opnd)))10221 (o1 (opnd->opnd6810222 first-opnd10223 (temp-in-opnd68 o2)10224 sn-third-opnd)))10225 (make-top-of-frame-if-stk-opnds68 o1 o2 sn-third-opnd)10226 (let* ((offset (if (eq? kind 'closure)10227 (- pointer-size type-procedure)10228 (- pointer-size type-subtyped)))10229 (loc68 (if (imm? o2)10230 (begin10231 (move-opnd68-to-loc6810232 (opnd68->true-opnd68 o1 sn-third-opnd)10233 atemp1)10234 (make-disp*10235 atemp110236 (+ (quotient10237 (imm-val o2)10238 (vector-select kind 2 8 8 4))10239 offset)))10240 (begin10241 (move-opnd68-to-loc6810242 (opnd68->true-opnd68 o2 (sn-opnd68 o1 sn-loc))10243 dtemp1)10244 (emit-asr.l10245 (make-imm (vector-select kind 1 3 3 2))10246 dtemp1)10247 (move-opnd68-to-loc6810248 (opnd68->true-opnd68 o1 sn-loc)10249 atemp1)10250 (if (obj-vector? kind)10251 (make-inx atemp1 dtemp1 offset)10252 (begin10253 (emit-move.l dtemp1 atemp2)10254 (make-inx atemp1 atemp2 offset)))))))10255 (if (obj-vector? kind)10256 (move-opnd-to-loc68 third-opnd loc68 sn-loc)10257 (begin10258 (move-opnd-to-loc68 third-opnd dtemp1 sn-loc)10259 (emit-asr.l (make-imm 3) dtemp1)10260 (if (eq? kind 'vector16)10261 (emit-move.w dtemp1 loc68)10262 (emit-move.b dtemp1 loc68))))10263 (if (and loc (not (eq? first-opnd loc)))10264 (copy-opnd-to-loc first-opnd loc sn))))))))10265(define (make-gen-vector-shrink! kind)10266 (lambda (opnds loc sn)10267 (let ((sn-loc (if loc (sn-opnd loc sn) sn)))10268 (let ((first-opnd (car opnds)) (second-opnd (cadr opnds)))10269 (let* ((sn-loc (if (and loc (not (eq? first-opnd loc)))10270 (sn-opnd first-opnd sn-loc)10271 sn))10272 (o2 (opnd->opnd68 second-opnd #f (sn-opnd first-opnd sn-loc)))10273 (o1 (opnd->opnd68 first-opnd (temp-in-opnd68 o2) sn-loc)))10274 (make-top-of-frame-if-stk-opnds68 o1 o2 sn-loc)10275 (move-opnd68-to-loc6810276 (opnd68->true-opnd68 o2 (sn-opnd68 o1 sn-loc))10277 dtemp1)10278 (emit-move.l (opnd68->true-opnd68 o1 sn-loc) atemp1)10279 (if (eq? kind 'string)10280 (begin10281 (emit-asr.l (make-imm 3) dtemp1)10282 (emit-move.b10283 (make-imm 0)10284 (make-inx atemp1 dtemp1 (- pointer-size type-subtyped)))10285 (emit-addq.l 1 dtemp1)10286 (emit-asl.l (make-imm 8) dtemp1))10287 (emit-asl.l (make-imm (vector-select kind 7 5 5 6)) dtemp1))10288 (emit-move.b (make-ind atemp1) dtemp1)10289 (emit-move.l dtemp1 (make-disp* atemp1 (- type-subtyped)))10290 (if (and loc (not (eq? first-opnd loc)))10291 (move-opnd68-to-loc atemp1 loc sn)))))))10292(define (gen-eq-test bits not? opnds lbl fs)10293 (gen-compare* (opnd->opnd68 (car opnds) #f fs) (make-imm bits) fs)10294 (if not? (emit-bne lbl) (emit-beq lbl)))10295(define (gen-compare opnd1 opnd2 fs)10296 (let* ((o1 (opnd->opnd68 opnd1 #f (sn-opnd opnd2 fs)))10297 (o2 (opnd->opnd68 opnd2 (temp-in-opnd68 o1) fs)))10298 (gen-compare* o1 o2 fs)))10299(define (gen-compare* o1 o2 fs)10300 (make-top-of-frame-if-stk-opnds68 o1 o2 fs)10301 (let ((order-1-210302 (cond ((imm? o1)10303 (cmp-n-to-opnd68 (imm-val o1) (opnd68->true-opnd68 o2 fs)))10304 ((imm? o2)10305 (not (cmp-n-to-opnd6810306 (imm-val o2)10307 (opnd68->true-opnd68 o1 fs))))10308 ((reg68? o1) (emit-cmp.l (opnd68->true-opnd68 o2 fs) o1) #f)10309 ((reg68? o2) (emit-cmp.l (opnd68->true-opnd68 o1 fs) o2) #t)10310 (else10311 (emit-move.l (opnd68->true-opnd68 o1 (sn-opnd68 o2 fs)) dtemp1)10312 (emit-cmp.l (opnd68->true-opnd68 o2 fs) dtemp1)10313 #f))))10314 (shrink-frame fs)10315 order-1-2))10316(define (gen-compares branch< branch>= branch> branch<= not? opnds lbl fs)10317 (gen-compares*10318 gen-compare10319 branch<10320 branch>=10321 branch>10322 branch<=10323 not?10324 opnds10325 lbl10326 fs))10327(define (gen-compares*10328 gen-comp10329 branch<10330 branch>=10331 branch>10332 branch<=10333 not?10334 opnds10335 lbl10336 fs)10337 (define (gen-compare-sequence opnd1 opnd2 rest)10338 (if (null? rest)10339 (if (gen-comp opnd1 opnd2 fs)10340 (if not? (branch<= lbl) (branch> lbl))10341 (if not? (branch>= lbl) (branch< lbl)))10342 (let ((order-1-210343 (gen-comp opnd1 opnd2 (sn-opnd opnd2 (sn-opnds rest fs)))))10344 (if (= current-fs fs)10345 (if not?10346 (begin10347 (if order-1-2 (branch<= lbl) (branch>= lbl))10348 (gen-compare-sequence opnd2 (car rest) (cdr rest)))10349 (let ((exit-lbl (new-lbl!)))10350 (if order-1-2 (branch<= exit-lbl) (branch>= exit-lbl))10351 (gen-compare-sequence opnd2 (car rest) (cdr rest))10352 (emit-label exit-lbl)))10353 (if not?10354 (let ((next-lbl (new-lbl!)))10355 (if order-1-2 (branch> next-lbl) (branch< next-lbl))10356 (shrink-frame fs)10357 (emit-bra lbl)10358 (emit-label next-lbl)10359 (gen-compare-sequence opnd2 (car rest) (cdr rest)))10360 (let* ((next-lbl (new-lbl!)) (exit-lbl (new-lbl!)))10361 (if order-1-2 (branch> next-lbl) (branch< next-lbl))10362 (shrink-frame fs)10363 (emit-bra exit-lbl)10364 (emit-label next-lbl)10365 (gen-compare-sequence opnd2 (car rest) (cdr rest))10366 (emit-label exit-lbl)))))))10367 (if (or (null? opnds) (null? (cdr opnds)))10368 (begin (shrink-frame fs) (if (not not?) (emit-bra lbl)))10369 (gen-compare-sequence (car opnds) (cadr opnds) (cddr opnds))))10370(define (gen-compare-flo opnd1 opnd2 fs)10371 (let* ((o1 (opnd->opnd68 opnd1 #f (sn-opnd opnd2 fs)))10372 (o2 (opnd->opnd68 opnd2 (temp-in-opnd68 o1) fs)))10373 (make-top-of-frame-if-stk-opnds68 o1 o2 fs)10374 (emit-move.l (opnd68->true-opnd68 o1 (sn-opnd68 o2 fs)) atemp1)10375 (emit-move.l (opnd68->true-opnd68 o2 fs) atemp2)10376 (emit-fmov.dx (make-disp* atemp2 (- type-flonum)) ftemp1)10377 (emit-fcmp.dx (make-disp* atemp1 (- type-flonum)) ftemp1)10378 #t))10379(define (gen-compares-flo branch< branch>= branch> branch<= not? opnds lbl fs)10380 (gen-compares*10381 gen-compare-flo10382 branch<10383 branch>=10384 branch>10385 branch<=10386 not?10387 opnds10388 lbl10389 fs))10390(define (gen-type-test tag not? opnds lbl fs)10391 (let ((opnd (car opnds)))10392 (let ((o (opnd->opnd68 opnd #f fs)))10393 (define (mask-test set-reg correction)10394 (emit-btst10395 (if (= correction 0)10396 (if (dreg? o)10397 o10398 (begin10399 (emit-move.l (opnd68->true-opnd68 o fs) dtemp1)10400 dtemp1))10401 (begin10402 (if (not (eq? o dtemp1))10403 (emit-move.l (opnd68->true-opnd68 o fs) dtemp1))10404 (emit-addq.w correction dtemp1)10405 dtemp1))10406 set-reg))10407 (make-top-of-frame-if-stk-opnd68 o fs)10408 (cond ((= tag 0)10409 (if (eq? o dtemp1)10410 (emit-and.w (make-imm 7) dtemp1)10411 (begin10412 (emit-move.l (opnd68->true-opnd68 o fs) dtemp1)10413 (emit-and.w (make-imm 7) dtemp1))))10414 ((= tag type-placeholder) (mask-test placeholder-reg 0))10415 (else (mask-test pair-reg (modulo (- type-pair tag) 8))))10416 (shrink-frame fs)10417 (if not? (emit-bne lbl) (emit-beq lbl)))))10418(define (gen-subtype-test type not? opnds lbl fs)10419 (let ((opnd (car opnds)))10420 (let ((o (opnd->opnd68 opnd #f fs)) (cont-lbl (new-lbl!)))10421 (make-top-of-frame-if-stk-opnd68 o fs)10422 (if (not (eq? o dtemp1)) (emit-move.l (opnd68->true-opnd68 o fs) dtemp1))10423 (emit-move.l dtemp1 atemp1)10424 (emit-addq.w (modulo (- type-pair type-subtyped) 8) dtemp1)10425 (emit-btst dtemp1 pair-reg)10426 (shrink-frame fs)10427 (if not? (emit-bne lbl) (emit-bne cont-lbl))10428 (emit-cmp.b (make-imm (* type 8)) (make-ind atemp1))10429 (if not? (emit-bne lbl) (emit-beq lbl))10430 (emit-label cont-lbl))))10431(define (gen-even-test not? opnds lbl fs)10432 (move-opnd-to-loc68 (car opnds) dtemp1 fs)10433 (emit-and.w (make-imm 8) dtemp1)10434 (shrink-frame fs)10435 (if not? (emit-bne lbl) (emit-beq lbl)))10436(define (def-spec name specializer-maker)10437 (let ((proc-name (string->canonical-symbol name)))10438 (let ((proc (prim-info proc-name)))10439 (if proc10440 (proc-obj-specialize-set! proc (specializer-maker proc proc-name))10441 (compiler-internal-error "def-spec, unknown primitive:" name)))))10442(define (safe name)10443 (lambda (proc proc-name)10444 (let ((spec (get-prim-info name))) (lambda (decls) spec))))10445(define (unsafe name)10446 (lambda (proc proc-name)10447 (let ((spec (get-prim-info name)))10448 (lambda (decls) (if (not (safe? decls)) spec proc)))))10449(define (safe-arith fix-name flo-name) (arith #t fix-name flo-name))10450(define (unsafe-arith fix-name flo-name) (arith #f fix-name flo-name))10451(define (arith fix-safe? fix-name flo-name)10452 (lambda (proc proc-name)10453 (let ((fix-spec (if fix-name (get-prim-info fix-name) proc))10454 (flo-spec (if flo-name (get-prim-info flo-name) proc)))10455 (lambda (decls)10456 (let ((arith (arith-implementation proc-name decls)))10457 (cond ((eq? arith fixnum-sym)10458 (if (or fix-safe? (not (safe? decls))) fix-spec proc))10459 ((eq? arith flonum-sym) (if (not (safe? decls)) flo-spec proc))10460 (else proc)))))))10461(define-apply "##TYPE" #f (lambda (opnds loc sn) (gen-type opnds loc sn)))10462(define-apply10463 "##TYPE-CAST"10464 #f10465 (lambda (opnds loc sn) (gen-type-cast opnds loc sn)))10466(define-apply10467 "##SUBTYPE"10468 #f10469 (lambda (opnds loc sn) (gen-subtype opnds loc sn)))10470(define-apply10471 "##SUBTYPE-SET!"10472 #t10473 (lambda (opnds loc sn) (gen-subtype-set! opnds loc sn)))10474(define-ifjump10475 "##NOT"10476 (lambda (not? opnds lbl fs) (gen-eq-test bits-false not? opnds lbl fs)))10477(define-ifjump10478 "##NULL?"10479 (lambda (not? opnds lbl fs) (gen-eq-test bits-null not? opnds lbl fs)))10480(define-ifjump10481 "##UNASSIGNED?"10482 (lambda (not? opnds lbl fs) (gen-eq-test bits-unass not? opnds lbl fs)))10483(define-ifjump10484 "##UNBOUND?"10485 (lambda (not? opnds lbl fs) (gen-eq-test bits-unbound not? opnds lbl fs)))10486(define-ifjump10487 "##EQ?"10488 (lambda (not? opnds lbl fs)10489 (gen-compares emit-beq emit-bne emit-beq emit-bne not? opnds lbl fs)))10490(define-ifjump10491 "##FIXNUM?"10492 (lambda (not? opnds lbl fs) (gen-type-test type-fixnum not? opnds lbl fs)))10493(define-ifjump10494 "##FLONUM?"10495 (lambda (not? opnds lbl fs) (gen-type-test type-flonum not? opnds lbl fs)))10496(define-ifjump10497 "##SPECIAL?"10498 (lambda (not? opnds lbl fs) (gen-type-test type-special not? opnds lbl fs)))10499(define-ifjump10500 "##PAIR?"10501 (lambda (not? opnds lbl fs) (gen-type-test type-pair not? opnds lbl fs)))10502(define-ifjump10503 "##SUBTYPED?"10504 (lambda (not? opnds lbl fs) (gen-type-test type-subtyped not? opnds lbl fs)))10505(define-ifjump10506 "##PROCEDURE?"10507 (lambda (not? opnds lbl fs) (gen-type-test type-procedure not? opnds lbl fs)))10508(define-ifjump10509 "##PLACEHOLDER?"10510 (lambda (not? opnds lbl fs)10511 (gen-type-test type-placeholder not? opnds lbl fs)))10512(define-ifjump10513 "##VECTOR?"10514 (lambda (not? opnds lbl fs)10515 (gen-subtype-test subtype-vector not? opnds lbl fs)))10516(define-ifjump10517 "##SYMBOL?"10518 (lambda (not? opnds lbl fs)10519 (gen-subtype-test subtype-symbol not? opnds lbl fs)))10520(define-ifjump10521 "##RATNUM?"10522 (lambda (not? opnds lbl fs)10523 (gen-subtype-test subtype-ratnum not? opnds lbl fs)))10524(define-ifjump10525 "##CPXNUM?"10526 (lambda (not? opnds lbl fs)10527 (gen-subtype-test subtype-cpxnum not? opnds lbl fs)))10528(define-ifjump10529 "##STRING?"10530 (lambda (not? opnds lbl fs)10531 (gen-subtype-test subtype-string not? opnds lbl fs)))10532(define-ifjump10533 "##BIGNUM?"10534 (lambda (not? opnds lbl fs)10535 (gen-subtype-test subtype-bignum not? opnds lbl fs)))10536(define-ifjump10537 "##CHAR?"10538 (lambda (not? opnds lbl fs)10539 (let ((opnd (car opnds)))10540 (let ((o (opnd->opnd68 opnd #f fs)) (cont-lbl (new-lbl!)))10541 (make-top-of-frame-if-stk-opnd68 o fs)10542 (emit-move.l (opnd68->true-opnd68 o fs) dtemp1)10543 (if not? (emit-bmi lbl) (emit-bmi cont-lbl))10544 (emit-addq.w (modulo (- type-pair type-special) 8) dtemp1)10545 (emit-btst dtemp1 pair-reg)10546 (shrink-frame fs)10547 (if not? (emit-bne lbl) (emit-beq lbl))10548 (emit-label cont-lbl)))))10549(define-ifjump10550 "##CLOSURE?"10551 (lambda (not? opnds lbl fs)10552 (move-opnd-to-loc68 (car opnds) atemp1 fs)10553 (shrink-frame fs)10554 (emit-cmp.w (make-imm 20153) (make-ind atemp1))10555 (if not? (emit-bne lbl) (emit-beq lbl))))10556(define-ifjump10557 "##SUBPROCEDURE?"10558 (lambda (not? opnds lbl fs)10559 (move-opnd-to-loc68 (car opnds) atemp1 fs)10560 (shrink-frame fs)10561 (emit-move.w (make-pdec atemp1) dtemp1)10562 (if not? (emit-bmi lbl) (emit-bpl lbl))))10563(define-ifjump10564 "##RETURN-DYNAMIC-ENV-BIND?"10565 (lambda (not? opnds lbl fs)10566 (move-opnd-to-loc68 (car opnds) atemp1 fs)10567 (shrink-frame fs)10568 (emit-move.w (make-disp* atemp1 -6) dtemp1)10569 (if not? (emit-bne lbl) (emit-beq lbl))))10570(define-apply10571 "##FIXNUM.+"10572 #f10573 (lambda (opnds loc sn)10574 (let ((sn-loc (sn-opnd loc sn)))10575 (cond ((null? opnds) (copy-opnd-to-loc (make-obj '0) loc sn))10576 ((null? (cdr opnds)) (copy-opnd-to-loc (car opnds) loc sn))10577 ((or (reg? loc) (stk? loc))10578 (commut-oper gen-add opnds loc sn #f '() '()))10579 (else (gen-add opnds '() loc sn #f))))))10580(define-apply10581 "##FIXNUM.-"10582 #f10583 (lambda (opnds loc sn)10584 (let ((sn-loc (sn-opnd loc sn)))10585 (gen-sub (car opnds)10586 (cdr opnds)10587 loc10588 sn10589 (any-contains-opnd? loc (cdr opnds))))))10590(define-apply10591 "##FIXNUM.*"10592 #f10593 (lambda (opnds loc sn)10594 (let ((sn-loc (sn-opnd loc sn)))10595 (cond ((null? opnds) (copy-opnd-to-loc (make-obj '1) loc sn))10596 ((null? (cdr opnds)) (copy-opnd-to-loc (car opnds) loc sn))10597 ((and (reg? loc) (not (eq? loc return-reg)))10598 (commut-oper gen-mul opnds loc sn #f '() '()))10599 (else (gen-mul opnds '() loc sn #f))))))10600(define-apply10601 "##FIXNUM.QUOTIENT"10602 #f10603 (lambda (opnds loc sn)10604 (let ((sn-loc (sn-opnd loc sn)))10605 (gen-div (car opnds)10606 (cdr opnds)10607 loc10608 sn10609 (any-contains-opnd? loc (cdr opnds))))))10610(define-apply10611 "##FIXNUM.REMAINDER"10612 #f10613 (lambda (opnds loc sn)10614 (let ((sn-loc (sn-opnd loc sn)))10615 (gen-rem (car opnds) (cadr opnds) loc sn))))10616(define-apply10617 "##FIXNUM.MODULO"10618 #f10619 (lambda (opnds loc sn)10620 (let ((sn-loc (sn-opnd loc sn)))10621 (gen-mod (car opnds) (cadr opnds) loc sn))))10622(define-apply10623 "##FIXNUM.LOGIOR"10624 #f10625 (lambda (opnds loc sn)10626 (let ((sn-loc (sn-opnd loc sn)))10627 (cond ((null? opnds) (copy-opnd-to-loc (make-obj '0) loc sn))10628 ((null? (cdr opnds)) (copy-opnd-to-loc (car opnds) loc sn))10629 ((or (reg? loc) (stk? loc))10630 (commut-oper gen-logior opnds loc sn #f '() '()))10631 (else (gen-logior opnds '() loc sn #f))))))10632(define-apply10633 "##FIXNUM.LOGXOR"10634 #f10635 (lambda (opnds loc sn)10636 (let ((sn-loc (sn-opnd loc sn)))10637 (cond ((null? opnds) (copy-opnd-to-loc (make-obj '0) loc sn))10638 ((null? (cdr opnds)) (copy-opnd-to-loc (car opnds) loc sn))10639 ((or (reg? loc) (stk? loc))10640 (commut-oper gen-logxor opnds loc sn #f '() '()))10641 (else (gen-logxor opnds '() loc sn #f))))))10642(define-apply10643 "##FIXNUM.LOGAND"10644 #f10645 (lambda (opnds loc sn)10646 (let ((sn-loc (sn-opnd loc sn)))10647 (cond ((null? opnds) (copy-opnd-to-loc (make-obj '-1) loc sn))10648 ((null? (cdr opnds)) (copy-opnd-to-loc (car opnds) loc sn))10649 ((or (reg? loc) (stk? loc))10650 (commut-oper gen-logand opnds loc sn #f '() '()))10651 (else (gen-logand opnds '() loc sn #f))))))10652(define-apply10653 "##FIXNUM.LOGNOT"10654 #f10655 (lambda (opnds loc sn)10656 (let ((sn-loc (sn-opnd loc sn)) (opnd (car opnds)))10657 (if (and (or (reg? loc) (stk? loc)) (not (eq? loc return-reg)))10658 (begin10659 (copy-opnd-to-loc opnd loc sn-loc)10660 (let ((loc68 (loc->loc68 loc #f sn)))10661 (make-top-of-frame-if-stk-opnd68 loc68 sn)10662 (emit-not.l (opnd68->true-opnd68 loc68 sn))10663 (emit-and.w (make-imm -8) (opnd68->true-opnd68 loc68 sn))))10664 (begin10665 (move-opnd-to-loc68 opnd dtemp1 (sn-opnd loc sn))10666 (emit-not.l dtemp1)10667 (emit-and.w (make-imm -8) dtemp1)10668 (move-opnd68-to-loc dtemp1 loc sn))))))10669(define-apply "##FIXNUM.ASH" #f (gen-shift emit-asr.l))10670(define-apply "##FIXNUM.LSH" #f (gen-shift emit-lsr.l))10671(define-ifjump10672 "##FIXNUM.ZERO?"10673 (lambda (not? opnds lbl fs) (gen-eq-test 0 not? opnds lbl fs)))10674(define-ifjump10675 "##FIXNUM.POSITIVE?"10676 (lambda (not? opnds lbl fs)10677 (gen-compares10678 emit-bgt10679 emit-ble10680 emit-blt10681 emit-bge10682 not?10683 (list (car opnds) (make-obj '0))10684 lbl10685 fs)))10686(define-ifjump10687 "##FIXNUM.NEGATIVE?"10688 (lambda (not? opnds lbl fs)10689 (gen-compares10690 emit-blt10691 emit-bge10692 emit-bgt10693 emit-ble10694 not?10695 (list (car opnds) (make-obj '0))10696 lbl10697 fs)))10698(define-ifjump10699 "##FIXNUM.ODD?"10700 (lambda (not? opnds lbl fs) (gen-even-test (not not?) opnds lbl fs)))10701(define-ifjump10702 "##FIXNUM.EVEN?"10703 (lambda (not? opnds lbl fs) (gen-even-test not? opnds lbl fs)))10704(define-ifjump10705 "##FIXNUM.="10706 (lambda (not? opnds lbl fs)10707 (gen-compares emit-beq emit-bne emit-beq emit-bne not? opnds lbl fs)))10708(define-ifjump10709 "##FIXNUM.<"10710 (lambda (not? opnds lbl fs)10711 (gen-compares emit-blt emit-bge emit-bgt emit-ble not? opnds lbl fs)))10712(define-ifjump10713 "##FIXNUM.>"10714 (lambda (not? opnds lbl fs)10715 (gen-compares emit-bgt emit-ble emit-blt emit-bge not? opnds lbl fs)))10716(define-ifjump10717 "##FIXNUM.<="10718 (lambda (not? opnds lbl fs)10719 (gen-compares emit-ble emit-bgt emit-bge emit-blt not? opnds lbl fs)))10720(define-ifjump10721 "##FIXNUM.>="10722 (lambda (not? opnds lbl fs)10723 (gen-compares emit-bge emit-blt emit-ble emit-bgt not? opnds lbl fs)))10724(define-apply10725 "##FLONUM.->FIXNUM"10726 #f10727 (lambda (opnds loc sn)10728 (let ((sn-loc (sn-opnd loc sn)))10729 (move-opnd-to-loc68 (car opnds) atemp1 sn-loc)10730 (let ((reg68 (if (and (reg? loc) (not (eq? loc return-reg)))10731 (reg->reg68 loc)10732 dtemp1)))10733 (emit-fmov.dx (make-disp* atemp1 (- type-flonum)) ftemp1)10734 (emit-fmov.l ftemp1 reg68)10735 (emit-asl.l (make-imm 3) reg68)10736 (if (not (and (reg? loc) (not (eq? loc return-reg))))10737 (move-opnd68-to-loc reg68 loc sn))))))10738(define-apply10739 "##FLONUM.<-FIXNUM"10740 #f10741 (lambda (opnds loc sn)10742 (gen-guarantee-space 2)10743 (move-opnd-to-loc6810744 (car opnds)10745 dtemp110746 (sn-opnds (cdr opnds) (sn-opnd loc sn)))10747 (emit-asr.l (make-imm 3) dtemp1)10748 (emit-fmov.l dtemp1 ftemp1)10749 (add-n-to-loc68 (* -2 pointer-size) heap-reg)10750 (emit-fmov.dx ftemp1 (make-ind heap-reg))10751 (let ((reg68 (if (reg? loc) (reg->reg68 loc) atemp1)))10752 (emit-move.l heap-reg reg68)10753 (emit-addq.l type-flonum reg68))10754 (if (not (reg? loc)) (move-opnd68-to-loc atemp1 loc sn))))10755(define-apply10756 "##FLONUM.+"10757 #f10758 (lambda (opnds loc sn)10759 (let ((sn-loc (sn-opnd loc sn)))10760 (cond ((null? opnds) (copy-opnd-to-loc (make-obj inexact-0) loc sn))10761 ((null? (cdr opnds)) (copy-opnd-to-loc (car opnds) loc sn))10762 (else (flo-oper emit-fmov.dx emit-fadd.dx opnds loc sn))))))10763(define-apply10764 "##FLONUM.*"10765 #f10766 (lambda (opnds loc sn)10767 (let ((sn-loc (sn-opnd loc sn)))10768 (cond ((null? opnds) (copy-opnd-to-loc (make-obj inexact-+1) loc sn))10769 ((null? (cdr opnds)) (copy-opnd-to-loc (car opnds) loc sn))10770 (else (flo-oper emit-fmov.dx emit-fmul.dx opnds loc sn))))))10771(define-apply10772 "##FLONUM.-"10773 #f10774 (lambda (opnds loc sn)10775 (let ((sn-loc (sn-opnd loc sn)))10776 (if (null? (cdr opnds))10777 (flo-oper emit-fneg.dx #f opnds loc sn)10778 (flo-oper emit-fmov.dx emit-fsub.dx opnds loc sn)))))10779(define-apply10780 "##FLONUM./"10781 #f10782 (lambda (opnds loc sn)10783 (let ((sn-loc (sn-opnd loc sn)))10784 (if (null? (cdr opnds))10785 (flo-oper10786 emit-fmov.dx10787 emit-fdiv.dx10788 (cons (make-obj inexact-+1) opnds)10789 loc10790 sn)10791 (flo-oper emit-fmov.dx emit-fdiv.dx opnds loc sn)))))10792(define-apply10793 "##FLONUM.ABS"10794 #f10795 (lambda (opnds loc sn)10796 (let ((sn-loc (sn-opnd loc sn))) (flo-oper emit-fabs.dx #f opnds loc sn))))10797(define-apply10798 "##FLONUM.TRUNCATE"10799 #f10800 (lambda (opnds loc sn)10801 (let ((sn-loc (sn-opnd loc sn)))10802 (flo-oper emit-fintrz.dx #f opnds loc sn))))10803(define-apply10804 "##FLONUM.ROUND"10805 #f10806 (lambda (opnds loc sn)10807 (let ((sn-loc (sn-opnd loc sn))) (flo-oper emit-fint.dx #f opnds loc sn))))10808(define-apply10809 "##FLONUM.EXP"10810 #f10811 (lambda (opnds loc sn)10812 (let ((sn-loc (sn-opnd loc sn))) (flo-oper emit-fetox.dx #f opnds loc sn))))10813(define-apply10814 "##FLONUM.LOG"10815 #f10816 (lambda (opnds loc sn)10817 (let ((sn-loc (sn-opnd loc sn))) (flo-oper emit-flogn.dx #f opnds loc sn))))10818(define-apply10819 "##FLONUM.SIN"10820 #f10821 (lambda (opnds loc sn)10822 (let ((sn-loc (sn-opnd loc sn))) (flo-oper emit-fsin.dx #f opnds loc sn))))10823(define-apply10824 "##FLONUM.COS"10825 #f10826 (lambda (opnds loc sn)10827 (let ((sn-loc (sn-opnd loc sn))) (flo-oper emit-fcos.dx #f opnds loc sn))))10828(define-apply10829 "##FLONUM.TAN"10830 #f10831 (lambda (opnds loc sn)10832 (let ((sn-loc (sn-opnd loc sn))) (flo-oper emit-ftan.dx #f opnds loc sn))))10833(define-apply10834 "##FLONUM.ASIN"10835 #f10836 (lambda (opnds loc sn)10837 (let ((sn-loc (sn-opnd loc sn))) (flo-oper emit-fasin.dx #f opnds loc sn))))10838(define-apply10839 "##FLONUM.ACOS"10840 #f10841 (lambda (opnds loc sn)10842 (let ((sn-loc (sn-opnd loc sn))) (flo-oper emit-facos.dx #f opnds loc sn))))10843(define-apply10844 "##FLONUM.ATAN"10845 #f10846 (lambda (opnds loc sn)10847 (let ((sn-loc (sn-opnd loc sn))) (flo-oper emit-fatan.dx #f opnds loc sn))))10848(define-apply10849 "##FLONUM.SQRT"10850 #f10851 (lambda (opnds loc sn)10852 (let ((sn-loc (sn-opnd loc sn))) (flo-oper emit-fsqrt.dx #f opnds loc sn))))10853(define-ifjump10854 "##FLONUM.ZERO?"10855 (lambda (not? opnds lbl fs)10856 (gen-compares-flo10857 emit-fbeq10858 emit-fbne10859 emit-fbeq10860 emit-fbne10861 not?10862 (list (car opnds) (make-obj inexact-0))10863 lbl10864 fs)))10865(define-ifjump10866 "##FLONUM.NEGATIVE?"10867 (lambda (not? opnds lbl fs)10868 (gen-compares-flo10869 emit-fblt10870 emit-fbge10871 emit-fbgt10872 emit-fble10873 not?10874 (list (car opnds) (make-obj inexact-0))10875 lbl10876 fs)))10877(define-ifjump10878 "##FLONUM.POSITIVE?"10879 (lambda (not? opnds lbl fs)10880 (gen-compares-flo10881 emit-fbgt10882 emit-fble10883 emit-fblt10884 emit-fbge10885 not?10886 (list (car opnds) (make-obj inexact-0))10887 lbl10888 fs)))10889(define-ifjump10890 "##FLONUM.="10891 (lambda (not? opnds lbl fs)10892 (gen-compares-flo10893 emit-fbeq10894 emit-fbne10895 emit-fbeq10896 emit-fbne10897 not?10898 opnds10899 lbl10900 fs)))10901(define-ifjump10902 "##FLONUM.<"10903 (lambda (not? opnds lbl fs)10904 (gen-compares-flo10905 emit-fblt10906 emit-fbge10907 emit-fbgt10908 emit-fble10909 not?10910 opnds10911 lbl10912 fs)))10913(define-ifjump10914 "##FLONUM.>"10915 (lambda (not? opnds lbl fs)10916 (gen-compares-flo10917 emit-fbgt10918 emit-fble10919 emit-fblt10920 emit-fbge10921 not?10922 opnds10923 lbl10924 fs)))10925(define-ifjump10926 "##FLONUM.<="10927 (lambda (not? opnds lbl fs)10928 (gen-compares-flo10929 emit-fble10930 emit-fbgt10931 emit-fbge10932 emit-fblt10933 not?10934 opnds10935 lbl10936 fs)))10937(define-ifjump10938 "##FLONUM.>="10939 (lambda (not? opnds lbl fs)10940 (gen-compares-flo10941 emit-fbge10942 emit-fblt10943 emit-fble10944 emit-fbgt10945 not?10946 opnds10947 lbl10948 fs)))10949(define-ifjump10950 "##CHAR=?"10951 (lambda (not? opnds lbl fs)10952 (gen-compares emit-beq emit-bne emit-beq emit-bne not? opnds lbl fs)))10953(define-ifjump10954 "##CHAR<?"10955 (lambda (not? opnds lbl fs)10956 (gen-compares emit-blt emit-bge emit-bgt emit-ble not? opnds lbl fs)))10957(define-ifjump10958 "##CHAR>?"10959 (lambda (not? opnds lbl fs)10960 (gen-compares emit-bgt emit-ble emit-blt emit-bge not? opnds lbl fs)))10961(define-ifjump10962 "##CHAR<=?"10963 (lambda (not? opnds lbl fs)10964 (gen-compares emit-ble emit-bgt emit-bge emit-blt not? opnds lbl fs)))10965(define-ifjump10966 "##CHAR>=?"10967 (lambda (not? opnds lbl fs)10968 (gen-compares emit-bge emit-blt emit-ble emit-bgt not? opnds lbl fs)))10969(define-apply "##CONS" #f (lambda (opnds loc sn) (gen-cons opnds loc sn)))10970(define-apply10971 "##SET-CAR!"10972 #t10973 (lambda (opnds loc sn) (gen-set-car! opnds loc sn)))10974(define-apply10975 "##SET-CDR!"10976 #t10977 (lambda (opnds loc sn) (gen-set-cdr! opnds loc sn)))10978(define-apply "##CAR" #f (make-gen-apply-c...r 2))10979(define-apply "##CDR" #f (make-gen-apply-c...r 3))10980(define-apply "##CAAR" #f (make-gen-apply-c...r 4))10981(define-apply "##CADR" #f (make-gen-apply-c...r 5))10982(define-apply "##CDAR" #f (make-gen-apply-c...r 6))10983(define-apply "##CDDR" #f (make-gen-apply-c...r 7))10984(define-apply "##CAAAR" #f (make-gen-apply-c...r 8))10985(define-apply "##CAADR" #f (make-gen-apply-c...r 9))10986(define-apply "##CADAR" #f (make-gen-apply-c...r 10))10987(define-apply "##CADDR" #f (make-gen-apply-c...r 11))10988(define-apply "##CDAAR" #f (make-gen-apply-c...r 12))10989(define-apply "##CDADR" #f (make-gen-apply-c...r 13))10990(define-apply "##CDDAR" #f (make-gen-apply-c...r 14))10991(define-apply "##CDDDR" #f (make-gen-apply-c...r 15))10992(define-apply "##CAAAAR" #f (make-gen-apply-c...r 16))10993(define-apply "##CAAADR" #f (make-gen-apply-c...r 17))10994(define-apply "##CAADAR" #f (make-gen-apply-c...r 18))10995(define-apply "##CAADDR" #f (make-gen-apply-c...r 19))10996(define-apply "##CADAAR" #f (make-gen-apply-c...r 20))10997(define-apply "##CADADR" #f (make-gen-apply-c...r 21))10998(define-apply "##CADDAR" #f (make-gen-apply-c...r 22))10999(define-apply "##CADDDR" #f (make-gen-apply-c...r 23))11000(define-apply "##CDAAAR" #f (make-gen-apply-c...r 24))11001(define-apply "##CDAADR" #f (make-gen-apply-c...r 25))11002(define-apply "##CDADAR" #f (make-gen-apply-c...r 26))11003(define-apply "##CDADDR" #f (make-gen-apply-c...r 27))11004(define-apply "##CDDAAR" #f (make-gen-apply-c...r 28))11005(define-apply "##CDDADR" #f (make-gen-apply-c...r 29))11006(define-apply "##CDDDAR" #f (make-gen-apply-c...r 30))11007(define-apply "##CDDDDR" #f (make-gen-apply-c...r 31))11008(define-apply11009 "##MAKE-CELL"11010 #f11011 (lambda (opnds loc sn) (gen-cons (list (car opnds) (make-obj '())) loc sn)))11012(define-apply "##CELL-REF" #f (make-gen-apply-c...r 2))11013(define-apply11014 "##CELL-SET!"11015 #t11016 (lambda (opnds loc sn) (gen-set-car! opnds loc sn)))11017(define-apply "##VECTOR" #f (make-gen-vector 'vector))11018(define-apply "##VECTOR-LENGTH" #f (make-gen-vector-length 'vector))11019(define-apply "##VECTOR-REF" #f (make-gen-vector-ref 'vector))11020(define-apply "##VECTOR-SET!" #t (make-gen-vector-set! 'vector))11021(define-apply "##VECTOR-SHRINK!" #t (make-gen-vector-shrink! 'vector))11022(define-apply "##STRING" #f (make-gen-vector 'string))11023(define-apply "##STRING-LENGTH" #f (make-gen-vector-length 'string))11024(define-apply "##STRING-REF" #f (make-gen-vector-ref 'string))11025(define-apply "##STRING-SET!" #t (make-gen-vector-set! 'string))11026(define-apply "##STRING-SHRINK!" #t (make-gen-vector-shrink! 'string))11027(define-apply "##VECTOR8" #f (make-gen-vector 'vector8))11028(define-apply "##VECTOR8-LENGTH" #f (make-gen-vector-length 'vector8))11029(define-apply "##VECTOR8-REF" #f (make-gen-vector-ref 'vector8))11030(define-apply "##VECTOR8-SET!" #t (make-gen-vector-set! 'vector8))11031(define-apply "##VECTOR8-SHRINK!" #t (make-gen-vector-shrink! 'vector8))11032(define-apply "##VECTOR16" #f (make-gen-vector 'vector16))11033(define-apply "##VECTOR16-LENGTH" #f (make-gen-vector-length 'vector16))11034(define-apply "##VECTOR16-REF" #f (make-gen-vector-ref 'vector16))11035(define-apply "##VECTOR16-SET!" #t (make-gen-vector-set! 'vector16))11036(define-apply "##VECTOR16-SHRINK!" #t (make-gen-vector-shrink! 'vector16))11037(define-apply "##CLOSURE-CODE" #f (make-gen-slot-ref 1 type-procedure))11038(define-apply "##CLOSURE-REF" #f (make-gen-vector-ref 'closure))11039(define-apply "##CLOSURE-SET!" #t (make-gen-vector-set! 'closure))11040(define-apply11041 "##SUBPROCEDURE-ID"11042 #f11043 (lambda (opnds loc sn) (gen-subprocedure-id opnds loc sn)))11044(define-apply11045 "##SUBPROCEDURE-PARENT"11046 #f11047 (lambda (opnds loc sn) (gen-subprocedure-parent opnds loc sn)))11048(define-apply11049 "##RETURN-FS"11050 #f11051 (lambda (opnds loc sn) (gen-return-fs opnds loc sn)))11052(define-apply11053 "##RETURN-LINK"11054 #f11055 (lambda (opnds loc sn) (gen-return-link opnds loc sn)))11056(define-apply11057 "##PROCEDURE-INFO"11058 #f11059 (lambda (opnds loc sn) (gen-procedure-info opnds loc sn)))11060(define-apply11061 "##PSTATE"11062 #f11063 (lambda (opnds loc sn) (move-opnd68-to-loc pstate-reg loc sn)))11064(define-apply11065 "##MAKE-PLACEHOLDER"11066 #f11067 (lambda (opnds loc sn) (gen-make-placeholder opnds loc sn)))11068(define-apply11069 "##TOUCH"11070 #t11071 (lambda (opnds loc sn)11072 (let ((opnd (car opnds)))11073 (if loc11074 (touch-opnd-to-loc opnd loc sn)11075 (touch-opnd-to-any-reg68 opnd sn)))))11076(def-spec "NOT" (safe "##NOT"))11077(def-spec "NULL?" (safe "##NULL?"))11078(def-spec "EQ?" (safe "##EQ?"))11079(def-spec "PAIR?" (safe "##PAIR?"))11080(def-spec "PROCEDURE?" (safe "##PROCEDURE?"))11081(def-spec "VECTOR?" (safe "##VECTOR?"))11082(def-spec "SYMBOL?" (safe "##SYMBOL?"))11083(def-spec "STRING?" (safe "##STRING?"))11084(def-spec "CHAR?" (safe "##CHAR?"))11085(def-spec "ZERO?" (safe-arith "##FIXNUM.ZERO?" "##FLONUM.ZERO?"))11086(def-spec "POSITIVE?" (safe-arith "##FIXNUM.POSITIVE?" "##FLONUM.POSITIVE?"))11087(def-spec "NEGATIVE?" (safe-arith "##FIXNUM.NEGATIVE?" "##FLONUM.NEGATIVE?"))11088(def-spec "ODD?" (safe-arith "##FIXNUM.ODD?" #f))11089(def-spec "EVEN?" (safe-arith "##FIXNUM.EVEN?" #f))11090(def-spec "+" (unsafe-arith "##FIXNUM.+" "##FLONUM.+"))11091(def-spec "*" (unsafe-arith "##FIXNUM.*" "##FLONUM.*"))11092(def-spec "-" (unsafe-arith "##FIXNUM.-" "##FLONUM.-"))11093(def-spec "/" (unsafe-arith #f "##FLONUM./"))11094(def-spec "QUOTIENT" (unsafe-arith "##FIXNUM.QUOTIENT" #f))11095(def-spec "REMAINDER" (unsafe-arith "##FIXNUM.REMAINDER" #f))11096(def-spec "MODULO" (unsafe-arith "##FIXNUM.MODULO" #f))11097(def-spec "=" (safe-arith "##FIXNUM.=" "##FLONUM.="))11098(def-spec "<" (safe-arith "##FIXNUM.<" "##FLONUM.<"))11099(def-spec ">" (safe-arith "##FIXNUM.>" "##FLONUM.>"))11100(def-spec "<=" (safe-arith "##FIXNUM.<=" "##FLONUM.<="))11101(def-spec ">=" (safe-arith "##FIXNUM.>=" "##FLONUM.>="))11102(def-spec "ABS" (unsafe-arith #f "##FLONUM.ABS"))11103(def-spec "TRUNCATE" (unsafe-arith #f "##FLONUM.TRUNCATE"))11104(def-spec "EXP" (unsafe-arith #f "##FLONUM.EXP"))11105(def-spec "LOG" (unsafe-arith #f "##FLONUM.LOG"))11106(def-spec "SIN" (unsafe-arith #f "##FLONUM.SIN"))11107(def-spec "COS" (unsafe-arith #f "##FLONUM.COS"))11108(def-spec "TAN" (unsafe-arith #f "##FLONUM.TAN"))11109(def-spec "ASIN" (unsafe-arith #f "##FLONUM.ASIN"))11110(def-spec "ACOS" (unsafe-arith #f "##FLONUM.ACOS"))11111(def-spec "ATAN" (unsafe-arith #f "##FLONUM.ATAN"))11112(def-spec "SQRT" (unsafe-arith #f "##FLONUM.SQRT"))11113(def-spec "CHAR=?" (safe "##CHAR=?"))11114(def-spec "CHAR<?" (safe "##CHAR<?"))11115(def-spec "CHAR>?" (safe "##CHAR>?"))11116(def-spec "CHAR<=?" (safe "##CHAR<=?"))11117(def-spec "CHAR>=?" (safe "##CHAR>=?"))11118(def-spec "CONS" (safe "##CONS"))11119(def-spec "SET-CAR!" (unsafe "##SET-CAR!"))11120(def-spec "SET-CDR!" (unsafe "##SET-CDR!"))11121(def-spec "CAR" (unsafe "##CAR"))11122(def-spec "CDR" (unsafe "##CDR"))11123(def-spec "CAAR" (unsafe "##CAAR"))11124(def-spec "CADR" (unsafe "##CADR"))11125(def-spec "CDAR" (unsafe "##CDAR"))11126(def-spec "CDDR" (unsafe "##CDDR"))11127(def-spec "CAAAR" (unsafe "##CAAAR"))11128(def-spec "CAADR" (unsafe "##CAADR"))11129(def-spec "CADAR" (unsafe "##CADAR"))11130(def-spec "CADDR" (unsafe "##CADDR"))11131(def-spec "CDAAR" (unsafe "##CDAAR"))11132(def-spec "CDADR" (unsafe "##CDADR"))11133(def-spec "CDDAR" (unsafe "##CDDAR"))11134(def-spec "CDDDR" (unsafe "##CDDDR"))11135(def-spec "CAAAAR" (unsafe "##CAAAAR"))11136(def-spec "CAAADR" (unsafe "##CAAADR"))11137(def-spec "CAADAR" (unsafe "##CAADAR"))11138(def-spec "CAADDR" (unsafe "##CAADDR"))11139(def-spec "CADAAR" (unsafe "##CADAAR"))11140(def-spec "CADADR" (unsafe "##CADADR"))11141(def-spec "CADDAR" (unsafe "##CADDAR"))11142(def-spec "CADDDR" (unsafe "##CADDDR"))11143(def-spec "CDAAAR" (unsafe "##CDAAAR"))11144(def-spec "CDAADR" (unsafe "##CDAADR"))11145(def-spec "CDADAR" (unsafe "##CDADAR"))11146(def-spec "CDADDR" (unsafe "##CDADDR"))11147(def-spec "CDDAAR" (unsafe "##CDDAAR"))11148(def-spec "CDDADR" (unsafe "##CDDADR"))11149(def-spec "CDDDAR" (unsafe "##CDDDAR"))11150(def-spec "CDDDDR" (unsafe "##CDDDDR"))11151(def-spec "VECTOR" (safe "##VECTOR"))11152(def-spec "VECTOR-LENGTH" (unsafe "##VECTOR-LENGTH"))11153(def-spec "VECTOR-REF" (unsafe "##VECTOR-REF"))11154(def-spec "VECTOR-SET!" (unsafe "##VECTOR-SET!"))11155(def-spec "STRING" (safe "##STRING"))11156(def-spec "STRING-LENGTH" (unsafe "##STRING-LENGTH"))11157(def-spec "STRING-REF" (unsafe "##STRING-REF"))11158(def-spec "STRING-SET!" (unsafe "##STRING-SET!"))11159(def-spec "TOUCH" (safe "##TOUCH"))11160(let ((targ (make-target 4 'm68000)))11161 (target-begin!-set! targ (lambda (info-port) (begin! info-port targ)))11162 (put-target targ))1116311164(define input-source-code '11165(begin11166(declare (standard-bindings) (fixnum) (not safe) (block))1116711168(define (fib n)11169 (if (< n 2)11170 n11171 (+ (fib (- n 1))11172 (fib (- n 2)))))1117311174(define (tak x y z)11175 (if (not (< y x))11176 z11177 (tak (tak (- x 1) y z)11178 (tak (- y 1) z x)11179 (tak (- z 1) x y))))1118011181(define (ack m n)11182 (cond ((= m 0) (+ n 1))11183 ((= n 0) (ack (- m 1) 1))11184 (else (ack (- m 1) (ack m (- n 1))))))1118511186(define (create-x n)11187 (define result (make-vector n))11188 (do ((i 0 (+ i 1)))11189 ((>= i n) result)11190 (vector-set! result i i)))1119111192(define (create-y x)11193 (let* ((n (vector-length x))11194 (result (make-vector n)))11195 (do ((i (- n 1) (- i 1)))11196 ((< i 0) result)11197 (vector-set! result i (vector-ref x i)))))1119811199(define (my-try n)11200 (vector-length (create-y (create-x n))))1120111202(define (go n)11203 (let loop ((repeat 100)11204 (result 0))11205 (if (> repeat 0)11206 (loop (- repeat 1) (my-try n))11207 result)))1120811209(+ (fib 20)11210 (tak 18 12 6)11211 (ack 3 9)11212 (go 200000))11213))1121411215(define output-expected '(11216"|------------------------------------------------------"11217"| #[primitive #!program] ="11218"L1:"11219" cmpw #1,d0"11220" beq L1000"11221" TRAP1(9,0)"11222" LBL_PTR(L1)"11223"L1000:"11224" MOVE_PROC(1,a1)"11225" movl a1,GLOB(fib)"11226" MOVE_PROC(2,a1)"11227" movl a1,GLOB(tak)"11228" MOVE_PROC(3,a1)"11229" movl a1,GLOB(ack)"11230" MOVE_PROC(4,a1)"11231" movl a1,GLOB(create-x)"11232" MOVE_PROC(5,a1)"11233" movl a1,GLOB(create-y)"11234" MOVE_PROC(6,a1)"11235" movl a1,GLOB(my-try)"11236" MOVE_PROC(7,a1)"11237" movl a1,GLOB(go)"11238" movl a0,sp@-"11239" movl #160,d1"11240" lea L2,a0"11241" dbra d5,L1001"11242" moveq #9,d5"11243" cmpl a5@,sp"11244" bcc L1001"11245" TRAP2(24)"11246" RETURN(L1,1,1)"11247"L1002:"11248"L1001:"11249" JMP_PROC(1,10)"11250" RETURN(L1,1,1)"11251"L2:"11252" movl d1,sp@-"11253" moveq #48,d3"11254" moveq #96,d2"11255" movl #144,d1"11256" lea L3,a0"11257" JMP_PROC(2,14)"11258" RETURN(L1,2,1)"11259"L3:"11260" movl d1,sp@-"11261" moveq #72,d2"11262" moveq #24,d1"11263" lea L4,a0"11264" JMP_PROC(3,10)"11265" RETURN(L1,3,1)"11266"L4:"11267" movl d1,sp@-"11268" movl #1600000,d1"11269" lea L5,a0"11270" JMP_PROC(7,10)"11271" RETURN(L1,4,1)"11272"L5:"11273" dbra d5,L1003"11274" moveq #9,d5"11275" cmpl a5@,sp"11276" bcc L1003"11277" TRAP2(24)"11278" RETURN(L1,4,1)"11279"L1004:"11280"L1003:"11281"L6:"11282" addl sp@(8),d1"11283" addl sp@(4),d1"11284" addl sp@+,d1"11285" addql #8,sp"11286" rts"11287"L0:"11288"|------------------------------------------------------"11289"| #[primitive fib] ="11290"L1:"11291" bmi L1000"11292" TRAP1(9,1)"11293" LBL_PTR(L1)"11294"L1000:"11295" moveq #16,d0"11296" cmpl d1,d0"11297" ble L3"11298" bra L4"11299" RETURN(L1,2,1)"11300"L2:"11301" movl d1,sp@-"11302" movl sp@(4),d1"11303" moveq #-16,d0"11304" addl d0,d1"11305" lea L5,a0"11306" moveq #16,d0"11307" cmpl d1,d0"11308" bgt L4"11309"L3:"11310" movl a0,sp@-"11311" movl d1,sp@-"11312" subql #8,d1"11313" lea L2,a0"11314" dbra d5,L1001"11315" moveq #9,d5"11316" cmpl a5@,sp"11317" bcc L1001"11318" TRAP2(24)"11319" RETURN(L1,2,1)"11320"L1002:"11321"L1001:"11322" moveq #16,d0"11323" cmpl d1,d0"11324" ble L3"11325"L4:"11326" jmp a0@"11327" RETURN(L1,3,1)"11328"L5:"11329" addl sp@+,d1"11330" dbra d5,L1003"11331" moveq #9,d5"11332" cmpl a5@,sp"11333" bcc L1003"11334" TRAP2(24)"11335" RETURN(L1,2,1)"11336"L1004:"11337"L1003:"11338" addql #4,sp"11339" rts"11340"L0:"11341"|------------------------------------------------------"11342"| #[primitive tak] ="11343"L1:"11344" cmpw #4,d0"11345" beq L1000"11346" TRAP1(9,3)"11347" LBL_PTR(L1)"11348"L1000:"11349" cmpl d1,d2"11350" bge L4"11351" bra L3"11352" RETURN(L1,6,1)"11353"L2:"11354" movl d1,d3"11355" movl sp@(20),a0"11356" movl sp@+,d2"11357" movl sp@+,d1"11358" dbra d5,L1001"11359" moveq #9,d5"11360" cmpl a5@,sp"11361" bcc L1001"11362" movl a0,sp@(12)"11363" TRAP2(24)"11364" RETURN(L1,4,1)"11365"L1002:"11366" movl sp@(12),a0"11367"L1001:"11368" cmpl d1,d2"11369" lea sp@(16),sp"11370" bge L4"11371"L3:"11372" movl a0,sp@-"11373" movl d1,sp@-"11374" movl d2,sp@-"11375" movl d3,sp@-"11376" subql #8,d1"11377" lea L5,a0"11378" dbra d5,L1003"11379" moveq #9,d5"11380" cmpl a5@,sp"11381" bcc L1003"11382" TRAP2(24)"11383" RETURN(L1,4,1)"11384"L1004:"11385"L1003:"11386" cmpl d1,d2"11387" blt L3"11388"L4:"11389" movl d3,d1"11390" jmp a0@"11391" RETURN(L1,4,1)"11392"L5:"11393" movl d1,sp@-"11394" movl sp@(12),d3"11395" movl sp@(4),d2"11396" movl sp@(8),d1"11397" subql #8,d1"11398" lea L6,a0"11399" cmpl d1,d2"11400" bge L4"11401" bra L3"11402" RETURN(L1,5,1)"11403"L6:"11404" movl d1,sp@-"11405" movl sp@(12),d3"11406" movl sp@(16),d2"11407" movl sp@(8),d1"11408" subql #8,d1"11409" lea L2,a0"11410" cmpl d1,d2"11411" bge L4"11412" bra L3"11413"L0:"11414"|------------------------------------------------------"11415"| #[primitive ack] ="11416"L1:"11417" beq L1000"11418" TRAP1(9,2)"11419" LBL_PTR(L1)"11420"L1000:"11421" movl d1,d0"11422" bne L3"11423" bra L5"11424" RETURN(L1,2,1)"11425"L2:"11426" movl d1,d2"11427" movl sp@+,d1"11428" subql #8,d1"11429" movl sp@+,a0"11430" dbra d5,L1001"11431" moveq #9,d5"11432" cmpl a5@,sp"11433" bcc L1001"11434" movl a0,sp@-"11435" TRAP2(24)"11436" RETURN(L1,1,1)"11437"L1002:"11438" movl sp@+,a0"11439"L1001:"11440" movl d1,d0"11441" beq L5"11442"L3:"11443" movl d2,d0"11444" bne L6"11445"L4:"11446" subql #8,d1"11447" moveq #8,d2"11448" dbra d5,L1003"11449" moveq #9,d5"11450" cmpl a5@,sp"11451" bcc L1003"11452" movl a0,sp@-"11453" TRAP2(24)"11454" RETURN(L1,1,1)"11455"L1004:"11456" movl sp@+,a0"11457"L1003:"11458" movl d1,d0"11459" bne L3"11460"L5:"11461" movl d2,d1"11462" addql #8,d1"11463" jmp a0@"11464"L6:"11465" movl a0,sp@-"11466" movl d1,sp@-"11467" movl d2,d1"11468" subql #8,d1"11469" movl d1,d2"11470" movl sp@,d1"11471" lea L2,a0"11472" dbra d5,L1005"11473" moveq #9,d5"11474" cmpl a5@,sp"11475" bcc L1005"11476" TRAP2(24)"11477" RETURN(L1,2,1)"11478"L1006:"11479"L1005:"11480" movl d1,d0"11481" bne L3"11482" bra L5"11483"L0:"11484"|------------------------------------------------------"11485"| #[primitive create-x] ="11486"L1:"11487" bmi L1000"11488" TRAP1(9,1)"11489" LBL_PTR(L1)"11490"L1000:"11491" movl a0,sp@-"11492" movl d1,sp@-"11493" lea L2,a0"11494" dbra d5,L1001"11495" moveq #9,d5"11496" cmpl a5@,sp"11497" bcc L1001"11498" TRAP2(24)"11499" RETURN(L1,2,1)"11500"L1002:"11501"L1001:"11502" moveq #-1,d0"11503" JMP_PRIM(make-vector,0)"11504" RETURN(L1,2,1)"11505"L2:"11506" movl d1,d2"11507" movl sp@+,d1"11508" moveq #0,d3"11509" movl sp@+,a0"11510" dbra d5,L1003"11511" moveq #9,d5"11512" cmpl a5@,sp"11513" bcc L1003"11514" movl a0,sp@-"11515" TRAP2(24)"11516" RETURN(L1,1,1)"11517"L1004:"11518" movl sp@+,a0"11519"L1003:"11520" cmpl d1,d3"11521" bge L4"11522"L3:"11523" movl d3,d0"11524" asrl #1,d0"11525" movl d2,a1"11526" movl d3,a1@(1,d0:l)"11527" addql #8,d3"11528" dbra d5,L1005"11529" moveq #9,d5"11530" cmpl a5@,sp"11531" bcc L1005"11532" movl a0,sp@-"11533" TRAP2(24)"11534" RETURN(L1,1,1)"11535"L1006:"11536" movl sp@+,a0"11537"L1005:"11538" cmpl d1,d3"11539" blt L3"11540"L4:"11541" movl d2,d1"11542" jmp a0@"11543"L0:"11544"|------------------------------------------------------"11545"| #[primitive create-y] ="11546"L1:"11547" bmi L1000"11548" TRAP1(9,1)"11549" LBL_PTR(L1)"11550"L1000:"11551" movl d1,a1"11552" movl a1@(-3),d2"11553" lsrl #7,d2"11554" movl a0,sp@-"11555" movl d1,sp@-"11556" movl d2,sp@-"11557" movl d2,d1"11558" lea L2,a0"11559" dbra d5,L1001"11560" moveq #9,d5"11561" cmpl a5@,sp"11562" bcc L1001"11563" TRAP2(24)"11564" RETURN(L1,3,1)"11565"L1002:"11566"L1001:"11567" moveq #-1,d0"11568" JMP_PRIM(make-vector,0)"11569" RETURN(L1,3,1)"11570"L2:"11571" movl sp@+,d2"11572" subql #8,d2"11573" movl d2,d3"11574" movl d1,d2"11575" movl sp@+,d1"11576" movl sp@+,a0"11577" dbra d5,L1003"11578" moveq #9,d5"11579" cmpl a5@,sp"11580" bcc L1003"11581" movl a0,sp@-"11582" TRAP2(24)"11583" RETURN(L1,1,1)"11584"L1004:"11585" movl sp@+,a0"11586"L1003:"11587" movl d3,d0"11588" blt L4"11589"L3:"11590" movl d3,d0"11591" asrl #1,d0"11592" movl d1,a1"11593" movl a1@(1,d0:l),d4"11594" movl d3,d0"11595" asrl #1,d0"11596" movl d2,a1"11597" movl d4,a1@(1,d0:l)"11598" subql #8,d3"11599" dbra d5,L1005"11600" moveq #9,d5"11601" cmpl a5@,sp"11602" bcc L1005"11603" movl a0,sp@-"11604" TRAP2(24)"11605" RETURN(L1,1,1)"11606"L1006:"11607" movl sp@+,a0"11608"L1005:"11609" movl d3,d0"11610" bge L3"11611"L4:"11612" movl d2,d1"11613" jmp a0@"11614"L0:"11615"|------------------------------------------------------"11616"| #[primitive my-try] ="11617"L1:"11618" bmi L1000"11619" TRAP1(9,1)"11620" LBL_PTR(L1)"11621"L1000:"11622" movl a0,sp@-"11623" lea L2,a0"11624" dbra d5,L1001"11625" moveq #9,d5"11626" cmpl a5@,sp"11627" bcc L1001"11628" TRAP2(24)"11629" RETURN(L1,1,1)"11630"L1002:"11631"L1001:"11632" JMP_PROC(4,10)"11633" RETURN(L1,1,1)"11634"L2:"11635" lea L3,a0"11636" JMP_PROC(5,10)"11637" RETURN(L1,1,1)"11638"L3:"11639" movl d1,a1"11640" movl a1@(-3),d1"11641" lsrl #7,d1"11642" dbra d5,L1003"11643" moveq #9,d5"11644" cmpl a5@,sp"11645" bcc L1003"11646" TRAP2(24)"11647" RETURN(L1,1,1)"11648"L1004:"11649"L1003:"11650" rts"11651"L0:"11652"|------------------------------------------------------"11653"| #[primitive go] ="11654"L1:"11655" bmi L1000"11656" TRAP1(9,1)"11657" LBL_PTR(L1)"11658"L1000:"11659" moveq #0,d3"11660" movl #800,d2"11661" dbra d5,L1001"11662" moveq #9,d5"11663" cmpl a5@,sp"11664" bcc L1001"11665" movl a0,sp@-"11666" TRAP2(24)"11667" RETURN(L1,1,1)"11668"L1002:"11669" movl sp@+,a0"11670"L1001:"11671" movl d2,d0"11672" ble L4"11673" bra L3"11674" RETURN(L1,3,1)"11675"L2:"11676" movl d1,d3"11677" movl sp@+,d1"11678" subql #8,d1"11679" movl d1,d2"11680" movl sp@+,d1"11681" movl sp@+,a0"11682" dbra d5,L1003"11683" moveq #9,d5"11684" cmpl a5@,sp"11685" bcc L1003"11686" movl a0,sp@-"11687" TRAP2(24)"11688" RETURN(L1,1,1)"11689"L1004:"11690" movl sp@+,a0"11691"L1003:"11692" movl d2,d0"11693" ble L4"11694"L3:"11695" movl a0,sp@-"11696" movl d1,sp@-"11697" movl d2,sp@-"11698" lea L2,a0"11699" dbra d5,L1005"11700" moveq #9,d5"11701" cmpl a5@,sp"11702" bcc L1005"11703" TRAP2(24)"11704" RETURN(L1,3,1)"11705"L1006:"11706"L1005:"11707" JMP_PROC(6,10)"11708"L4:"11709" movl d3,d1"11710" jmp a0@"11711"L0:"11712""))1171311714(define (main . args)11715 (run-benchmark11716 "compiler"11717 compiler-iters11718 (lambda (result)11719 (equal? result output-expected))11720 (lambda (expr target opt) (lambda () (ce expr target opt) (asm-output-get)))11721 input-source-code11722 'm6800011723 'asm))1172411725(main)