conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
ikarus/benchmarks.larceny/src/test.scm

6533 lines
267 KiB
Scheme
Raw Blame History

;(define integer->char ascii->char)
;(define char->integer char->ascii)
(define open-input-file* open-input-file)
(define (pp-expression expr port) (write expr port) (newline port))
(define (write-returning-len obj port) (write obj port) 1)
(define (display-returning-len obj port) (display obj port) 1)
(define (write-word w port)
(write-char (integer->char (quotient w 256)) port)
(write-char (integer->char (modulo w 256)) port))
(define char-nul (integer->char 0))
(define char-tab (integer->char 9))
(define char-newline (integer->char 10))
(define character-encoding char->integer)
(define max-character-encoding 255)
(define (fatal-err msg arg) (error msg arg))
(define (scheme-global-var name) name)
(define (scheme-global-var-ref var) (scheme-global-eval var))
(define (scheme-global-var-set! var val)
(scheme-global-eval (list 'set! var (list 'quote val)) fatal-err))
(define (scheme-global-eval expr err) (eval expr))
(define (pinpoint-error filename line char) #t)
(define file-path-sep #\:)
(define file-ext-sep #\.)
(define (path-absolute? x)
(and (> (string-length x) 0)
(let ((c (string-ref x 0))) (or (char=? c #\/) (char=? c #\~)))))
(define (file-path x)
(let loop1 ((i (string-length x)))
(if (and (> i 0) (not (char=? (string-ref x (- i 1)) file-path-sep)))
(loop1 (- i 1))
(let ((result (make-string i)))
(let loop2 ((j (- i 1)))
(if (< j 0)
result
(begin
(string-set! result j (string-ref x j))
(loop2 (- j 1)))))))))
(define (file-name x)
(let loop1 ((i (string-length x)))
(if (and (> i 0) (not (char=? (string-ref x (- i 1)) file-path-sep)))
(loop1 (- i 1))
(let ((result (make-string (- (string-length x) i))))
(let loop2 ((j (- (string-length x) 1)))
(if (< j i)
result
(begin
(string-set! result (- j i) (string-ref x j))
(loop2 (- j 1)))))))))
(define (file-ext x)
(let loop1 ((i (string-length x)))
(if (or (= i 0) (char=? (string-ref x (- i 1)) file-path-sep))
#f
(if (not (char=? (string-ref x (- i 1)) file-ext-sep))
(loop1 (- i 1))
(let ((result (make-string (- (string-length x) i))))
(let loop2 ((j (- (string-length x) 1)))
(if (< j i)
result
(begin
(string-set! result (- j i) (string-ref x j))
(loop2 (- j 1))))))))))
(define (file-root x)
(let loop1 ((i (string-length x)))
(if (or (= i 0) (char=? (string-ref x (- i 1)) file-path-sep))
x
(if (not (char=? (string-ref x (- i 1)) file-ext-sep))
(loop1 (- i 1))
(let ((result (make-string (- i 1))))
(let loop2 ((j (- i 2)))
(if (< j 0)
result
(begin
(string-set! result j (string-ref x j))
(loop2 (- j 1))))))))))
(define (make-counter next limit limit-error)
(lambda ()
(if (< next limit)
(let ((result next)) (set! next (+ next 1)) result)
(limit-error))))
(define (pos-in-list x l)
(let loop ((l l) (i 0))
(cond ((not (pair? l)) #f)
((eq? (car l) x) i)
(else (loop (cdr l) (+ i 1))))))
(define (string-pos-in-list x l)
(let loop ((l l) (i 0))
(cond ((not (pair? l)) #f)
((string=? (car l) x) i)
(else (loop (cdr l) (+ i 1))))))
(define (nth-after l n)
(let loop ((l l) (n n)) (if (> n 0) (loop (cdr l) (- n 1)) l)))
(define (pair-up l1 l2)
(define (pair l1 l2)
(if (pair? l1)
(cons (cons (car l1) (car l2)) (pair (cdr l1) (cdr l2)))
'()))
(pair l1 l2))
(define (my-last-pair l)
(let loop ((l l)) (if (pair? (cdr l)) (loop (cdr l)) l)))
(define (sort-list l <?)
(define (mergesort l)
(define (merge l1 l2)
(cond ((null? l1) l2)
((null? l2) l1)
(else
(let ((e1 (car l1)) (e2 (car l2)))
(if (<? e1 e2)
(cons e1 (merge (cdr l1) l2))
(cons e2 (merge l1 (cdr l2))))))))
(define (split l)
(if (or (null? l) (null? (cdr l))) l (cons (car l) (split (cddr l)))))
(if (or (null? l) (null? (cdr l)))
l
(let* ((l1 (mergesort (split l))) (l2 (mergesort (split (cdr l)))))
(merge l1 l2))))
(mergesort l))
(define (lst->vector l)
(let* ((n (length l)) (v (make-vector n)))
(let loop ((l l) (i 0))
(if (pair? l)
(begin (vector-set! v i (car l)) (loop (cdr l) (+ i 1)))
v))))
(define (vector->lst v)
(let loop ((l '()) (i (- (vector-length v) 1)))
(if (< i 0) l (loop (cons (vector-ref v i) l) (- i 1)))))
(define (lst->string l)
(let* ((n (length l)) (s (make-string n)))
(let loop ((l l) (i 0))
(if (pair? l)
(begin (string-set! s i (car l)) (loop (cdr l) (+ i 1)))
s))))
(define (string->lst s)
(let loop ((l '()) (i (- (string-length s) 1)))
(if (< i 0) l (loop (cons (string-ref s i) l) (- i 1)))))
(define (with-exception-handling proc)
(let ((old-exception-handler throw-to-exception-handler))
(let ((val (call-with-current-continuation
(lambda (cont)
(set! throw-to-exception-handler cont)
(proc)))))
(set! throw-to-exception-handler old-exception-handler)
val)))
(define (throw-to-exception-handler val)
(fatal-err "Internal error, no exception handler at this point" val))
(define (compiler-error msg . args)
(newline)
(display "*** ERROR -- ")
(display msg)
(for-each (lambda (x) (display " ") (write x)) args)
(newline)
(compiler-abort))
(define (compiler-user-error loc msg . args)
(newline)
(display "*** ERROR -- In ")
(locat-show loc)
(newline)
(display "*** ")
(display msg)
(for-each (lambda (x) (display " ") (write x)) args)
(newline)
(compiler-abort))
(define (compiler-internal-error msg . args)
(newline)
(display "*** ERROR -- Compiler internal error detected")
(newline)
(display "*** in procedure ")
(display msg)
(for-each (lambda (x) (display " ") (write x)) args)
(newline)
(compiler-abort))
(define (compiler-limitation-error msg . args)
(newline)
(display "*** ERROR -- Compiler limit reached")
(newline)
(display "*** ")
(display msg)
(for-each (lambda (x) (display " ") (write x)) args)
(newline)
(compiler-abort))
(define (compiler-abort) (throw-to-exception-handler #f))
(define (make-gnode label edges) (vector label edges))
(define (gnode-label x) (vector-ref x 0))
(define (gnode-edges x) (vector-ref x 1))
(define (transitive-closure graph)
(define changed? #f)
(define (closure edges)
(list->set
(set-union
edges
(apply set-union
(map (lambda (label) (gnode-edges (gnode-find label graph)))
(set->list edges))))))
(let ((new-graph
(set-map (lambda (x)
(let ((new-edges (closure (gnode-edges x))))
(if (not (set-equal? new-edges (gnode-edges x)))
(set! changed? #t))
(make-gnode (gnode-label x) new-edges)))
graph)))
(if changed? (transitive-closure new-graph) new-graph)))
(define (gnode-find label graph)
(define (find label l)
(cond ((null? l) #f)
((eq? (gnode-label (car l)) label) (car l))
(else (find label (cdr l)))))
(find label (set->list graph)))
(define (topological-sort graph)
(if (set-empty? graph)
'()
(let ((to-remove (or (remove-no-edges graph) (remove-cycle graph))))
(let ((labels (set-map gnode-label to-remove)))
(cons labels
(topological-sort
(set-map (lambda (x)
(make-gnode
(gnode-label x)
(set-difference (gnode-edges x) labels)))
(set-difference graph to-remove))))))))
(define (remove-no-edges graph)
(let ((nodes-with-no-edges
(set-keep (lambda (x) (set-empty? (gnode-edges x))) graph)))
(if (set-empty? nodes-with-no-edges) #f nodes-with-no-edges)))
(define (remove-cycle graph)
(define (remove l)
(let ((edges (gnode-edges (car l))))
(define (equal-edges? x) (set-equal? (gnode-edges x) edges))
(define (member-edges? x) (set-member? (gnode-label x) edges))
(if (set-member? (gnode-label (car l)) edges)
(let ((edge-graph (set-keep member-edges? graph)))
(if (set-every? equal-edges? edge-graph)
edge-graph
(remove (cdr l))))
(remove (cdr l)))))
(remove (set->list graph)))
(define (list->set list) list)
(define (set->list set) set)
(define (set-empty) '())
(define (set-empty? set) (null? set))
(define (set-member? x set) (memq x set))
(define (set-singleton x) (list x))
(define (set-adjoin set x) (if (memq x set) set (cons x set)))
(define (set-remove set x)
(cond ((null? set) '())
((eq? (car set) x) (cdr set))
(else (cons (car set) (set-remove (cdr set) x)))))
(define (set-equal? s1 s2)
(cond ((null? s1) (null? s2))
((memq (car s1) s2) (set-equal? (cdr s1) (set-remove s2 (car s1))))
(else #f)))
(define (set-difference set . other-sets)
(define (difference s1 s2)
(cond ((null? s1) '())
((memq (car s1) s2) (difference (cdr s1) s2))
(else (cons (car s1) (difference (cdr s1) s2)))))
(n-ary difference set other-sets))
(define (set-union . sets)
(define (union s1 s2)
(cond ((null? s1) s2)
((memq (car s1) s2) (union (cdr s1) s2))
(else (cons (car s1) (union (cdr s1) s2)))))
(n-ary union '() sets))
(define (set-intersection set . other-sets)
(define (intersection s1 s2)
(cond ((null? s1) '())
((memq (car s1) s2) (cons (car s1) (intersection (cdr s1) s2)))
(else (intersection (cdr s1) s2))))
(n-ary intersection set other-sets))
(define (n-ary function first rest)
(if (null? rest)
first
(n-ary function (function first (car rest)) (cdr rest))))
(define (set-keep keep? set)
(cond ((null? set) '())
((keep? (car set)) (cons (car set) (set-keep keep? (cdr set))))
(else (set-keep keep? (cdr set)))))
(define (set-every? pred? set)
(or (null? set) (and (pred? (car set)) (set-every? pred? (cdr set)))))
(define (set-map proc set)
(if (null? set) '() (cons (proc (car set)) (set-map proc (cdr set)))))
(define (list->queue list)
(cons list (if (pair? list) (my-last-pair list) '())))
(define (queue->list queue) (car queue))
(define (queue-empty) (cons '() '()))
(define (queue-empty? queue) (null? (car queue)))
(define (queue-get! queue)
(if (null? (car queue))
(compiler-internal-error "queue-get!, queue is empty")
(let ((x (caar queue)))
(set-car! queue (cdar queue))
(if (null? (car queue)) (set-cdr! queue '()))
x)))
(define (queue-put! queue x)
(let ((entry (cons x '())))
(if (null? (car queue))
(set-car! queue entry)
(set-cdr! (cdr queue) entry))
(set-cdr! queue entry)
x))
(define (string->canonical-symbol str)
(let ((len (string-length str)))
(let loop ((str str) (s (make-string len)) (i (- len 1)))
(if (>= i 0)
(begin
(string-set! s i (char-downcase (string-ref str i)))
(loop str s (- i 1)))
(string->symbol s)))))
(define quote-sym (string->canonical-symbol "QUOTE"))
(define quasiquote-sym (string->canonical-symbol "QUASIQUOTE"))
(define unquote-sym (string->canonical-symbol "UNQUOTE"))
(define unquote-splicing-sym (string->canonical-symbol "UNQUOTE-SPLICING"))
(define lambda-sym (string->canonical-symbol "LAMBDA"))
(define if-sym (string->canonical-symbol "IF"))
(define set!-sym (string->canonical-symbol "SET!"))
(define cond-sym (string->canonical-symbol "COND"))
(define =>-sym (string->canonical-symbol "=>"))
(define else-sym (string->canonical-symbol "ELSE"))
(define and-sym (string->canonical-symbol "AND"))
(define or-sym (string->canonical-symbol "OR"))
(define case-sym (string->canonical-symbol "CASE"))
(define let-sym (string->canonical-symbol "LET"))
(define let*-sym (string->canonical-symbol "LET*"))
(define letrec-sym (string->canonical-symbol "LETREC"))
(define begin-sym (string->canonical-symbol "BEGIN"))
(define do-sym (string->canonical-symbol "DO"))
(define define-sym (string->canonical-symbol "DEFINE"))
(define delay-sym (string->canonical-symbol "DELAY"))
(define future-sym (string->canonical-symbol "FUTURE"))
(define **define-macro-sym (string->canonical-symbol "DEFINE-MACRO"))
(define **declare-sym (string->canonical-symbol "DECLARE"))
(define **include-sym (string->canonical-symbol "INCLUDE"))
(define not-sym (string->canonical-symbol "NOT"))
(define **c-declaration-sym (string->canonical-symbol "C-DECLARATION"))
(define **c-init-sym (string->canonical-symbol "C-INIT"))
(define **c-procedure-sym (string->canonical-symbol "C-PROCEDURE"))
(define void-sym (string->canonical-symbol "VOID"))
(define char-sym (string->canonical-symbol "CHAR"))
(define signed-char-sym (string->canonical-symbol "SIGNED-CHAR"))
(define unsigned-char-sym (string->canonical-symbol "UNSIGNED-CHAR"))
(define short-sym (string->canonical-symbol "SHORT"))
(define unsigned-short-sym (string->canonical-symbol "UNSIGNED-SHORT"))
(define int-sym (string->canonical-symbol "INT"))
(define unsigned-int-sym (string->canonical-symbol "UNSIGNED-INT"))
(define long-sym (string->canonical-symbol "LONG"))
(define unsigned-long-sym (string->canonical-symbol "UNSIGNED-LONG"))
(define float-sym (string->canonical-symbol "FLOAT"))
(define double-sym (string->canonical-symbol "DOUBLE"))
(define pointer-sym (string->canonical-symbol "POINTER"))
(define boolean-sym (string->canonical-symbol "BOOLEAN"))
(define string-sym (string->canonical-symbol "STRING"))
(define scheme-object-sym (string->canonical-symbol "SCHEME-OBJECT"))
(define c-id-prefix "___")
(define false-object (if (eq? '() #f) (string->symbol "#f") #f))
(define (false-object? obj) (eq? obj false-object))
(define undef-object (string->symbol "#[undefined]"))
(define (undef-object? obj) (eq? obj undef-object))
(define (symbol-object? obj)
(and (not (false-object? obj)) (not (undef-object? obj)) (symbol? obj)))
(define scm-file-exts '("scm" #f))
(define compiler-version "2.2.2")
(define (open-sf filename)
(define (open-err) (compiler-error "Can't find file" filename))
(if (not (file-ext filename))
(let loop ((exts scm-file-exts))
(if (pair? exts)
(let* ((ext (car exts))
(full-name
(if ext (string-append filename "." ext) filename))
(port (open-input-file* full-name)))
(if port (vector port full-name 0 1 0) (loop (cdr exts))))
(open-err)))
(let ((port (open-input-file* filename)))
(if port (vector port filename 0 1 0) (open-err)))))
(define (close-sf sf) (close-input-port (vector-ref sf 0)))
(define (sf-read-char sf)
(let ((c (read-char (vector-ref sf 0))))
(cond ((eof-object? c))
((char=? c char-newline)
(vector-set! sf 3 (+ (vector-ref sf 3) 1))
(vector-set! sf 4 0))
(else (vector-set! sf 4 (+ (vector-ref sf 4) 1))))
c))
(define (sf-peek-char sf) (peek-char (vector-ref sf 0)))
(define (sf-read-error sf msg . args)
(apply compiler-user-error
(cons (sf->locat sf)
(cons (string-append "Read error -- " msg) args))))
(define (sf->locat sf)
(vector 'file
(vector-ref sf 1)
(vector-ref sf 2)
(vector-ref sf 3)
(vector-ref sf 4)))
(define (expr->locat expr source) (vector 'expr expr source))
(define (locat-show loc)
(if loc
(case (vector-ref loc 0)
((file)
(if (pinpoint-error
(vector-ref loc 1)
(vector-ref loc 3)
(vector-ref loc 4))
(begin
(display "file \"")
(display (vector-ref loc 1))
(display "\", line ")
(display (vector-ref loc 3))
(display ", character ")
(display (vector-ref loc 4)))))
((expr)
(display "expression ")
(write (vector-ref loc 1))
(if (vector-ref loc 2)
(begin
(display " ")
(locat-show (source-locat (vector-ref loc 2))))))
(else (compiler-internal-error "locat-show, unknown location tag")))
(display "unknown location")))
(define (locat-filename loc)
(if loc
(case (vector-ref loc 0)
((file) (vector-ref loc 1))
((expr)
(let ((source (vector-ref loc 2)))
(if source (locat-filename (source-locat source)) "")))
(else
(compiler-internal-error "locat-filename, unknown location tag")))
""))
(define (make-source code locat) (vector code locat))
(define (source-code x) (vector-ref x 0))
(define (source-code-set! x y) (vector-set! x 0 y) x)
(define (source-locat x) (vector-ref x 1))
(define (expression->source expr source)
(define (expr->source x)
(make-source
(cond ((pair? x) (list->source x))
((vector? x) (vector->source x))
((symbol-object? x) (string->canonical-symbol (symbol->string x)))
(else x))
(expr->locat x source)))
(define (list->source l)
(cond ((pair? l) (cons (expr->source (car l)) (list->source (cdr l))))
((null? l) '())
(else (expr->source l))))
(define (vector->source v)
(let* ((len (vector-length v)) (x (make-vector len)))
(let loop ((i (- len 1)))
(if (>= i 0)
(begin
(vector-set! x i (expr->source (vector-ref v i)))
(loop (- i 1)))))
x))
(expr->source expr))
(define (source->expression source)
(define (list->expression l)
(cond ((pair? l)
(cons (source->expression (car l)) (list->expression (cdr l))))
((null? l) '())
(else (source->expression l))))
(define (vector->expression v)
(let* ((len (vector-length v)) (x (make-vector len)))
(let loop ((i (- len 1)))
(if (>= i 0)
(begin
(vector-set! x i (source->expression (vector-ref v i)))
(loop (- i 1)))))
x))
(let ((code (source-code source)))
(cond ((pair? code) (list->expression code))
((vector? code) (vector->expression code))
(else code))))
(define (file->sources filename info-port)
(if info-port
(begin
(display "(reading \"" info-port)
(display filename info-port)
(display "\"" info-port)))
(let ((sf (open-sf filename)))
(define (read-sources)
(let ((source (read-source sf)))
(if (not (eof-object? source))
(begin
(if info-port (display "." info-port))
(cons source (read-sources)))
'())))
(let ((sources (read-sources)))
(if info-port (display ")" info-port))
(close-sf sf)
sources)))
(define (file->sources* filename info-port loc)
(file->sources
(if (path-absolute? filename)
filename
(string-append (file-path (locat-filename loc)) filename))
info-port))
(define (read-source sf)
(define (read-char*)
(let ((c (sf-read-char sf)))
(if (eof-object? c)
(sf-read-error sf "Premature end of file encountered")
c)))
(define (read-non-whitespace-char)
(let ((c (read-char*)))
(cond ((< 0 (vector-ref read-table (char->integer c)))
(read-non-whitespace-char))
((char=? c #\;)
(let loop ()
(if (not (char=? (read-char*) char-newline))
(loop)
(read-non-whitespace-char))))
(else c))))
(define (delimiter? c)
(or (eof-object? c) (not (= (vector-ref read-table (char->integer c)) 0))))
(define (read-list first)
(let ((result (cons first '())))
(let loop ((end result))
(let ((c (read-non-whitespace-char)))
(cond ((char=? c #\)))
((and (char=? c #\.) (delimiter? (sf-peek-char sf)))
(let ((x (read-source sf)))
(if (char=? (read-non-whitespace-char) #\))
(set-cdr! end x)
(sf-read-error sf "')' expected"))))
(else
(let ((tail (cons (rd* c) '())))
(set-cdr! end tail)
(loop tail))))))
result))
(define (read-vector)
(define (loop i)
(let ((c (read-non-whitespace-char)))
(if (char=? c #\))
(make-vector i '())
(let* ((x (rd* c)) (v (loop (+ i 1)))) (vector-set! v i x) v))))
(loop 0))
(define (read-string)
(define (loop i)
(let ((c (read-char*)))
(cond ((char=? c #\") (make-string i #\space))
((char=? c #\\)
(let* ((c (read-char*)) (s (loop (+ i 1))))
(string-set! s i c)
s))
(else (let ((s (loop (+ i 1)))) (string-set! s i c) s)))))
(loop 0))
(define (read-symbol/number-string i)
(if (delimiter? (sf-peek-char sf))
(make-string i #\space)
(let* ((c (sf-read-char sf)) (s (read-symbol/number-string (+ i 1))))
(string-set! s i (char-downcase c))
s)))
(define (read-symbol/number c)
(let ((s (read-symbol/number-string 1)))
(string-set! s 0 (char-downcase c))
(or (string->number s 10) (string->canonical-symbol s))))
(define (read-prefixed-number c)
(let ((s (read-symbol/number-string 2)))
(string-set! s 0 #\#)
(string-set! s 1 c)
(string->number s 10)))
(define (read-special-symbol)
(let ((s (read-symbol/number-string 2)))
(string-set! s 0 #\#)
(string-set! s 1 #\#)
(string->canonical-symbol s)))
(define (rd c)
(cond ((eof-object? c) c)
((< 0 (vector-ref read-table (char->integer c)))
(rd (sf-read-char sf)))
((char=? c #\;)
(let loop ()
(let ((c (sf-read-char sf)))
(cond ((eof-object? c) c)
((char=? c char-newline) (rd (sf-read-char sf)))
(else (loop))))))
(else (rd* c))))
(define (rd* c)
(let ((source (make-source #f (sf->locat sf))))
(source-code-set!
source
(cond ((char=? c #\()
(let ((x (read-non-whitespace-char)))
(if (char=? x #\)) '() (read-list (rd* x)))))
((char=? c #\#)
(let ((c (char-downcase (sf-read-char sf))))
(cond ((char=? c #\() (read-vector))
((char=? c #\f) false-object)
((char=? c #\t) #t)
((char=? c #\\)
(let ((c (read-char*)))
(if (or (not (char-alphabetic? c))
(delimiter? (sf-peek-char sf)))
c
(let ((name (read-symbol/number c)))
(let ((x (assq name named-char-table)))
(if x
(cdr x)
(sf-read-error
sf
"Unknown character name"
name)))))))
((char=? c #\#) (read-special-symbol))
(else
(let ((num (read-prefixed-number c)))
(or num
(sf-read-error
sf
"Unknown '#' read macro"
c)))))))
((char=? c #\") (read-string))
((char=? c #\')
(list (make-source quote-sym (sf->locat sf)) (read-source sf)))
((char=? c #\`)
(list (make-source quasiquote-sym (sf->locat sf))
(read-source sf)))
((char=? c #\,)
(if (char=? (sf-peek-char sf) #\@)
(let ((x (make-source unquote-splicing-sym (sf->locat sf))))
(sf-read-char sf)
(list x (read-source sf)))
(list (make-source unquote-sym (sf->locat sf))
(read-source sf))))
((char=? c #\)) (sf-read-error sf "Misplaced ')'"))
((or (char=? c #\[) (char=? c #\]) (char=? c #\{) (char=? c #\}))
(sf-read-error sf "Illegal character" c))
(else
(if (char=? c #\.)
(if (delimiter? (sf-peek-char sf))
(sf-read-error sf "Misplaced '.'")))
(read-symbol/number c))))))
(rd (sf-read-char sf)))
(define named-char-table
(list (cons (string->canonical-symbol "NUL") char-nul)
(cons (string->canonical-symbol "TAB") char-tab)
(cons (string->canonical-symbol "NEWLINE") char-newline)
(cons (string->canonical-symbol "SPACE") #\space)))
(define read-table
(let ((rt (make-vector (+ max-character-encoding 1) 0)))
(vector-set! rt (char->integer char-tab) 1)
(vector-set! rt (char->integer char-newline) 1)
(vector-set! rt (char->integer #\space) 1)
(vector-set! rt (char->integer #\;) -1)
(vector-set! rt (char->integer #\() -1)
(vector-set! rt (char->integer #\)) -1)
(vector-set! rt (char->integer #\") -1)
(vector-set! rt (char->integer #\') -1)
(vector-set! rt (char->integer #\`) -1)
rt))
(define (make-var name bound refs sets source)
(vector var-tag name bound refs sets source #f))
(define (var? x)
(and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) var-tag)))
(define (var-name x) (vector-ref x 1))
(define (var-bound x) (vector-ref x 2))
(define (var-refs x) (vector-ref x 3))
(define (var-sets x) (vector-ref x 4))
(define (var-source x) (vector-ref x 5))
(define (var-info x) (vector-ref x 6))
(define (var-name-set! x y) (vector-set! x 1 y))
(define (var-bound-set! x y) (vector-set! x 2 y))
(define (var-refs-set! x y) (vector-set! x 3 y))
(define (var-sets-set! x y) (vector-set! x 4 y))
(define (var-source-set! x y) (vector-set! x 5 y))
(define (var-info-set! x y) (vector-set! x 6 y))
(define var-tag (list 'var-tag))
(define (var-copy var)
(make-var (var-name var) #t (set-empty) (set-empty) (var-source var)))
(define (make-temp-var name) (make-var name #t (set-empty) (set-empty) #f))
(define (temp-var? var) (eq? (var-bound var) #t))
(define ret-var (make-temp-var 'ret))
(define ret-var-set (set-singleton ret-var))
(define closure-env-var (make-temp-var 'closure-env))
(define empty-var (make-temp-var #f))
(define make-global-environment #f)
(set! make-global-environment (lambda () (env-frame #f '())))
(define (env-frame env vars) (vector (cons vars #f) '() '() env))
(define (env-new-var! env name source)
(let* ((glob (not (env-parent-ref env)))
(var (make-var name (not glob) (set-empty) (set-empty) source)))
(env-vars-set! env (cons var (env-vars-ref env)))
var))
(define (env-macro env name def)
(let ((name* (if (full-name? name)
name
(let ((prefix (env-namespace-prefix env name)))
(if prefix (make-full-name prefix name) name)))))
(vector (vector-ref env 0)
(cons (cons name* def) (env-macros-ref env))
(env-decls-ref env)
(env-parent-ref env))))
(define (env-declare env decl)
(vector (vector-ref env 0)
(env-macros-ref env)
(cons decl (env-decls-ref env))
(env-parent-ref env)))
(define (env-vars-ref env) (car (vector-ref env 0)))
(define (env-vars-set! env vars) (set-car! (vector-ref env 0) vars))
(define (env-macros-ref env) (vector-ref env 1))
(define (env-decls-ref env) (vector-ref env 2))
(define (env-parent-ref env) (vector-ref env 3))
(define (env-namespace-prefix env name)
(let loop ((decls (env-decls-ref env)))
(if (pair? decls)
(let ((decl (car decls)))
(if (eq? (car decl) namespace-sym)
(let ((syms (cddr decl)))
(if (or (null? syms) (memq name syms))
(cadr decl)
(loop (cdr decls))))
(loop (cdr decls))))
#f)))
(define (env-lookup env name stop-at-first-frame? proc)
(define (search env name full?)
(if full?
(search* env name full?)
(let ((prefix (env-namespace-prefix env name)))
(if prefix
(search* env (make-full-name prefix name) #t)
(search* env name full?)))))
(define (search* env name full?)
(define (search-macros macros)
(if (pair? macros)
(let ((m (car macros)))
(if (eq? (car m) name)
(proc env name (cdr m))
(search-macros (cdr macros))))
(search-vars (env-vars-ref env))))
(define (search-vars vars)
(if (pair? vars)
(let ((v (car vars)))
(if (eq? (var-name v) name)
(proc env name v)
(search-vars (cdr vars))))
(let ((env* (env-parent-ref env)))
(if (or stop-at-first-frame? (not env*))
(proc env name #f)
(search env* name full?)))))
(search-macros (env-macros-ref env)))
(search env name (full-name? name)))
(define (valid-prefix? str)
(let ((l (string-length str)))
(or (= l 0) (and (>= l 2) (char=? (string-ref str (- l 1)) #\#)))))
(define (full-name? sym)
(let ((str (symbol->string sym)))
(let loop ((i (- (string-length str) 1)))
(if (< i 0) #f (if (char=? (string-ref str i) #\#) #t (loop (- i 1)))))))
(define (make-full-name prefix sym)
(if (= (string-length prefix) 0)
sym
(string->canonical-symbol (string-append prefix (symbol->string sym)))))
(define (env-lookup-var env name source)
(env-lookup
env
name
#f
(lambda (env name x)
(if x
(if (var? x)
x
(compiler-internal-error
"env-lookup-var, name is that of a macro"
name))
(env-new-var! env name source)))))
(define (env-define-var env name source)
(env-lookup
env
name
#t
(lambda (env name x)
(if x
(if (var? x)
(pt-syntax-error source "Duplicate definition of a variable")
(compiler-internal-error
"env-define-var, name is that of a macro"
name))
(env-new-var! env name source)))))
(define (env-lookup-global-var env name)
(let ((env* (env-global-env env)))
(define (search-vars vars)
(if (pair? vars)
(let ((v (car vars)))
(if (eq? (var-name v) name) v (search-vars (cdr vars))))
(env-new-var! env* name #f)))
(search-vars (env-vars-ref env*))))
(define (env-global-variables env) (env-vars-ref (env-global-env env)))
(define (env-global-env env)
(let loop ((env env))
(let ((env* (env-parent-ref env))) (if env* (loop env*) env))))
(define (env-lookup-macro env name)
(env-lookup
env
name
#f
(lambda (env name x) (if (or (not x) (var? x)) #f x))))
(define (env-declarations env) env)
(define flag-declarations '())
(define parameterized-declarations '())
(define boolean-declarations '())
(define namable-declarations '())
(define namable-boolean-declarations '())
(define namable-string-declarations '())
(define (define-flag-decl name type)
(set! flag-declarations (cons (cons name type) flag-declarations))
'())
(define (define-parameterized-decl name)
(set! parameterized-declarations (cons name parameterized-declarations))
'())
(define (define-boolean-decl name)
(set! boolean-declarations (cons name boolean-declarations))
'())
(define (define-namable-decl name type)
(set! namable-declarations (cons (cons name type) namable-declarations))
'())
(define (define-namable-boolean-decl name)
(set! namable-boolean-declarations (cons name namable-boolean-declarations))
'())
(define (define-namable-string-decl name)
(set! namable-string-declarations (cons name namable-string-declarations))
'())
(define (flag-decl source type val) (list type val))
(define (parameterized-decl source id parm) (list id parm))
(define (boolean-decl source id pos) (list id pos))
(define (namable-decl source type val names) (cons type (cons val names)))
(define (namable-boolean-decl source id pos names) (cons id (cons pos names)))
(define (namable-string-decl source id str names)
(if (and (eq? id namespace-sym) (not (valid-prefix? str)))
(pt-syntax-error source "Illegal namespace"))
(cons id (cons str names)))
(define (declaration-value name element default decls)
(if (not decls)
default
(let loop ((l (env-decls-ref decls)))
(if (pair? l)
(let ((d (car l)))
(if (and (eq? (car d) name)
(or (null? (cddr d)) (memq element (cddr d))))
(cadr d)
(loop (cdr l))))
(declaration-value name element default (env-parent-ref decls))))))
(define namespace-sym (string->canonical-symbol "NAMESPACE"))
(define-namable-string-decl namespace-sym)
(define (node-parent x) (vector-ref x 1))
(define (node-children x) (vector-ref x 2))
(define (node-fv x) (vector-ref x 3))
(define (node-decl x) (vector-ref x 4))
(define (node-source x) (vector-ref x 5))
(define (node-parent-set! x y) (vector-set! x 1 y))
(define (node-fv-set! x y) (vector-set! x 3 y))
(define (node-decl-set! x y) (vector-set! x 4 y))
(define (node-source-set! x y) (vector-set! x 5 y))
(define (node-children-set! x y)
(vector-set! x 2 y)
(for-each (lambda (child) (node-parent-set! child x)) y)
(node-fv-invalidate! x))
(define (node-fv-invalidate! x)
(let loop ((node x))
(if node (begin (node-fv-set! node #t) (loop (node-parent node))))))
(define (make-cst parent children fv decl source val)
(vector cst-tag parent children fv decl source val))
(define (cst? x)
(and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) cst-tag)))
(define (cst-val x) (vector-ref x 6))
(define (cst-val-set! x y) (vector-set! x 6 y))
(define cst-tag (list 'cst-tag))
(define (make-ref parent children fv decl source var)
(vector ref-tag parent children fv decl source var))
(define (ref? x)
(and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) ref-tag)))
(define (ref-var x) (vector-ref x 6))
(define (ref-var-set! x y) (vector-set! x 6 y))
(define ref-tag (list 'ref-tag))
(define (make-set parent children fv decl source var)
(vector set-tag parent children fv decl source var))
(define (set? x)
(and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) set-tag)))
(define (set-var x) (vector-ref x 6))
(define (set-var-set! x y) (vector-set! x 6 y))
(define set-tag (list 'set-tag))
(define (make-def parent children fv decl source var)
(vector def-tag parent children fv decl source var))
(define (def? x)
(and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) def-tag)))
(define (def-var x) (vector-ref x 6))
(define (def-var-set! x y) (vector-set! x 6 y))
(define def-tag (list 'def-tag))
(define (make-tst parent children fv decl source)
(vector tst-tag parent children fv decl source))
(define (tst? x)
(and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) tst-tag)))
(define tst-tag (list 'tst-tag))
(define (make-conj parent children fv decl source)
(vector conj-tag parent children fv decl source))
(define (conj? x)
(and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) conj-tag)))
(define conj-tag (list 'conj-tag))
(define (make-disj parent children fv decl source)
(vector disj-tag parent children fv decl source))
(define (disj? x)
(and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) disj-tag)))
(define disj-tag (list 'disj-tag))
(define (make-prc parent children fv decl source name min rest parms)
(vector prc-tag parent children fv decl source name min rest parms))
(define (prc? x)
(and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) prc-tag)))
(define (prc-name x) (vector-ref x 6))
(define (prc-min x) (vector-ref x 7))
(define (prc-rest x) (vector-ref x 8))
(define (prc-parms x) (vector-ref x 9))
(define (prc-name-set! x y) (vector-set! x 6 y))
(define (prc-min-set! x y) (vector-set! x 7 y))
(define (prc-rest-set! x y) (vector-set! x 8 y))
(define (prc-parms-set! x y) (vector-set! x 9 y))
(define prc-tag (list 'prc-tag))
(define (make-app parent children fv decl source)
(vector app-tag parent children fv decl source))
(define (app? x)
(and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) app-tag)))
(define app-tag (list 'app-tag))
(define (make-fut parent children fv decl source)
(vector fut-tag parent children fv decl source))
(define (fut? x)
(and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) fut-tag)))
(define fut-tag (list 'fut-tag))
(define (new-cst source decl val) (make-cst #f '() #t decl source val))
(define (new-ref source decl var)
(let ((node (make-ref #f '() #t decl source var)))
(var-refs-set! var (set-adjoin (var-refs var) node))
node))
(define (new-ref-extended-bindings source name env)
(new-ref source
(add-extended-bindings (env-declarations env))
(env-lookup-global-var env name)))
(define (new-set source decl var val)
(let ((node (make-set #f (list val) #t decl source var)))
(var-sets-set! var (set-adjoin (var-sets var) node))
(node-parent-set! val node)
node))
(define (set-val x)
(if (set? x)
(car (node-children x))
(compiler-internal-error "set-val, 'set' node expected" x)))
(define (new-def source decl var val)
(let ((node (make-def #f (list val) #t decl source var)))
(var-sets-set! var (set-adjoin (var-sets var) node))
(node-parent-set! val node)
node))
(define (def-val x)
(if (def? x)
(car (node-children x))
(compiler-internal-error "def-val, 'def' node expected" x)))
(define (new-tst source decl pre con alt)
(let ((node (make-tst #f (list pre con alt) #t decl source)))
(node-parent-set! pre node)
(node-parent-set! con node)
(node-parent-set! alt node)
node))
(define (tst-pre x)
(if (tst? x)
(car (node-children x))
(compiler-internal-error "tst-pre, 'tst' node expected" x)))
(define (tst-con x)
(if (tst? x)
(cadr (node-children x))
(compiler-internal-error "tst-con, 'tst' node expected" x)))
(define (tst-alt x)
(if (tst? x)
(caddr (node-children x))
(compiler-internal-error "tst-alt, 'tst' node expected" x)))
(define (new-conj source decl pre alt)
(let ((node (make-conj #f (list pre alt) #t decl source)))
(node-parent-set! pre node)
(node-parent-set! alt node)
node))
(define (conj-pre x)
(if (conj? x)
(car (node-children x))
(compiler-internal-error "conj-pre, 'conj' node expected" x)))
(define (conj-alt x)
(if (conj? x)
(cadr (node-children x))
(compiler-internal-error "conj-alt, 'conj' node expected" x)))
(define (new-disj source decl pre alt)
(let ((node (make-disj #f (list pre alt) #t decl source)))
(node-parent-set! pre node)
(node-parent-set! alt node)
node))
(define (disj-pre x)
(if (disj? x)
(car (node-children x))
(compiler-internal-error "disj-pre, 'disj' node expected" x)))
(define (disj-alt x)
(if (disj? x)
(cadr (node-children x))
(compiler-internal-error "disj-alt, 'disj' node expected" x)))
(define (new-prc source decl name min rest parms body)
(let ((node (make-prc #f (list body) #t decl source name min rest parms)))
(for-each (lambda (x) (var-bound-set! x node)) parms)
(node-parent-set! body node)
node))
(define (prc-body x)
(if (prc? x)
(car (node-children x))
(compiler-internal-error "prc-body, 'proc' node expected" x)))
(define (new-call source decl oper args)
(let ((node (make-app #f (cons oper args) #t decl source)))
(node-parent-set! oper node)
(for-each (lambda (x) (node-parent-set! x node)) args)
node))
(define (new-call* source decl oper args)
(if *ptree-port*
(if (ref? oper)
(let ((var (ref-var oper)))
(if (global? var)
(let ((proc (standard-procedure
(var-name var)
(node-decl oper))))
(if (and proc
(not (nb-args-conforms?
(length args)
(standard-procedure-call-pattern proc))))
(begin
(display "*** WARNING -- \"" *ptree-port*)
(display (var-name var) *ptree-port*)
(display "\" is called with " *ptree-port*)
(display (length args) *ptree-port*)
(display " argument(s)." *ptree-port*)
(newline *ptree-port*))))))))
(new-call source decl oper args))
(define (app-oper x)
(if (app? x)
(car (node-children x))
(compiler-internal-error "app-oper, 'call' node expected" x)))
(define (app-args x)
(if (app? x)
(cdr (node-children x))
(compiler-internal-error "app-args, 'call' node expected" x)))
(define (oper-pos? node)
(let ((parent (node-parent node)))
(if parent (and (app? parent) (eq? (app-oper parent) node)) #f)))
(define (new-fut source decl val)
(let ((node (make-fut #f (list val) #t decl source)))
(node-parent-set! val node)
node))
(define (fut-val x)
(if (fut? x)
(car (node-children x))
(compiler-internal-error "fut-val, 'fut' node expected" x)))
(define (new-disj-call source decl pre oper alt)
(new-call*
source
decl
(let* ((parms (new-temps source '(temp))) (temp (car parms)))
(new-prc source
decl
#f
1
#f
parms
(new-tst source
decl
(new-ref source decl temp)
(new-call*
source
decl
oper
(list (new-ref source decl temp)))
alt)))
(list pre)))
(define (new-seq source decl before after)
(new-call*
source
decl
(new-prc source decl #f 1 #f (new-temps source '(temp)) after)
(list before)))
(define (new-let ptree proc vars vals body)
(if (pair? vars)
(new-call
(node-source ptree)
(node-decl ptree)
(new-prc (node-source proc)
(node-decl proc)
(prc-name proc)
(length vars)
#f
(reverse vars)
body)
(reverse vals))
body))
(define (new-temps source names)
(if (null? names)
'()
(cons (make-var (car names) #t (set-empty) (set-empty) source)
(new-temps source (cdr names)))))
(define (new-variables vars)
(if (null? vars)
'()
(cons (make-var
(source-code (car vars))
#t
(set-empty)
(set-empty)
(car vars))
(new-variables (cdr vars)))))
(define (set-prc-names! vars vals)
(let loop ((vars vars) (vals vals))
(if (not (null? vars))
(let ((var (car vars)) (val (car vals)))
(if (prc? val) (prc-name-set! val (symbol->string (var-name var))))
(loop (cdr vars) (cdr vals))))))
(define (free-variables node)
(if (eq? (node-fv node) #t)
(let ((x (apply set-union (map free-variables (node-children node)))))
(node-fv-set!
node
(cond ((ref? node)
(if (global? (ref-var node)) x (set-adjoin x (ref-var node))))
((set? node)
(if (global? (set-var node)) x (set-adjoin x (set-var node))))
((prc? node) (set-difference x (list->set (prc-parms node))))
((and (app? node) (prc? (app-oper node)))
(set-difference x (list->set (prc-parms (app-oper node)))))
(else x)))))
(node-fv node))
(define (bound-variables node) (list->set (prc-parms node)))
(define (not-mutable? var) (set-empty? (var-sets var)))
(define (mutable? var) (not (not-mutable? var)))
(define (bound? var) (var-bound var))
(define (global? var) (not (bound? var)))
(define (global-val var)
(and (global? var)
(let ((sets (set->list (var-sets var))))
(and (pair? sets)
(null? (cdr sets))
(def? (car sets))
(eq? (compilation-strategy (node-decl (car sets))) block-sym)
(def-val (car sets))))))
(define **not-sym (string->canonical-symbol "##NOT"))
(define **quasi-append-sym (string->canonical-symbol "##QUASI-APPEND"))
(define **quasi-list-sym (string->canonical-symbol "##QUASI-LIST"))
(define **quasi-cons-sym (string->canonical-symbol "##QUASI-CONS"))
(define **quasi-list->vector-sym
(string->canonical-symbol "##QUASI-LIST->VECTOR"))
(define **case-memv-sym (string->canonical-symbol "##CASE-MEMV"))
(define **unassigned?-sym (string->canonical-symbol "##UNASSIGNED?"))
(define **make-cell-sym (string->canonical-symbol "##MAKE-CELL"))
(define **cell-ref-sym (string->canonical-symbol "##CELL-REF"))
(define **cell-set!-sym (string->canonical-symbol "##CELL-SET!"))
(define **make-placeholder-sym (string->canonical-symbol "##MAKE-PLACEHOLDER"))
(define ieee-scheme-sym (string->canonical-symbol "IEEE-SCHEME"))
(define r4rs-scheme-sym (string->canonical-symbol "R4RS-SCHEME"))
(define multilisp-sym (string->canonical-symbol "MULTILISP"))
(define lambda-lift-sym (string->canonical-symbol "LAMBDA-LIFT"))
(define block-sym (string->canonical-symbol "BLOCK"))
(define separate-sym (string->canonical-symbol "SEPARATE"))
(define standard-bindings-sym (string->canonical-symbol "STANDARD-BINDINGS"))
(define extended-bindings-sym (string->canonical-symbol "EXTENDED-BINDINGS"))
(define safe-sym (string->canonical-symbol "SAFE"))
(define interrupts-enabled-sym (string->canonical-symbol "INTERRUPTS-ENABLED"))
(define-flag-decl ieee-scheme-sym 'dialect)
(define-flag-decl r4rs-scheme-sym 'dialect)
(define-flag-decl multilisp-sym 'dialect)
(define-boolean-decl lambda-lift-sym)
(define-flag-decl block-sym 'compilation-strategy)
(define-flag-decl separate-sym 'compilation-strategy)
(define-namable-boolean-decl standard-bindings-sym)
(define-namable-boolean-decl extended-bindings-sym)
(define-boolean-decl safe-sym)
(define-boolean-decl interrupts-enabled-sym)
(define (scheme-dialect decl)
(declaration-value 'dialect #f ieee-scheme-sym decl))
(define (lambda-lift? decl) (declaration-value lambda-lift-sym #f #t decl))
(define (compilation-strategy decl)
(declaration-value 'compilation-strategy #f separate-sym decl))
(define (standard-binding? name decl)
(declaration-value standard-bindings-sym name #f decl))
(define (extended-binding? name decl)
(declaration-value extended-bindings-sym name #f decl))
(define (add-extended-bindings decl)
(add-decl (list extended-bindings-sym #t) decl))
(define (intrs-enabled? decl)
(declaration-value interrupts-enabled-sym #f #t decl))
(define (add-not-interrupts-enabled decl)
(add-decl (list interrupts-enabled-sym #f) decl))
(define (safe? decl) (declaration-value safe-sym #f #f decl))
(define (add-not-safe decl) (add-decl (list safe-sym #f) decl))
(define (dialect-specific-keywords dialect)
(cond ((eq? dialect ieee-scheme-sym) ieee-scheme-specific-keywords)
((eq? dialect r4rs-scheme-sym) r4rs-scheme-specific-keywords)
((eq? dialect multilisp-sym) multilisp-specific-keywords)
(else
(compiler-internal-error
"dialect-specific-keywords, unknown dialect"
dialect))))
(define (dialect-specific-procedures dialect)
(cond ((eq? dialect ieee-scheme-sym) ieee-scheme-specific-procedures)
((eq? dialect r4rs-scheme-sym) r4rs-scheme-specific-procedures)
((eq? dialect multilisp-sym) multilisp-specific-procedures)
(else
(compiler-internal-error
"dialect-specific-procedures, unknown dialect"
dialect))))
(define (make-standard-procedure x)
(cons (string->canonical-symbol (car x)) (cdr x)))
(define (standard-procedure name decl)
(or (assq name (dialect-specific-procedures (scheme-dialect decl)))
(assq name common-procedures)))
(define (standard-procedure-call-pattern proc) (cdr proc))
(define ieee-scheme-specific-keywords '())
(define ieee-scheme-specific-procedures (map make-standard-procedure '()))
(define r4rs-scheme-specific-keywords (list delay-sym))
(define r4rs-scheme-specific-procedures
(map make-standard-procedure
'(("LIST-TAIL" 2)
("-" . 1)
("/" . 1)
("STRING->LIST" 1)
("LIST->STRING" 1)
("STRING-COPY" 1)
("STRING-FILL!" 2)
("VECTOR->LIST" 1)
("LIST->VECTOR" 1)
("VECTOR-FILL!" 2)
("FORCE" 1)
("WITH-INPUT-FROM-FILE" 2)
("WITH-OUTPUT-TO-FILE" 2)
("CHAR-READY?" 0 1)
("LOAD" 1)
("TRANSCRIPT-ON" 1)
("TRANSCRIPT-OFF" 0))))
(define multilisp-specific-keywords (list delay-sym future-sym))
(define multilisp-specific-procedures
(map make-standard-procedure '(("FORCE" 1) ("TOUCH" 1))))
(define common-keywords
(list quote-sym
quasiquote-sym
unquote-sym
unquote-splicing-sym
lambda-sym
if-sym
set!-sym
cond-sym
=>-sym
else-sym
and-sym
or-sym
case-sym
let-sym
let*-sym
letrec-sym
begin-sym
do-sym
define-sym
**define-macro-sym
**declare-sym
**include-sym))
(define common-procedures
(map make-standard-procedure
'(("NOT" 1)
("BOOLEAN?" 1)
("EQV?" 2)
("EQ?" 2)
("EQUAL?" 2)
("PAIR?" 1)
("CONS" 2)
("CAR" 1)
("CDR" 1)
("SET-CAR!" 2)
("SET-CDR!" 2)
("CAAR" 1)
("CADR" 1)
("CDAR" 1)
("CDDR" 1)
("CAAAR" 1)
("CAADR" 1)
("CADAR" 1)
("CADDR" 1)
("CDAAR" 1)
("CDADR" 1)
("CDDAR" 1)
("CDDDR" 1)
("CAAAAR" 1)
("CAAADR" 1)
("CAADAR" 1)
("CAADDR" 1)
("CADAAR" 1)
("CADADR" 1)
("CADDAR" 1)
("CADDDR" 1)
("CDAAAR" 1)
("CDAADR" 1)
("CDADAR" 1)
("CDADDR" 1)
("CDDAAR" 1)
("CDDADR" 1)
("CDDDAR" 1)
("CDDDDR" 1)
("NULL?" 1)
("LIST?" 1)
("LIST" . 0)
("LENGTH" 1)
("APPEND" . 0)
("REVERSE" 1)
("LIST-REF" 2)
("MEMQ" 2)
("MEMV" 2)
("MEMBER" 2)
("ASSQ" 2)
("ASSV" 2)
("ASSOC" 2)
("SYMBOL?" 1)
("SYMBOL->STRING" 1)
("STRING->SYMBOL" 1)
("NUMBER?" 1)
("COMPLEX?" 1)
("REAL?" 1)
("RATIONAL?" 1)
("INTEGER?" 1)
("EXACT?" 1)
("INEXACT?" 1)
("=" . 2)
("<" . 2)
(">" . 2)
("<=" . 2)
(">=" . 2)
("ZERO?" 1)
("POSITIVE?" 1)
("NEGATIVE?" 1)
("ODD?" 1)
("EVEN?" 1)
("MAX" . 1)
("MIN" . 1)
("+" . 0)
("*" . 0)
("-" 1 2)
("/" 1 2)
("ABS" 1)
("QUOTIENT" 2)
("REMAINDER" 2)
("MODULO" 2)
("GCD" . 0)
("LCM" . 0)
("NUMERATOR" 1)
("DENOMINATOR" 1)
("FLOOR" 1)
("CEILING" 1)
("TRUNCATE" 1)
("ROUND" 1)
("RATIONALIZE" 2)
("EXP" 1)
("LOG" 1)
("SIN" 1)
("COS" 1)
("TAN" 1)
("ASIN" 1)
("ACOS" 1)
("ATAN" 1 2)
("SQRT" 1)
("EXPT" 2)
("MAKE-RECTANGULAR" 2)
("MAKE-POLAR" 2)
("REAL-PART" 1)
("IMAG-PART" 1)
("MAGNITUDE" 1)
("ANGLE" 1)
("EXACT->INEXACT" 1)
("INEXACT->EXACT" 1)
("NUMBER->STRING" 1 2)
("STRING->NUMBER" 1 2)
("CHAR?" 1)
("CHAR=?" 2)
("CHAR<?" 2)
("CHAR>?" 2)
("CHAR<=?" 2)
("CHAR>=?" 2)
("CHAR-CI=?" 2)
("CHAR-CI<?" 2)
("CHAR-CI>?" 2)
("CHAR-CI<=?" 2)
("CHAR-CI>=?" 2)
("CHAR-ALPHABETIC?" 1)
("CHAR-NUMERIC?" 1)
("CHAR-WHITESPACE?" 1)
("CHAR-UPPER-CASE?" 1)
("CHAR-LOWER-CASE?" 1)
("CHAR->INTEGER" 1)
("INTEGER->CHAR" 1)
("CHAR-UPCASE" 1)
("CHAR-DOWNCASE" 1)
("STRING?" 1)
("MAKE-STRING" 1 2)
("STRING" . 0)
("STRING-LENGTH" 1)
("STRING-REF" 2)
("STRING-SET!" 3)
("STRING=?" 2)
("STRING<?" 2)
("STRING>?" 2)
("STRING<=?" 2)
("STRING>=?" 2)
("STRING-CI=?" 2)
("STRING-CI<?" 2)
("STRING-CI>?" 2)
("STRING-CI<=?" 2)
("STRING-CI>=?" 2)
("SUBSTRING" 3)
("STRING-APPEND" . 0)
("VECTOR?" 1)
("MAKE-VECTOR" 1 2)
("VECTOR" . 0)
("VECTOR-LENGTH" 1)
("VECTOR-REF" 2)
("VECTOR-SET!" 3)
("PROCEDURE?" 1)
("APPLY" . 2)
("MAP" . 2)
("FOR-EACH" . 2)
("CALL-WITH-CURRENT-CONTINUATION" 1)
("CALL-WITH-INPUT-FILE" 2)
("CALL-WITH-OUTPUT-FILE" 2)
("INPUT-PORT?" 1)
("OUTPUT-PORT?" 1)
("CURRENT-INPUT-PORT" 0)
("CURRENT-OUTPUT-PORT" 0)
("OPEN-INPUT-FILE" 1)
("OPEN-OUTPUT-FILE" 1)
("CLOSE-INPUT-PORT" 1)
("CLOSE-OUTPUT-PORT" 1)
("EOF-OBJECT?" 1)
("READ" 0 1)
("READ-CHAR" 0 1)
("PEEK-CHAR" 0 1)
("WRITE" 1 2)
("DISPLAY" 1 2)
("NEWLINE" 0 1)
("WRITE-CHAR" 1 2))))
(define (parse-program program env module-name proc)
(define (parse-prog program env lst proc)
(if (null? program)
(proc (reverse lst) env)
(let ((source (car program)))
(cond ((macro-expr? source env)
(parse-prog
(cons (macro-expand source env) (cdr program))
env
lst
proc))
((begin-defs-expr? source)
(parse-prog
(append (begin-defs-body source) (cdr program))
env
lst
proc))
((include-expr? source)
(if *ptree-port* (display " " *ptree-port*))
(let ((x (file->sources*
(include-filename source)
*ptree-port*
(source-locat source))))
(if *ptree-port* (newline *ptree-port*))
(parse-prog (append x (cdr program)) env lst proc)))
((define-macro-expr? source env)
(if *ptree-port*
(begin
(display " \"macro\"" *ptree-port*)
(newline *ptree-port*)))
(parse-prog (cdr program) (add-macro source env) lst proc))
((declare-expr? source)
(if *ptree-port*
(begin
(display " \"decl\"" *ptree-port*)
(newline *ptree-port*)))
(parse-prog
(cdr program)
(add-declarations source env)
lst
proc))
((define-expr? source env)
(let* ((var** (definition-variable source))
(var* (source-code var**))
(var (env-lookup-var env var* var**)))
(if *ptree-port*
(begin
(display " " *ptree-port*)
(display (var-name var) *ptree-port*)
(newline *ptree-port*)))
(let ((node (pt (definition-value source) env 'true)))
(set-prc-names! (list var) (list node))
(parse-prog
(cdr program)
env
(cons (cons (new-def source
(env-declarations env)
var
node)
env)
lst)
proc))))
((c-declaration-expr? source)
(if *ptree-port*
(begin
(display " \"c-decl\"" *ptree-port*)
(newline *ptree-port*)))
(add-c-declaration (source-code (cadr (source-code source))))
(parse-prog (cdr program) env lst proc))
((c-init-expr? source)
(if *ptree-port*
(begin
(display " \"c-init\"" *ptree-port*)
(newline *ptree-port*)))
(add-c-init (source-code (cadr (source-code source))))
(parse-prog (cdr program) env lst proc))
(else
(if *ptree-port*
(begin
(display " \"expr\"" *ptree-port*)
(newline *ptree-port*)))
(parse-prog
(cdr program)
env
(cons (cons (pt source env 'true) env) lst)
proc))))))
(if *ptree-port*
(begin (display "Parsing:" *ptree-port*) (newline *ptree-port*)))
(c-interface-begin module-name)
(parse-prog
program
env
'()
(lambda (lst env)
(if *ptree-port* (newline *ptree-port*))
(proc lst env (c-interface-end)))))
(define (c-interface-begin module-name)
(set! c-interface-module-name module-name)
(set! c-interface-proc-count 0)
(set! c-interface-decls '())
(set! c-interface-procs '())
(set! c-interface-inits '())
#f)
(define (c-interface-end)
(let ((i (make-c-intf
(reverse c-interface-decls)
(reverse c-interface-procs)
(reverse c-interface-inits))))
(set! c-interface-module-name #f)
(set! c-interface-proc-count #f)
(set! c-interface-decls #f)
(set! c-interface-procs #f)
(set! c-interface-inits #f)
i))
(define c-interface-module-name #f)
(define c-interface-proc-count #f)
(define c-interface-decls #f)
(define c-interface-procs #f)
(define c-interface-inits #f)
(define (make-c-intf decls procs inits) (vector decls procs inits))
(define (c-intf-decls c-intf) (vector-ref c-intf 0))
(define (c-intf-decls-set! c-intf x) (vector-set! c-intf 0 x))
(define (c-intf-procs c-intf) (vector-ref c-intf 1))
(define (c-intf-procs-set! c-intf x) (vector-set! c-intf 1 x))
(define (c-intf-inits c-intf) (vector-ref c-intf 2))
(define (c-intf-inits-set! c-intf x) (vector-set! c-intf 2 x))
(define (c-declaration-expr? source)
(and (mymatch **c-declaration-sym 1 source)
(let ((code (source-code source)))
(or (string? (source-code (cadr code)))
(pt-syntax-error
source
"Argument to '##c-declaration' must be a string")))))
(define (c-init-expr? source)
(and (mymatch **c-init-sym 1 source)
(let ((code (source-code source)))
(or (string? (source-code (cadr code)))
(pt-syntax-error
source
"Argument to '##c-init' must be a string")))))
(define (c-procedure-expr? source)
(and (mymatch **c-procedure-sym 3 source)
(let ((code (source-code source)))
(if (not (string? (source-code (cadddr code))))
(pt-syntax-error
source
"Last argument to '##c-procedure' must be a string")
(check-arg-and-result-types source (cadr code) (caddr code))))))
(define scheme-to-c-notation
(list (list void-sym "VOID" "void")
(list char-sym "CHAR" "char")
(list signed-char-sym "SCHAR" "signed char")
(list unsigned-char-sym "UCHAR" "unsigned char")
(list short-sym "SHORT" "short")
(list unsigned-short-sym "USHORT" "unsigned short")
(list int-sym "INT" "int")
(list unsigned-int-sym "UINT" "unsigned int")
(list long-sym "LONG" "long")
(list unsigned-long-sym "ULONG" "unsigned long")
(list float-sym "FLOAT" "float")
(list double-sym "DOUBLE" "double")
(list pointer-sym "POINTER" "void*")
(list boolean-sym "BOOLEAN" "int")
(list string-sym "STRING" "char*")
(list scheme-object-sym "SCMOBJ" "long")))
(define (convert-type typ) (if (assq typ scheme-to-c-notation) typ #f))
(define (check-arg-and-result-types source arg-typs-source res-typ-source)
(let ((arg-typs (source-code arg-typs-source))
(res-typ (source-code res-typ-source)))
(let ((res-type (convert-type res-typ)))
(if (not res-type)
(pt-syntax-error res-typ-source "Invalid result type")
(if (not (proper-length arg-typs))
(pt-syntax-error
arg-typs-source
"Ill-terminated argument type list")
(let loop ((lst arg-typs))
(if (pair? lst)
(let* ((arg-typ (source-code (car lst)))
(arg-type (convert-type arg-typ)))
(if (or (not arg-type) (eq? arg-type void-sym))
(pt-syntax-error (car lst) "Invalid argument type")
(loop (cdr lst))))
#t)))))))
(define (add-c-declaration declaration-string)
(set! c-interface-decls (cons declaration-string c-interface-decls))
#f)
(define (add-c-init initialization-code-string)
(set! c-interface-inits (cons initialization-code-string c-interface-inits))
#f)
(define (add-c-proc scheme-name c-name arity def)
(set! c-interface-procs
(cons (vector scheme-name c-name arity def) c-interface-procs))
#f)
(define (pt-c-procedure source env use)
(let* ((code (source-code source))
(name (build-c-procedure
(map source-code (source-code (cadr code)))
(source-code (caddr code))
(source-code (cadddr code))))
(decl (env-declarations env)))
(new-ref source decl (env-lookup-global-var env (string->symbol name)))))
(define (build-c-procedure argument-types result-type proc-name-or-code)
(define proc-name?
(let loop ((i (- (string-length proc-name-or-code) 1)))
(if (>= i 0)
(let ((c (string-ref proc-name-or-code i)))
(if (or (char-alphabetic? c) (char=? c #\_)) (loop (- i 1)) #f))
#t)))
(define nl (string #\newline))
(define undefined-value "UND")
(define scheme-arg-prefix "ARG")
(define scheme-result-name "RESULT")
(define c-arg-prefix "arg")
(define c-result-name "result")
(define scheme-to-c-prefix "SCMOBJ_TO_")
(define c-to-scheme-suffix "_TO_SCMOBJ")
(define (c-type-name typ) (cadr (assq typ scheme-to-c-notation)))
(define (c-type-decl typ) (caddr (assq typ scheme-to-c-notation)))
(define (listify strings)
(if (null? strings)
""
(string-append
(car strings)
(apply string-append
(map (lambda (s) (string-append "," s)) (cdr strings))))))
(define (scheme-arg-var t)
(string-append c-id-prefix scheme-arg-prefix (number->string (cdr t))))
(define (c-arg-var t)
(string-append c-id-prefix c-arg-prefix (number->string (cdr t))))
(define (make-c-procedure arg-types res-type)
(define (make-arg-decl)
(apply string-append
(map (lambda (t)
(string-append
(c-type-decl (car t))
" "
(c-arg-var t)
";"
nl))
arg-types)))
(define (make-conversions)
(if (not (null? arg-types))
(let loop ((lst arg-types) (str (string-append "if (" nl)))
(if (null? lst)
(string-append str " )" nl)
(let ((t (car lst)) (rest (cdr lst)))
(loop rest
(string-append
str
" "
c-id-prefix
scheme-to-c-prefix
(c-type-name (car t))
"("
(scheme-arg-var t)
","
(c-arg-var t)
")"
(if (null? rest) "" " &&")
nl)))))
""))
(define (make-body)
(if proc-name?
(let* ((param-list (listify (map c-arg-var arg-types)))
(call (string-append proc-name-or-code "(" param-list ")")))
(if (eq? res-type void-sym)
(string-append
"{"
nl
call
";"
nl
c-id-prefix
scheme-result-name
" = "
c-id-prefix
undefined-value
";"
nl
"}"
nl)
(string-append
c-id-prefix
(c-type-name res-type)
c-to-scheme-suffix
"("
call
","
c-id-prefix
scheme-result-name
");"
nl)))
(if (eq? res-type void-sym)
(string-append
"{"
nl
proc-name-or-code
nl
c-id-prefix
scheme-result-name
" = "
c-id-prefix
undefined-value
";"
nl
"}"
nl)
(string-append
"{"
nl
proc-name-or-code
nl
c-id-prefix
(c-type-name res-type)
c-to-scheme-suffix
"("
c-id-prefix
c-result-name
","
c-id-prefix
scheme-result-name
");"
nl
"}"
nl))))
(let* ((index (number->string c-interface-proc-count))
(scheme-name (string-append "#!" c-interface-module-name "#" index))
(c-name (string-append c-id-prefix (scheme-id->c-id scheme-name)))
(arity (length argument-types))
(def (string-append
(if (or proc-name? (eq? res-type void-sym))
""
(string-append
(c-type-decl res-type)
" "
c-id-prefix
c-result-name
";"
nl))
(make-arg-decl)
(make-conversions)
(make-body))))
(set! c-interface-proc-count (+ c-interface-proc-count 1))
(add-c-proc scheme-name c-name arity def)
scheme-name))
(let loop ((i 1) (lst1 argument-types) (lst2 '()))
(if (pair? lst1)
(loop (+ i 1) (cdr lst1) (cons (cons (car lst1) i) lst2))
(make-c-procedure (reverse lst2) result-type))))
(define (scheme-id->c-id s)
(define (hex->char i) (string-ref "0123456789abcdef" i))
(let loop ((i (- (string-length s) 1)) (l '()))
(if (>= i 0)
(let ((c (string-ref s i)))
(cond ((or (char-alphabetic? c) (char-numeric? c))
(loop (- i 1) (cons c l)))
((char=? c #\_) (loop (- i 1) (cons c (cons c l))))
(else
(let ((n (character-encoding c)))
(loop (- i 1)
(cons #\_
(cons (hex->char (quotient n 16))
(cons (hex->char (modulo n 16)) l))))))))
(lst->string l))))
(define (pt-syntax-error source msg . args)
(apply compiler-user-error
(cons (source-locat source)
(cons (string-append "Syntax error -- " msg) args))))
(define (pt source env use)
(cond ((macro-expr? source env) (pt (macro-expand source env) env use))
((self-eval-expr? source) (pt-self-eval source env use))
((quote-expr? source) (pt-quote source env use))
((quasiquote-expr? source) (pt-quasiquote source env use))
((unquote-expr? source)
(pt-syntax-error source "Ill-placed 'unquote'"))
((unquote-splicing-expr? source)
(pt-syntax-error source "Ill-placed 'unquote-splicing'"))
((var-expr? source env) (pt-var source env use))
((set!-expr? source env) (pt-set! source env use))
((lambda-expr? source env) (pt-lambda source env use))
((if-expr? source) (pt-if source env use))
((cond-expr? source) (pt-cond source env use))
((and-expr? source) (pt-and source env use))
((or-expr? source) (pt-or source env use))
((case-expr? source) (pt-case source env use))
((let-expr? source env) (pt-let source env use))
((let*-expr? source env) (pt-let* source env use))
((letrec-expr? source env) (pt-letrec source env use))
((begin-expr? source) (pt-begin source env use))
((do-expr? source env) (pt-do source env use))
((define-expr? source env)
(pt-syntax-error source "Ill-placed 'define'"))
((delay-expr? source env) (pt-delay source env use))
((future-expr? source env) (pt-future source env use))
((define-macro-expr? source env)
(pt-syntax-error source "Ill-placed '##define-macro'"))
((begin-defs-expr? source)
(pt-syntax-error source "Ill-placed 'begin' style definitions"))
((declare-expr? source)
(pt-syntax-error source "Ill-placed '##declare'"))
((c-declaration-expr? source)
(pt-syntax-error source "Ill-placed '##c-declaration'"))
((c-init-expr? source)
(pt-syntax-error source "Ill-placed '##c-init'"))
((c-procedure-expr? source) (pt-c-procedure source env use))
((combination-expr? source) (pt-combination source env use))
(else (compiler-internal-error "pt, unknown expression type" source))))
(define (macro-expand source env)
(let ((code (source-code source)))
(expression->source
(apply (cdr (env-lookup-macro env (source-code (car code))))
(cdr (source->expression source)))
source)))
(define (pt-self-eval source env use)
(let ((val (source->expression source)))
(if (eq? use 'none)
(new-cst source (env-declarations env) undef-object)
(new-cst source (env-declarations env) val))))
(define (pt-quote source env use)
(let ((code (source-code source)))
(if (eq? use 'none)
(new-cst source (env-declarations env) undef-object)
(new-cst source
(env-declarations env)
(source->expression (cadr code))))))
(define (pt-quasiquote source env use)
(let ((code (source-code source))) (pt-quasiquotation (cadr code) 1 env)))
(define (pt-quasiquotation form level env)
(cond ((= level 0) (pt form env 'true))
((quasiquote-expr? form)
(pt-quasiquotation-list form (source-code form) (+ level 1) env))
((unquote-expr? form)
(if (= level 1)
(pt (cadr (source-code form)) env 'true)
(pt-quasiquotation-list form (source-code form) (- level 1) env)))
((unquote-splicing-expr? form)
(if (= level 1)
(pt-syntax-error form "Ill-placed 'unquote-splicing'")
(pt-quasiquotation-list form (source-code form) (- level 1) env)))
((pair? (source-code form))
(pt-quasiquotation-list form (source-code form) level env))
((vector? (source-code form))
(vector-form
form
(pt-quasiquotation-list
form
(vector->lst (source-code form))
level
env)
env))
(else
(new-cst form (env-declarations env) (source->expression form)))))
(define (pt-quasiquotation-list form l level env)
(cond ((pair? l)
(if (and (unquote-splicing-expr? (car l)) (= level 1))
(let ((x (pt (cadr (source-code (car l))) env 'true)))
(if (null? (cdr l))
x
(append-form
(car l)
x
(pt-quasiquotation-list form (cdr l) 1 env)
env)))
(cons-form
form
(pt-quasiquotation (car l) level env)
(pt-quasiquotation-list form (cdr l) level env)
env)))
((null? l) (new-cst form (env-declarations env) '()))
(else (pt-quasiquotation l level env))))
(define (append-form source ptree1 ptree2 env)
(cond ((and (cst? ptree1) (cst? ptree2))
(new-cst source
(env-declarations env)
(append (cst-val ptree1) (cst-val ptree2))))
((and (cst? ptree2) (null? (cst-val ptree2))) ptree1)
(else
(new-call*
source
(add-not-safe (env-declarations env))
(new-ref-extended-bindings source **quasi-append-sym env)
(list ptree1 ptree2)))))
(define (cons-form source ptree1 ptree2 env)
(cond ((and (cst? ptree1) (cst? ptree2))
(new-cst source
(env-declarations env)
(cons (cst-val ptree1) (cst-val ptree2))))
((and (cst? ptree2) (null? (cst-val ptree2)))
(new-call*
source
(add-not-safe (env-declarations env))
(new-ref-extended-bindings source **quasi-list-sym env)
(list ptree1)))
(else
(new-call*
source
(add-not-safe (env-declarations env))
(new-ref-extended-bindings source **quasi-cons-sym env)
(list ptree1 ptree2)))))
(define (vector-form source ptree env)
(if (cst? ptree)
(new-cst source (env-declarations env) (lst->vector (cst-val ptree)))
(new-call*
source
(add-not-safe (env-declarations env))
(new-ref-extended-bindings source **quasi-list->vector-sym env)
(list ptree))))
(define (pt-var source env use)
(if (eq? use 'none)
(new-cst source (env-declarations env) undef-object)
(new-ref source
(env-declarations env)
(env-lookup-var env (source-code source) source))))
(define (pt-set! source env use)
(let ((code (source-code source)))
(new-set source
(env-declarations env)
(env-lookup-var env (source-code (cadr code)) (cadr code))
(pt (caddr code) env 'true))))
(define (pt-lambda source env use)
(let ((code (source-code source)))
(define (new-params parms)
(cond ((pair? parms)
(let* ((parm* (car parms))
(parm (source-code parm*))
(p* (if (pair? parm) (car parm) parm*)))
(cons (make-var (source-code p*) #t (set-empty) (set-empty) p*)
(new-params (cdr parms)))))
((null? parms) '())
(else
(list (make-var
(source-code parms)
#t
(set-empty)
(set-empty)
parms)))))
(define (min-params parms)
(let loop ((l parms) (n 0))
(if (pair? l)
(if (pair? (source-code (car l))) n (loop (cdr l) (+ n 1)))
n)))
(define (rest-param? parms)
(if (pair? parms) (rest-param? (cdr parms)) (not (null? parms))))
(define (optionals parms source body env)
(if (pair? parms)
(let* ((parm* (car parms)) (parm (source-code parm*)))
(if (and (pair? parm) (length? parm 2))
(let* ((var (car parm))
(vars (new-variables (list var)))
(decl (env-declarations env)))
(new-call*
parm*
decl
(new-prc parm*
decl
#f
1
#f
vars
(optionals
(cdr parms)
source
body
(env-frame env vars)))
(list (new-tst parm*
decl
(new-call*
parm*
decl
(new-ref-extended-bindings
parm*
**unassigned?-sym
env)
(list (new-ref parm*
decl
(env-lookup-var
env
(source-code var)
var))))
(pt (cadr parm) env 'true)
(new-ref parm*
decl
(env-lookup-var
env
(source-code var)
var))))))
(optionals (cdr parms) source body env)))
(pt-body source body env 'true)))
(if (eq? use 'none)
(new-cst source (env-declarations env) undef-object)
(let* ((parms (source->parms (cadr code))) (frame (new-params parms)))
(new-prc source
(env-declarations env)
#f
(min-params parms)
(rest-param? parms)
frame
(optionals
parms
source
(cddr code)
(env-frame env frame)))))))
(define (source->parms source)
(let ((x (source-code source))) (if (or (pair? x) (null? x)) x source)))
(define (pt-body source body env use)
(define (letrec-defines vars vals envs body env)
(cond ((null? body)
(pt-syntax-error
source
"Body must contain at least one evaluable expression"))
((macro-expr? (car body) env)
(letrec-defines
vars
vals
envs
(cons (macro-expand (car body) env) (cdr body))
env))
((begin-defs-expr? (car body))
(letrec-defines
vars
vals
envs
(append (begin-defs-body (car body)) (cdr body))
env))
((include-expr? (car body))
(if *ptree-port* (display " " *ptree-port*))
(let ((x (file->sources*
(include-filename (car body))
*ptree-port*
(source-locat (car body)))))
(if *ptree-port* (newline *ptree-port*))
(letrec-defines vars vals envs (append x (cdr body)) env)))
((define-expr? (car body) env)
(let* ((var** (definition-variable (car body)))
(var* (source-code var**))
(var (env-define-var env var* var**)))
(letrec-defines
(cons var vars)
(cons (definition-value (car body)) vals)
(cons env envs)
(cdr body)
env)))
((declare-expr? (car body))
(letrec-defines
vars
vals
envs
(cdr body)
(add-declarations (car body) env)))
((define-macro-expr? (car body) env)
(letrec-defines
vars
vals
envs
(cdr body)
(add-macro (car body) env)))
((c-declaration-expr? (car body))
(add-c-declaration (source-code (cadr (source-code (car body)))))
(letrec-defines vars vals envs (cdr body) env))
((c-init-expr? (car body))
(add-c-init (source-code (cadr (source-code (car body)))))
(letrec-defines vars vals envs (cdr body) env))
((null? vars) (pt-sequence source body env use))
(else
(let ((vars* (reverse vars)))
(let loop ((vals* '()) (l1 vals) (l2 envs))
(if (not (null? l1))
(loop (cons (pt (car l1) (car l2) 'true) vals*)
(cdr l1)
(cdr l2))
(pt-recursive-let source vars* vals* body env use)))))))
(letrec-defines '() '() '() body (env-frame env '())))
(define (pt-sequence source seq env use)
(if (length? seq 1)
(pt (car seq) env use)
(new-seq source
(env-declarations env)
(pt (car seq) env 'none)
(pt-sequence source (cdr seq) env use))))
(define (pt-if source env use)
(let ((code (source-code source)))
(new-tst source
(env-declarations env)
(pt (cadr code) env 'pred)
(pt (caddr code) env use)
(if (length? code 3)
(new-cst source (env-declarations env) undef-object)
(pt (cadddr code) env use)))))
(define (pt-cond source env use)
(define (pt-clauses clauses)
(if (length? clauses 0)
(new-cst source (env-declarations env) undef-object)
(let* ((clause* (car clauses)) (clause (source-code clause*)))
(cond ((eq? (source-code (car clause)) else-sym)
(pt-sequence clause* (cdr clause) env use))
((length? clause 1)
(new-disj
clause*
(env-declarations env)
(pt (car clause) env (if (eq? use 'true) 'true 'pred))
(pt-clauses (cdr clauses))))
((eq? (source-code (cadr clause)) =>-sym)
(new-disj-call
clause*
(env-declarations env)
(pt (car clause) env 'true)
(pt (caddr clause) env 'true)
(pt-clauses (cdr clauses))))
(else
(new-tst clause*
(env-declarations env)
(pt (car clause) env 'pred)
(pt-sequence clause* (cdr clause) env use)
(pt-clauses (cdr clauses))))))))
(pt-clauses (cdr (source-code source))))
(define (pt-and source env use)
(define (pt-exprs exprs)
(cond ((length? exprs 0) (new-cst source (env-declarations env) #t))
((length? exprs 1) (pt (car exprs) env use))
(else
(new-conj
(car exprs)
(env-declarations env)
(pt (car exprs) env (if (eq? use 'true) 'true 'pred))
(pt-exprs (cdr exprs))))))
(pt-exprs (cdr (source-code source))))
(define (pt-or source env use)
(define (pt-exprs exprs)
(cond ((length? exprs 0)
(new-cst source (env-declarations env) false-object))
((length? exprs 1) (pt (car exprs) env use))
(else
(new-disj
(car exprs)
(env-declarations env)
(pt (car exprs) env (if (eq? use 'true) 'true 'pred))
(pt-exprs (cdr exprs))))))
(pt-exprs (cdr (source-code source))))
(define (pt-case source env use)
(let ((code (source-code source)) (temp (new-temps source '(temp))))
(define (pt-clauses clauses)
(if (length? clauses 0)
(new-cst source (env-declarations env) undef-object)
(let* ((clause* (car clauses)) (clause (source-code clause*)))
(if (eq? (source-code (car clause)) else-sym)
(pt-sequence clause* (cdr clause) env use)
(new-tst clause*
(env-declarations env)
(new-call*
clause*
(add-not-safe (env-declarations env))
(new-ref-extended-bindings
clause*
**case-memv-sym
env)
(list (new-ref clause*
(env-declarations env)
(car temp))
(new-cst (car clause)
(env-declarations env)
(source->expression (car clause)))))
(pt-sequence clause* (cdr clause) env use)
(pt-clauses (cdr clauses)))))))
(new-call*
source
(env-declarations env)
(new-prc source
(env-declarations env)
#f
1
#f
temp
(pt-clauses (cddr code)))
(list (pt (cadr code) env 'true)))))
(define (pt-let source env use)
(let ((code (source-code source)))
(if (bindable-var? (cadr code) env)
(let* ((self (new-variables (list (cadr code))))
(bindings (map source-code (source-code (caddr code))))
(vars (new-variables (map car bindings)))
(vals (map (lambda (x) (pt (cadr x) env 'true)) bindings))
(env (env-frame (env-frame env vars) self))
(self-proc
(list (new-prc source
(env-declarations env)
#f
(length vars)
#f
vars
(pt-body source (cdddr code) env use)))))
(set-prc-names! self self-proc)
(set-prc-names! vars vals)
(new-call*
source
(env-declarations env)
(new-prc source
(env-declarations env)
#f
1
#f
self
(new-call*
source
(env-declarations env)
(new-ref source (env-declarations env) (car self))
vals))
self-proc))
(if (null? (source-code (cadr code)))
(pt-body source (cddr code) env use)
(let* ((bindings (map source-code (source-code (cadr code))))
(vars (new-variables (map car bindings)))
(vals (map (lambda (x) (pt (cadr x) env 'true)) bindings))
(env (env-frame env vars)))
(set-prc-names! vars vals)
(new-call*
source
(env-declarations env)
(new-prc source
(env-declarations env)
#f
(length vars)
#f
vars
(pt-body source (cddr code) env use))
vals))))))
(define (pt-let* source env use)
(let ((code (source-code source)))
(define (pt-bindings bindings env use)
(if (null? bindings)
(pt-body source (cddr code) env use)
(let* ((binding* (car bindings))
(binding (source-code binding*))
(vars (new-variables (list (car binding))))
(vals (list (pt (cadr binding) env 'true)))
(env (env-frame env vars)))
(set-prc-names! vars vals)
(new-call*
binding*
(env-declarations env)
(new-prc binding*
(env-declarations env)
#f
1
#f
vars
(pt-bindings (cdr bindings) env use))
vals))))
(pt-bindings (source-code (cadr code)) env use)))
(define (pt-letrec source env use)
(let* ((code (source-code source))
(bindings (map source-code (source-code (cadr code))))
(vars* (new-variables (map car bindings)))
(env* (env-frame env vars*)))
(pt-recursive-let
source
vars*
(map (lambda (x) (pt (cadr x) env* 'true)) bindings)
(cddr code)
env*
use)))
(define (pt-recursive-let source vars vals body env use)
(define (dependency-graph vars vals)
(define (dgraph vars* vals*)
(if (null? vars*)
(set-empty)
(let ((var (car vars*)) (val (car vals*)))
(set-adjoin
(dgraph (cdr vars*) (cdr vals*))
(make-gnode
var
(set-intersection (list->set vars) (free-variables val)))))))
(dgraph vars vals))
(define (val-of var)
(list-ref vals (- (length vars) (length (memq var vars)))))
(define (bind-in-order order)
(if (null? order)
(pt-body source body env use)
(let* ((vars-set (car order)) (vars (set->list vars-set)))
(let loop1 ((l (reverse vars))
(vars-b '())
(vals-b '())
(vars-a '()))
(if (not (null? l))
(let* ((var (car l)) (val (val-of var)))
(if (or (prc? val)
(set-empty?
(set-intersection (free-variables val) vars-set)))
(loop1 (cdr l)
(cons var vars-b)
(cons val vals-b)
vars-a)
(loop1 (cdr l) vars-b vals-b (cons var vars-a))))
(let* ((result1 (let loop2 ((l vars-a))
(if (not (null? l))
(let* ((var (car l)) (val (val-of var)))
(new-seq source
(env-declarations env)
(new-set source
(env-declarations
env)
var
val)
(loop2 (cdr l))))
(bind-in-order (cdr order)))))
(result2 (if (null? vars-b)
result1
(new-call*
source
(env-declarations env)
(new-prc source
(env-declarations env)
#f
(length vars-b)
#f
vars-b
result1)
vals-b)))
(result3 (if (null? vars-a)
result2
(new-call*
source
(env-declarations env)
(new-prc source
(env-declarations env)
#f
(length vars-a)
#f
vars-a
result2)
(map (lambda (var)
(new-cst source
(env-declarations env)
undef-object))
vars-a)))))
result3))))))
(set-prc-names! vars vals)
(bind-in-order
(topological-sort (transitive-closure (dependency-graph vars vals)))))
(define (pt-begin source env use)
(pt-sequence source (cdr (source-code source)) env use))
(define (pt-do source env use)
(let* ((code (source-code source))
(loop (new-temps source '(loop)))
(bindings (map source-code (source-code (cadr code))))
(vars (new-variables (map car bindings)))
(init (map (lambda (x) (pt (cadr x) env 'true)) bindings))
(env (env-frame env vars))
(step (map (lambda (x)
(pt (if (length? x 2) (car x) (caddr x)) env 'true))
bindings))
(exit (source-code (caddr code))))
(set-prc-names! vars init)
(new-call*
source
(env-declarations env)
(new-prc source
(env-declarations env)
#f
1
#f
loop
(new-call*
source
(env-declarations env)
(new-ref source (env-declarations env) (car loop))
init))
(list (new-prc source
(env-declarations env)
#f
(length vars)
#f
vars
(new-tst source
(env-declarations env)
(pt (car exit) env 'pred)
(if (length? exit 1)
(new-cst (caddr code)
(env-declarations env)
undef-object)
(pt-sequence (caddr code) (cdr exit) env use))
(if (length? code 3)
(new-call*
source
(env-declarations env)
(new-ref source
(env-declarations env)
(car loop))
step)
(new-seq source
(env-declarations env)
(pt-sequence
source
(cdddr code)
env
'none)
(new-call*
source
(env-declarations env)
(new-ref source
(env-declarations env)
(car loop))
step)))))))))
(define (pt-combination source env use)
(let* ((code (source-code source))
(oper (pt (car code) env 'true))
(decl (node-decl oper)))
(new-call*
source
(env-declarations env)
oper
(map (lambda (x) (pt x env 'true)) (cdr code)))))
(define (pt-delay source env use)
(let ((code (source-code source)))
(new-call*
source
(add-not-safe (env-declarations env))
(new-ref-extended-bindings source **make-placeholder-sym env)
(list (new-prc source
(env-declarations env)
#f
0
#f
'()
(pt (cadr code) env 'true))))))
(define (pt-future source env use)
(let ((decl (env-declarations env)) (code (source-code source)))
(new-fut source decl (pt (cadr code) env 'true))))
(define (self-eval-expr? source)
(let ((code (source-code source)))
(and (not (pair? code)) (not (symbol-object? code)))))
(define (quote-expr? source) (mymatch quote-sym 1 source))
(define (quasiquote-expr? source) (mymatch quasiquote-sym 1 source))
(define (unquote-expr? source) (mymatch unquote-sym 1 source))
(define (unquote-splicing-expr? source)
(mymatch unquote-splicing-sym 1 source))
(define (var-expr? source env)
(let ((code (source-code source)))
(and (symbol-object? code)
(not-keyword source env code)
(not-macro source env code))))
(define (not-macro source env name)
(if (env-lookup-macro env name)
(pt-syntax-error source "Macro name can't be used as a variable:" name)
#t))
(define (bindable-var? source env)
(let ((code (source-code source)))
(and (symbol-object? code) (not-keyword source env code))))
(define (not-keyword source env name)
(if (or (memq name common-keywords)
(memq name
(dialect-specific-keywords
(scheme-dialect (env-declarations env)))))
(pt-syntax-error
source
"Predefined keyword can't be used as a variable:"
name)
#t))
(define (set!-expr? source env)
(and (mymatch set!-sym 2 source)
(var-expr? (cadr (source-code source)) env)))
(define (lambda-expr? source env)
(and (mymatch lambda-sym -2 source)
(proper-parms? (source->parms (cadr (source-code source))) env)))
(define (if-expr? source)
(and (mymatch if-sym -2 source)
(or (<= (length (source-code source)) 4)
(pt-syntax-error source "Ill-formed special form" if-sym))))
(define (cond-expr? source)
(and (mymatch cond-sym -1 source) (proper-clauses? source)))
(define (and-expr? source) (mymatch and-sym 0 source))
(define (or-expr? source) (mymatch or-sym 0 source))
(define (case-expr? source)
(and (mymatch case-sym -2 source) (proper-case-clauses? source)))
(define (let-expr? source env)
(and (mymatch let-sym -2 source)
(let ((code (source-code source)))
(if (bindable-var? (cadr code) env)
(and (proper-bindings? (caddr code) #t env)
(or (> (length code) 3)
(pt-syntax-error source "Ill-formed named 'let'")))
(proper-bindings? (cadr code) #t env)))))
(define (let*-expr? source env)
(and (mymatch let*-sym -2 source)
(proper-bindings? (cadr (source-code source)) #f env)))
(define (letrec-expr? source env)
(and (mymatch letrec-sym -2 source)
(proper-bindings? (cadr (source-code source)) #t env)))
(define (begin-expr? source) (mymatch begin-sym -1 source))
(define (do-expr? source env)
(and (mymatch do-sym -2 source)
(proper-do-bindings? source env)
(proper-do-exit? source)))
(define (define-expr? source env)
(and (mymatch define-sym -1 source)
(proper-definition? source env)
(let ((v (definition-variable source)))
(not-macro v env (source-code v)))))
(define (combination-expr? source)
(let ((length (proper-length (source-code source))))
(if length
(or (> length 0) (pt-syntax-error source "Ill-formed procedure call"))
(pt-syntax-error source "Ill-terminated procedure call"))))
(define (delay-expr? source env)
(and (not (eq? (scheme-dialect (env-declarations env)) ieee-scheme-sym))
(mymatch delay-sym 1 source)))
(define (future-expr? source env)
(and (eq? (scheme-dialect (env-declarations env)) multilisp-sym)
(mymatch future-sym 1 source)))
(define (macro-expr? source env)
(let ((code (source-code source)))
(and (pair? code)
(symbol-object? (source-code (car code)))
(let ((macr (env-lookup-macro env (source-code (car code)))))
(and macr
(let ((len (proper-length (cdr code))))
(if len
(let ((len* (+ len 1)) (size (car macr)))
(or (if (> size 0) (= len* size) (>= len* (- size)))
(pt-syntax-error source "Ill-formed macro form")))
(pt-syntax-error
source
"Ill-terminated macro form"))))))))
(define (define-macro-expr? source env)
(and (mymatch **define-macro-sym -1 source) (proper-definition? source env)))
(define (declare-expr? source) (mymatch **declare-sym -1 source))
(define (include-expr? source) (mymatch **include-sym 1 source))
(define (begin-defs-expr? source) (mymatch begin-sym 0 source))
(define (mymatch keyword size source)
(let ((code (source-code source)))
(and (pair? code)
(eq? (source-code (car code)) keyword)
(let ((length (proper-length (cdr code))))
(if length
(or (if (> size 0) (= length size) (>= length (- size)))
(pt-syntax-error source "Ill-formed special form" keyword))
(pt-syntax-error
source
"Ill-terminated special form"
keyword))))))
(define (proper-length l)
(define (length l n)
(cond ((pair? l) (length (cdr l) (+ n 1))) ((null? l) n) (else #f)))
(length l 0))
(define (proper-definition? source env)
(let* ((code (source-code source))
(pattern* (cadr code))
(pattern (source-code pattern*))
(body (cddr code)))
(cond ((bindable-var? pattern* env)
(cond ((length? body 0) #t)
((length? body 1) #t)
(else (pt-syntax-error source "Ill-formed definition body"))))
((pair? pattern)
(if (length? body 0)
(pt-syntax-error
source
"Body of a definition must have at least one expression"))
(if (bindable-var? (car pattern) env)
(proper-parms? (cdr pattern) env)
(pt-syntax-error
(car pattern)
"Procedure name must be an identifier")))
(else (pt-syntax-error pattern* "Ill-formed definition pattern")))))
(define (definition-variable def)
(let* ((code (source-code def)) (pattern (cadr code)))
(if (pair? (source-code pattern)) (car (source-code pattern)) pattern)))
(define (definition-value def)
(let ((code (source-code def)) (loc (source-locat def)))
(cond ((pair? (source-code (cadr code)))
(make-source
(cons (make-source lambda-sym loc)
(cons (parms->source (cdr (source-code (cadr code))) loc)
(cddr code)))
loc))
((null? (cddr code))
(make-source
(list (make-source quote-sym loc) (make-source undef-object loc))
loc))
(else (caddr code)))))
(define (parms->source parms loc)
(if (or (pair? parms) (null? parms)) (make-source parms loc) parms))
(define (proper-parms? parms env)
(define (proper-parms parms seen optional-seen)
(cond ((pair? parms)
(let* ((parm* (car parms)) (parm (source-code parm*)))
(cond ((pair? parm)
(if (eq? (scheme-dialect (env-declarations env))
multilisp-sym)
(let ((length (proper-length parm)))
(if (or (eqv? length 1) (eqv? length 2))
(let ((var (car parm)))
(if (bindable-var? var env)
(if (memq (source-code var) seen)
(pt-syntax-error
var
"Duplicate parameter in parameter list")
(proper-parms
(cdr parms)
(cons (source-code var) seen)
#t))
(pt-syntax-error
var
"Parameter must be an identifier")))
(pt-syntax-error
parm*
"Ill-formed optional parameter")))
(pt-syntax-error
parm*
"optional parameters illegal in this dialect")))
(optional-seen
(pt-syntax-error parm* "Optional parameter expected"))
((bindable-var? parm* env)
(if (memq parm seen)
(pt-syntax-error
parm*
"Duplicate parameter in parameter list"))
(proper-parms (cdr parms) (cons parm seen) #f))
(else
(pt-syntax-error
parm*
"Parameter must be an identifier")))))
((null? parms) #t)
((bindable-var? parms env)
(if (memq (source-code parms) seen)
(pt-syntax-error parms "Duplicate parameter in parameter list")
#t))
(else
(pt-syntax-error parms "Rest parameter must be an identifier"))))
(proper-parms parms '() #f))
(define (proper-clauses? source)
(define (proper-clauses clauses)
(or (null? clauses)
(let* ((clause* (car clauses))
(clause (source-code clause*))
(length (proper-length clause)))
(if length
(if (>= length 1)
(if (eq? (source-code (car clause)) else-sym)
(cond ((= length 1)
(pt-syntax-error
clause*
"Else clause must have a body"))
((not (null? (cdr clauses)))
(pt-syntax-error
clause*
"Else clause must be the last clause"))
(else (proper-clauses (cdr clauses))))
(if (and (>= length 2)
(eq? (source-code (cadr clause)) =>-sym)
(not (= length 3)))
(pt-syntax-error
(cadr clause)
"'=>' must be followed by a single expression")
(proper-clauses (cdr clauses))))
(pt-syntax-error clause* "Ill-formed 'cond' clause"))
(pt-syntax-error clause* "Ill-terminated 'cond' clause")))))
(proper-clauses (cdr (source-code source))))
(define (proper-case-clauses? source)
(define (proper-case-clauses clauses)
(or (null? clauses)
(let* ((clause* (car clauses))
(clause (source-code clause*))
(length (proper-length clause)))
(if length
(if (>= length 2)
(if (eq? (source-code (car clause)) else-sym)
(if (not (null? (cdr clauses)))
(pt-syntax-error
clause*
"Else clause must be the last clause")
(proper-case-clauses (cdr clauses)))
(begin
(proper-selector-list? (car clause))
(proper-case-clauses (cdr clauses))))
(pt-syntax-error
clause*
"A 'case' clause must have a selector list and a body"))
(pt-syntax-error clause* "Ill-terminated 'case' clause")))))
(proper-case-clauses (cddr (source-code source))))
(define (proper-selector-list? source)
(let* ((code (source-code source)) (length (proper-length code)))
(if length
(or (>= length 1)
(pt-syntax-error
source
"Selector list must contain at least one element"))
(pt-syntax-error source "Ill-terminated selector list"))))
(define (proper-bindings? bindings check-dupl? env)
(define (proper-bindings l seen)
(cond ((pair? l)
(let* ((binding* (car l)) (binding (source-code binding*)))
(if (eqv? (proper-length binding) 2)
(let ((var (car binding)))
(if (bindable-var? var env)
(if (and check-dupl? (memq (source-code var) seen))
(pt-syntax-error
var
"Duplicate variable in bindings")
(proper-bindings
(cdr l)
(cons (source-code var) seen)))
(pt-syntax-error
var
"Binding variable must be an identifier")))
(pt-syntax-error binding* "Ill-formed binding"))))
((null? l) #t)
(else (pt-syntax-error bindings "Ill-terminated binding list"))))
(proper-bindings (source-code bindings) '()))
(define (proper-do-bindings? source env)
(let ((bindings (cadr (source-code source))))
(define (proper-bindings l seen)
(cond ((pair? l)
(let* ((binding* (car l))
(binding (source-code binding*))
(length (proper-length binding)))
(if (or (eqv? length 2) (eqv? length 3))
(let ((var (car binding)))
(if (bindable-var? var env)
(if (memq (source-code var) seen)
(pt-syntax-error
var
"Duplicate variable in bindings")
(proper-bindings
(cdr l)
(cons (source-code var) seen)))
(pt-syntax-error
var
"Binding variable must be an identifier")))
(pt-syntax-error binding* "Ill-formed binding"))))
((null? l) #t)
(else (pt-syntax-error bindings "Ill-terminated binding list"))))
(proper-bindings (source-code bindings) '())))
(define (proper-do-exit? source)
(let* ((code (source-code (caddr (source-code source))))
(length (proper-length code)))
(if length
(or (> length 0) (pt-syntax-error source "Ill-formed exit clause"))
(pt-syntax-error source "Ill-terminated exit clause"))))
(define (include-filename source) (source-code (cadr (source-code source))))
(define (begin-defs-body source) (cdr (source-code source)))
(define (length? l n)
(cond ((null? l) (= n 0)) ((> n 0) (length? (cdr l) (- n 1))) (else #f)))
(define (transform-declaration source)
(let ((code (source-code source)))
(if (not (pair? code))
(pt-syntax-error source "Ill-formed declaration")
(let* ((pos (not (eq? (source-code (car code)) not-sym)))
(x (if pos code (cdr code))))
(if (not (pair? x))
(pt-syntax-error source "Ill-formed declaration")
(let* ((id* (car x)) (id (source-code id*)))
(cond ((not (symbol-object? id))
(pt-syntax-error
id*
"Declaration name must be an identifier"))
((assq id flag-declarations)
(cond ((not pos)
(pt-syntax-error
id*
"Declaration can't be negated"))
((null? (cdr x))
(flag-decl
source
(cdr (assq id flag-declarations))
id))
(else
(pt-syntax-error
source
"Ill-formed declaration"))))
((memq id parameterized-declarations)
(cond ((not pos)
(pt-syntax-error
id*
"Declaration can't be negated"))
((eqv? (proper-length x) 2)
(parameterized-decl
source
id
(source->expression (cadr x))))
(else
(pt-syntax-error
source
"Ill-formed declaration"))))
((memq id boolean-declarations)
(if (null? (cdr x))
(boolean-decl source id pos)
(pt-syntax-error source "Ill-formed declaration")))
((assq id namable-declarations)
(cond ((not pos)
(pt-syntax-error
id*
"Declaration can't be negated"))
(else
(namable-decl
source
(cdr (assq id namable-declarations))
id
(map source->expression (cdr x))))))
((memq id namable-boolean-declarations)
(namable-boolean-decl
source
id
pos
(map source->expression (cdr x))))
((memq id namable-string-declarations)
(if (not (pair? (cdr x)))
(pt-syntax-error source "Ill-formed declaration")
(let* ((str* (cadr x)) (str (source-code str*)))
(cond ((not pos)
(pt-syntax-error
id*
"Declaration can't be negated"))
((not (string? str))
(pt-syntax-error str* "String expected"))
(else
(namable-string-decl
source
id
str
(map source->expression (cddr x))))))))
(else (pt-syntax-error id* "Unknown declaration")))))))))
(define (add-declarations source env)
(let loop ((l (cdr (source-code source))) (env env))
(if (pair? l)
(loop (cdr l) (env-declare env (transform-declaration (car l))))
env)))
(define (add-decl d decl) (env-declare decl d))
(define (add-macro source env)
(define (form-size parms)
(let loop ((l parms) (n 1))
(if (pair? l) (loop (cdr l) (+ n 1)) (if (null? l) n (- n)))))
(define (error-proc . msgs)
(apply compiler-user-error
(cons (source-locat source) (cons "(in macro body)" msgs))))
(let ((var (definition-variable source)) (proc (definition-value source)))
(if (lambda-expr? proc env)
(env-macro
env
(source-code var)
(cons (form-size (source->parms (cadr (source-code proc))))
(scheme-global-eval (source->expression proc) error-proc)))
(pt-syntax-error source "Macro value must be a lambda expression"))))
(define (ptree.begin! info-port) (set! *ptree-port* info-port) '())
(define (ptree.end!) '())
(define *ptree-port* '())
(define (normalize-parse-tree ptree env)
(define (normalize ptree)
(let ((tree (assignment-convert (partial-evaluate ptree) env)))
(lambda-lift! tree)
tree))
(if (def? ptree)
(begin
(node-children-set! ptree (list (normalize (def-val ptree))))
ptree)
(normalize ptree)))
(define (partial-evaluate ptree) (pe ptree '()))
(define (pe ptree consts)
(cond ((cst? ptree)
(new-cst (node-source ptree) (node-decl ptree) (cst-val ptree)))
((ref? ptree)
(let ((var (ref-var ptree)))
(var-refs-set! var (set-remove (var-refs var) ptree))
(let ((x (assq var consts)))
(if x
(new-cst (node-source ptree) (node-decl ptree) (cdr x))
(let ((y (global-val var)))
(if (and y (cst? y))
(new-cst (node-source ptree)
(node-decl ptree)
(cst-val y))
(new-ref (node-source ptree)
(node-decl ptree)
var)))))))
((set? ptree)
(let ((var (set-var ptree)) (val (pe (set-val ptree) consts)))
(var-sets-set! var (set-remove (var-sets var) ptree))
(new-set (node-source ptree) (node-decl ptree) var val)))
((tst? ptree)
(let ((pre (pe (tst-pre ptree) consts)))
(if (cst? pre)
(let ((val (cst-val pre)))
(if (false-object? val)
(pe (tst-alt ptree) consts)
(pe (tst-con ptree) consts)))
(new-tst (node-source ptree)
(node-decl ptree)
pre
(pe (tst-con ptree) consts)
(pe (tst-alt ptree) consts)))))
((conj? ptree)
(let ((pre (pe (conj-pre ptree) consts)))
(if (cst? pre)
(let ((val (cst-val pre)))
(if (false-object? val) pre (pe (conj-alt ptree) consts)))
(new-conj
(node-source ptree)
(node-decl ptree)
pre
(pe (conj-alt ptree) consts)))))
((disj? ptree)
(let ((pre (pe (disj-pre ptree) consts)))
(if (cst? pre)
(let ((val (cst-val pre)))
(if (false-object? val) (pe (disj-alt ptree) consts) pre))
(new-disj
(node-source ptree)
(node-decl ptree)
pre
(pe (disj-alt ptree) consts)))))
((prc? ptree)
(new-prc (node-source ptree)
(node-decl ptree)
(prc-name ptree)
(prc-min ptree)
(prc-rest ptree)
(prc-parms ptree)
(pe (prc-body ptree) consts)))
((app? ptree)
(let ((oper (app-oper ptree)) (args (app-args ptree)))
(if (and (prc? oper)
(not (prc-rest oper))
(= (length (prc-parms oper)) (length args)))
(pe-let ptree consts)
(new-call
(node-source ptree)
(node-decl ptree)
(pe oper consts)
(map (lambda (x) (pe x consts)) args)))))
((fut? ptree)
(new-fut (node-source ptree)
(node-decl ptree)
(pe (fut-val ptree) consts)))
(else (compiler-internal-error "pe, unknown parse tree node type"))))
(define (pe-let ptree consts)
(let* ((proc (app-oper ptree))
(vals (app-args ptree))
(vars (prc-parms proc))
(non-mut-vars (set-keep not-mutable? (list->set vars))))
(for-each
(lambda (var)
(var-refs-set! var (set-empty))
(var-sets-set! var (set-empty)))
vars)
(let loop ((l vars)
(v vals)
(new-vars '())
(new-vals '())
(new-consts consts))
(if (null? l)
(if (null? new-vars)
(pe (prc-body proc) new-consts)
(new-call
(node-source ptree)
(node-decl ptree)
(new-prc (node-source proc)
(node-decl proc)
#f
(length new-vars)
#f
(reverse new-vars)
(pe (prc-body proc) new-consts))
(reverse new-vals)))
(let ((var (car l)) (val (pe (car v) consts)))
(if (and (set-member? var non-mut-vars) (cst? val))
(loop (cdr l)
(cdr v)
new-vars
new-vals
(cons (cons var (cst-val val)) new-consts))
(loop (cdr l)
(cdr v)
(cons var new-vars)
(cons val new-vals)
new-consts)))))))
(define (assignment-convert ptree env)
(ac ptree (env-declare env (list safe-sym #f)) '()))
(define (ac ptree env mut)
(cond ((cst? ptree) ptree)
((ref? ptree)
(let ((var (ref-var ptree)))
(if (global? var)
ptree
(let ((x (assq var mut)))
(if x
(let ((source (node-source ptree)))
(var-refs-set! var (set-remove (var-refs var) ptree))
(new-call
source
(node-decl ptree)
(new-ref-extended-bindings source **cell-ref-sym env)
(list (new-ref source (node-decl ptree) (cdr x)))))
ptree)))))
((set? ptree)
(let ((var (set-var ptree))
(source (node-source ptree))
(val (ac (set-val ptree) env mut)))
(var-sets-set! var (set-remove (var-sets var) ptree))
(if (global? var)
(new-set source (node-decl ptree) var val)
(new-call
source
(node-decl ptree)
(new-ref-extended-bindings source **cell-set!-sym env)
(list (new-ref source (node-decl ptree) (cdr (assq var mut)))
val)))))
((tst? ptree)
(new-tst (node-source ptree)
(node-decl ptree)
(ac (tst-pre ptree) env mut)
(ac (tst-con ptree) env mut)
(ac (tst-alt ptree) env mut)))
((conj? ptree)
(new-conj
(node-source ptree)
(node-decl ptree)
(ac (conj-pre ptree) env mut)
(ac (conj-alt ptree) env mut)))
((disj? ptree)
(new-disj
(node-source ptree)
(node-decl ptree)
(ac (disj-pre ptree) env mut)
(ac (disj-alt ptree) env mut)))
((prc? ptree) (ac-proc ptree env mut))
((app? ptree)
(let ((oper (app-oper ptree)) (args (app-args ptree)))
(if (and (prc? oper)
(not (prc-rest oper))
(= (length (prc-parms oper)) (length args)))
(ac-let ptree env mut)
(new-call
(node-source ptree)
(node-decl ptree)
(ac oper env mut)
(map (lambda (x) (ac x env mut)) args)))))
((fut? ptree)
(new-fut (node-source ptree)
(node-decl ptree)
(ac (fut-val ptree) env mut)))
(else (compiler-internal-error "ac, unknown parse tree node type"))))
(define (ac-proc ptree env mut)
(let* ((mut-parms (ac-mutables (prc-parms ptree)))
(mut-parms-copies (map var-copy mut-parms))
(mut (append (pair-up mut-parms mut-parms-copies) mut))
(new-body (ac (prc-body ptree) env mut)))
(new-prc (node-source ptree)
(node-decl ptree)
(prc-name ptree)
(prc-min ptree)
(prc-rest ptree)
(prc-parms ptree)
(if (null? mut-parms)
new-body
(new-call
(node-source ptree)
(node-decl ptree)
(new-prc (node-source ptree)
(node-decl ptree)
#f
(length mut-parms-copies)
#f
mut-parms-copies
new-body)
(map (lambda (var)
(new-call
(var-source var)
(node-decl ptree)
(new-ref-extended-bindings
(var-source var)
**make-cell-sym
env)
(list (new-ref (var-source var)
(node-decl ptree)
var))))
mut-parms))))))
(define (ac-let ptree env mut)
(let* ((proc (app-oper ptree))
(vals (app-args ptree))
(vars (prc-parms proc))
(vals-fv (apply set-union (map free-variables vals)))
(mut-parms (ac-mutables vars))
(mut-parms-copies (map var-copy mut-parms))
(mut (append (pair-up mut-parms mut-parms-copies) mut)))
(let loop ((l vars)
(v vals)
(new-vars '())
(new-vals '())
(new-body (ac (prc-body proc) env mut)))
(if (null? l)
(new-let ptree proc new-vars new-vals new-body)
(let ((var (car l)) (val (car v)))
(if (memq var mut-parms)
(let ((src (node-source val))
(decl (node-decl val))
(var* (cdr (assq var mut))))
(if (set-member? var vals-fv)
(loop (cdr l)
(cdr v)
(cons var* new-vars)
(cons (new-call
src
decl
(new-ref-extended-bindings
src
**make-cell-sym
env)
(list (new-cst src decl undef-object)))
new-vals)
(new-seq src
decl
(new-call
src
decl
(new-ref-extended-bindings
src
**cell-set!-sym
env)
(list (new-ref src decl var*)
(ac val env mut)))
new-body))
(loop (cdr l)
(cdr v)
(cons var* new-vars)
(cons (new-call
src
decl
(new-ref-extended-bindings
src
**make-cell-sym
env)
(list (ac val env mut)))
new-vals)
new-body)))
(loop (cdr l)
(cdr v)
(cons var new-vars)
(cons (ac val env mut) new-vals)
new-body)))))))
(define (ac-mutables l)
(if (pair? l)
(let ((var (car l)) (rest (ac-mutables (cdr l))))
(if (mutable? var) (cons var rest) rest))
'()))
(define (lambda-lift! ptree) (ll! ptree (set-empty) '()))
(define (ll! ptree cst-procs env)
(define (new-env env vars)
(define (loop i l)
(if (pair? l)
(let ((var (car l)))
(cons (cons var (cons (length (set->list (var-refs var))) i))
(loop (+ i 1) (cdr l))))
env))
(loop (length env) vars))
(cond ((or (cst? ptree)
(ref? ptree)
(set? ptree)
(tst? ptree)
(conj? ptree)
(disj? ptree)
(fut? ptree))
(for-each
(lambda (child) (ll! child cst-procs env))
(node-children ptree)))
((prc? ptree)
(ll! (prc-body ptree) cst-procs (new-env env (prc-parms ptree))))
((app? ptree)
(let ((oper (app-oper ptree)) (args (app-args ptree)))
(if (and (prc? oper)
(not (prc-rest oper))
(= (length (prc-parms oper)) (length args)))
(ll!-let ptree cst-procs (new-env env (prc-parms oper)))
(for-each
(lambda (child) (ll! child cst-procs env))
(node-children ptree)))))
(else (compiler-internal-error "ll!, unknown parse tree node type"))))
(define (ll!-let ptree cst-procs env)
(let* ((proc (app-oper ptree))
(vals (app-args ptree))
(vars (prc-parms proc))
(var-val-map (pair-up vars vals)))
(define (var->val var) (cdr (assq var var-val-map)))
(define (liftable-proc-vars vars)
(let loop ((cst-proc-vars
(set-keep
(lambda (var)
(let ((val (var->val var)))
(and (prc? val)
(lambda-lift? (node-decl val))
(set-every? oper-pos? (var-refs var)))))
(list->set vars))))
(let* ((non-cst-proc-vars
(set-keep
(lambda (var)
(let ((val (var->val var)))
(and (prc? val) (not (set-member? var cst-proc-vars)))))
(list->set vars)))
(cst-proc-vars*
(set-keep
(lambda (var)
(let ((val (var->val var)))
(set-empty?
(set-intersection
(free-variables val)
non-cst-proc-vars))))
cst-proc-vars)))
(if (set-equal? cst-proc-vars cst-proc-vars*)
cst-proc-vars
(loop cst-proc-vars*)))))
(define (transitively-closed-free-variables vars)
(let ((tcfv-map
(map (lambda (var) (cons var (free-variables (var->val var))))
vars)))
(let loop ((changed? #f))
(for-each
(lambda (var-tcfv)
(let loop2 ((l (set->list (cdr var-tcfv))) (fv (cdr var-tcfv)))
(if (null? l)
(if (not (set-equal? fv (cdr var-tcfv)))
(begin (set-cdr! var-tcfv fv) (set! changed? #t)))
(let ((x (assq (car l) tcfv-map)))
(loop2 (cdr l) (if x (set-union fv (cdr x)) fv))))))
tcfv-map)
(if changed? (loop #f) tcfv-map))))
(let* ((tcfv-map
(transitively-closed-free-variables (liftable-proc-vars vars)))
(cst-proc-vars-list (map car tcfv-map))
(cst-procs* (set-union (list->set cst-proc-vars-list) cst-procs)))
(define (var->tcfv var) (cdr (assq var tcfv-map)))
(define (order-vars vars)
(map car
(sort-list
(map (lambda (var) (assq var env)) vars)
(lambda (x y)
(if (= (cadr x) (cadr y))
(< (cddr x) (cddr y))
(< (cadr x) (cadr y)))))))
(define (lifted-vars var)
(order-vars (set->list (set-difference (var->tcfv var) cst-procs*))))
(define (lift-app! var)
(let* ((val (var->val var)) (vars (lifted-vars var)))
(define (new-ref* var)
(new-ref (var-source var) (node-decl val) var))
(if (not (null? vars))
(for-each
(lambda (oper)
(let ((node (node-parent oper)))
(node-children-set!
node
(cons (app-oper node)
(append (map new-ref* vars) (app-args node))))))
(set->list (var-refs var))))))
(define (lift-prc! var)
(let* ((val (var->val var)) (vars (lifted-vars var)))
(if (not (null? vars))
(let ((var-copies (map var-copy vars)))
(prc-parms-set! val (append var-copies (prc-parms val)))
(for-each (lambda (x) (var-bound-set! x val)) var-copies)
(node-fv-invalidate! val)
(prc-min-set! val (+ (prc-min val) (length vars)))
(ll-rename! val (pair-up vars var-copies))))))
(for-each lift-app! cst-proc-vars-list)
(for-each lift-prc! cst-proc-vars-list)
(for-each (lambda (node) (ll! node cst-procs* env)) vals)
(ll! (prc-body proc) cst-procs* env))))
(define (ll-rename! ptree var-map)
(cond ((ref? ptree)
(let* ((var (ref-var ptree)) (x (assq var var-map)))
(if x
(begin
(var-refs-set! var (set-remove (var-refs var) ptree))
(var-refs-set! (cdr x) (set-adjoin (var-refs (cdr x)) ptree))
(ref-var-set! ptree (cdr x))))))
((set? ptree)
(let* ((var (set-var ptree)) (x (assq var var-map)))
(if x
(begin
(var-sets-set! var (set-remove (var-sets var) ptree))
(var-sets-set! (cdr x) (set-adjoin (var-sets (cdr x)) ptree))
(set-var-set! ptree (cdr x)))))))
(node-fv-set! ptree #t)
(for-each (lambda (child) (ll-rename! child var-map)) (node-children ptree)))
(define (parse-tree->expression ptree) (se ptree '() (list 0)))
(define (se ptree env num)
(cond ((cst? ptree) (list quote-sym (cst-val ptree)))
((ref? ptree)
(let ((x (assq (ref-var ptree) env)))
(if x (cdr x) (var-name (ref-var ptree)))))
((set? ptree)
(list set!-sym
(let ((x (assq (set-var ptree) env)))
(if x (cdr x) (var-name (set-var ptree))))
(se (set-val ptree) env num)))
((def? ptree)
(list define-sym
(let ((x (assq (def-var ptree) env)))
(if x (cdr x) (var-name (def-var ptree))))
(se (def-val ptree) env num)))
((tst? ptree)
(list if-sym
(se (tst-pre ptree) env num)
(se (tst-con ptree) env num)
(se (tst-alt ptree) env num)))
((conj? ptree)
(list and-sym
(se (conj-pre ptree) env num)
(se (conj-alt ptree) env num)))
((disj? ptree)
(list or-sym
(se (disj-pre ptree) env num)
(se (disj-alt ptree) env num)))
((prc? ptree)
(let ((new-env (se-rename (prc-parms ptree) env num)))
(list lambda-sym
(se-parameters
(prc-parms ptree)
(prc-rest ptree)
(prc-min ptree)
new-env)
(se (prc-body ptree) new-env num))))
((app? ptree)
(let ((oper (app-oper ptree)) (args (app-args ptree)))
(if (and (prc? oper)
(not (prc-rest oper))
(= (length (prc-parms oper)) (length args)))
(let ((new-env (se-rename (prc-parms oper) env num)))
(list (if (set-empty?
(set-intersection
(list->set (prc-parms oper))
(apply set-union (map free-variables args))))
let-sym
letrec-sym)
(se-bindings (prc-parms oper) args new-env num)
(se (prc-body oper) new-env num)))
(map (lambda (x) (se x env num)) (cons oper args)))))
((fut? ptree) (list future-sym (se (fut-val ptree) env num)))
(else (compiler-internal-error "se, unknown parse tree node type"))))
(define (se-parameters parms rest min env)
(define (se-parms parms rest n env)
(cond ((null? parms) '())
((and rest (null? (cdr parms))) (cdr (assq (car parms) env)))
(else
(let ((parm (cdr (assq (car parms) env))))
(cons (if (> n 0) parm (list parm))
(se-parms (cdr parms) rest (- n 1) env))))))
(se-parms parms rest min env))
(define (se-bindings vars vals env num)
(if (null? vars)
'()
(cons (list (cdr (assq (car vars) env)) (se (car vals) env num))
(se-bindings (cdr vars) (cdr vals) env num))))
(define (se-rename vars env num)
(define (rename vars)
(if (null? vars)
env
(cons (cons (car vars)
(string->canonical-symbol
(string-append
(symbol->string (var-name (car vars)))
"#"
(number->string (car num)))))
(rename (cdr vars)))))
(set-car! num (+ (car num) 1))
(rename vars))
(define *opnd-table* '())
(define *opnd-table-alloc* '())
(define opnd-table-size 10000)
(define (enter-opnd arg1 arg2)
(let loop ((i 0))
(if (< i *opnd-table-alloc*)
(let ((x (vector-ref *opnd-table* i)))
(if (and (eqv? (car x) arg1) (eqv? (cdr x) arg2)) i (loop (+ i 1))))
(if (< *opnd-table-alloc* opnd-table-size)
(begin
(set! *opnd-table-alloc* (+ *opnd-table-alloc* 1))
(vector-set! *opnd-table* i (cons arg1 arg2))
i)
(compiler-limitation-error
"program is too long [virtual machine operand table overflow]")))))
(define (contains-opnd? opnd1 opnd2)
(cond ((eqv? opnd1 opnd2) #t)
((clo? opnd2) (contains-opnd? opnd1 (clo-base opnd2)))
(else #f)))
(define (any-contains-opnd? opnd opnds)
(if (null? opnds)
#f
(or (contains-opnd? opnd (car opnds))
(any-contains-opnd? opnd (cdr opnds)))))
(define (make-reg num) num)
(define (reg? x) (< x 10000))
(define (reg-num x) (modulo x 10000))
(define (make-stk num) (+ num 10000))
(define (stk? x) (= (quotient x 10000) 1))
(define (stk-num x) (modulo x 10000))
(define (make-glo name) (+ (enter-opnd name #t) 30000))
(define (glo? x) (= (quotient x 10000) 3))
(define (glo-name x) (car (vector-ref *opnd-table* (modulo x 10000))))
(define (make-clo base index) (+ (enter-opnd base index) 40000))
(define (clo? x) (= (quotient x 10000) 4))
(define (clo-base x) (car (vector-ref *opnd-table* (modulo x 10000))))
(define (clo-index x) (cdr (vector-ref *opnd-table* (modulo x 10000))))
(define (make-lbl num) (+ num 20000))
(define (lbl? x) (= (quotient x 10000) 2))
(define (lbl-num x) (modulo x 10000))
(define label-limit 9999)
(define (make-obj val) (+ (enter-opnd val #f) 50000))
(define (obj? x) (= (quotient x 10000) 5))
(define (obj-val x) (car (vector-ref *opnd-table* (modulo x 10000))))
(define (make-pcontext fs map) (vector fs map))
(define (pcontext-fs x) (vector-ref x 0))
(define (pcontext-map x) (vector-ref x 1))
(define (make-frame size slots regs closed live)
(vector size slots regs closed live))
(define (frame-size x) (vector-ref x 0))
(define (frame-slots x) (vector-ref x 1))
(define (frame-regs x) (vector-ref x 2))
(define (frame-closed x) (vector-ref x 3))
(define (frame-live x) (vector-ref x 4))
(define (frame-eq? x y) (= (frame-size x) (frame-size y)))
(define (frame-truncate frame nb-slots)
(let ((fs (frame-size frame)))
(make-frame
nb-slots
(nth-after (frame-slots frame) (- fs nb-slots))
(frame-regs frame)
(frame-closed frame)
(frame-live frame))))
(define (frame-live? var frame)
(let ((live (frame-live frame)))
(if (eq? var closure-env-var)
(let ((closed (frame-closed frame)))
(if (or (set-member? var live)
(not (set-empty?
(set-intersection live (list->set closed)))))
closed
#f))
(if (set-member? var live) var #f))))
(define (frame-first-empty-slot frame)
(let loop ((i 1) (s (reverse (frame-slots frame))))
(if (pair? s)
(if (frame-live? (car s) frame) (loop (+ i 1) (cdr s)) i)
i)))
(define (make-proc-obj
name
primitive?
code
call-pat
side-effects?
strict-pat
type)
(let ((proc-obj
(vector proc-obj-tag
name
primitive?
code
call-pat
#f
#f
#f
side-effects?
strict-pat
type)))
(proc-obj-specialize-set! proc-obj (lambda (decls) proc-obj))
proc-obj))
(define proc-obj-tag (list 'proc-obj))
(define (proc-obj? x)
(and (vector? x)
(> (vector-length x) 0)
(eq? (vector-ref x 0) proc-obj-tag)))
(define (proc-obj-name obj) (vector-ref obj 1))
(define (proc-obj-primitive? obj) (vector-ref obj 2))
(define (proc-obj-code obj) (vector-ref obj 3))
(define (proc-obj-call-pat obj) (vector-ref obj 4))
(define (proc-obj-test obj) (vector-ref obj 5))
(define (proc-obj-inlinable obj) (vector-ref obj 6))
(define (proc-obj-specialize obj) (vector-ref obj 7))
(define (proc-obj-side-effects? obj) (vector-ref obj 8))
(define (proc-obj-strict-pat obj) (vector-ref obj 9))
(define (proc-obj-type obj) (vector-ref obj 10))
(define (proc-obj-code-set! obj x) (vector-set! obj 3 x))
(define (proc-obj-test-set! obj x) (vector-set! obj 5 x))
(define (proc-obj-inlinable-set! obj x) (vector-set! obj 6 x))
(define (proc-obj-specialize-set! obj x) (vector-set! obj 7 x))
(define (make-pattern min-args nb-parms rest?)
(let loop ((x (if rest? (- nb-parms 1) (list nb-parms)))
(y (if rest? (- nb-parms 1) nb-parms)))
(let ((z (- y 1))) (if (< z min-args) x (loop (cons z x) z)))))
(define (pattern-member? n pat)
(cond ((pair? pat) (if (= (car pat) n) #t (pattern-member? n (cdr pat))))
((null? pat) #f)
(else (<= pat n))))
(define (type-name type) (if (pair? type) (car type) type))
(define (type-pot-fut? type) (pair? type))
(define (make-bbs)
(vector (make-counter 1 label-limit bbs-limit-err) (queue-empty) '()))
(define (bbs-limit-err)
(compiler-limitation-error "procedure is too long [too many labels]"))
(define (bbs-lbl-counter bbs) (vector-ref bbs 0))
(define (bbs-lbl-counter-set! bbs cntr) (vector-set! bbs 0 cntr))
(define (bbs-bb-queue bbs) (vector-ref bbs 1))
(define (bbs-bb-queue-set! bbs bbq) (vector-set! bbs 1 bbq))
(define (bbs-entry-lbl-num bbs) (vector-ref bbs 2))
(define (bbs-entry-lbl-num-set! bbs lbl-num) (vector-set! bbs 2 lbl-num))
(define (bbs-new-lbl! bbs) ((bbs-lbl-counter bbs)))
(define (lbl-num->bb lbl-num bbs)
(let loop ((bb-list (queue->list (bbs-bb-queue bbs))))
(if (= (bb-lbl-num (car bb-list)) lbl-num)
(car bb-list)
(loop (cdr bb-list)))))
(define (make-bb label-instr bbs)
(let ((bb (vector label-instr (queue-empty) '() '() '())))
(queue-put! (vector-ref bbs 1) bb)
bb))
(define (bb-lbl-num bb) (label-lbl-num (vector-ref bb 0)))
(define (bb-label-type bb) (label-type (vector-ref bb 0)))
(define (bb-label-instr bb) (vector-ref bb 0))
(define (bb-label-instr-set! bb l) (vector-set! bb 0 l))
(define (bb-non-branch-instrs bb) (queue->list (vector-ref bb 1)))
(define (bb-non-branch-instrs-set! bb l) (vector-set! bb 1 (list->queue l)))
(define (bb-branch-instr bb) (vector-ref bb 2))
(define (bb-branch-instr-set! bb b) (vector-set! bb 2 b))
(define (bb-references bb) (vector-ref bb 3))
(define (bb-references-set! bb l) (vector-set! bb 3 l))
(define (bb-precedents bb) (vector-ref bb 4))
(define (bb-precedents-set! bb l) (vector-set! bb 4 l))
(define (bb-entry-frame-size bb)
(frame-size (gvm-instr-frame (bb-label-instr bb))))
(define (bb-exit-frame-size bb)
(frame-size (gvm-instr-frame (bb-branch-instr bb))))
(define (bb-slots-gained bb)
(- (bb-exit-frame-size bb) (bb-entry-frame-size bb)))
(define (bb-put-non-branch! bb gvm-instr)
(queue-put! (vector-ref bb 1) gvm-instr))
(define (bb-put-branch! bb gvm-instr) (vector-set! bb 2 gvm-instr))
(define (bb-add-reference! bb ref)
(if (not (memq ref (vector-ref bb 3)))
(vector-set! bb 3 (cons ref (vector-ref bb 3)))))
(define (bb-add-precedent! bb prec)
(if (not (memq prec (vector-ref bb 4)))
(vector-set! bb 4 (cons prec (vector-ref bb 4)))))
(define (bb-last-non-branch-instr bb)
(let ((non-branch-instrs (bb-non-branch-instrs bb)))
(if (null? non-branch-instrs)
(bb-label-instr bb)
(let loop ((l non-branch-instrs))
(if (pair? (cdr l)) (loop (cdr l)) (car l))))))
(define (gvm-instr-type gvm-instr) (vector-ref gvm-instr 0))
(define (gvm-instr-frame gvm-instr) (vector-ref gvm-instr 1))
(define (gvm-instr-comment gvm-instr) (vector-ref gvm-instr 2))
(define (make-label-simple lbl-num frame comment)
(vector 'label frame comment lbl-num 'simple))
(define (make-label-entry lbl-num nb-parms min rest? closed? frame comment)
(vector 'label frame comment lbl-num 'entry nb-parms min rest? closed?))
(define (make-label-return lbl-num frame comment)
(vector 'label frame comment lbl-num 'return))
(define (make-label-task-entry lbl-num frame comment)
(vector 'label frame comment lbl-num 'task-entry))
(define (make-label-task-return lbl-num frame comment)
(vector 'label frame comment lbl-num 'task-return))
(define (label-lbl-num gvm-instr) (vector-ref gvm-instr 3))
(define (label-lbl-num-set! gvm-instr n) (vector-set! gvm-instr 3 n))
(define (label-type gvm-instr) (vector-ref gvm-instr 4))
(define (label-entry-nb-parms gvm-instr) (vector-ref gvm-instr 5))
(define (label-entry-min gvm-instr) (vector-ref gvm-instr 6))
(define (label-entry-rest? gvm-instr) (vector-ref gvm-instr 7))
(define (label-entry-closed? gvm-instr) (vector-ref gvm-instr 8))
(define (make-apply prim opnds loc frame comment)
(vector 'apply frame comment prim opnds loc))
(define (apply-prim gvm-instr) (vector-ref gvm-instr 3))
(define (apply-opnds gvm-instr) (vector-ref gvm-instr 4))
(define (apply-loc gvm-instr) (vector-ref gvm-instr 5))
(define (make-copy opnd loc frame comment)
(vector 'copy frame comment opnd loc))
(define (copy-opnd gvm-instr) (vector-ref gvm-instr 3))
(define (copy-loc gvm-instr) (vector-ref gvm-instr 4))
(define (make-close parms frame comment) (vector 'close frame comment parms))
(define (close-parms gvm-instr) (vector-ref gvm-instr 3))
(define (make-closure-parms loc lbl opnds) (vector loc lbl opnds))
(define (closure-parms-loc x) (vector-ref x 0))
(define (closure-parms-lbl x) (vector-ref x 1))
(define (closure-parms-opnds x) (vector-ref x 2))
(define (make-ifjump test opnds true false poll? frame comment)
(vector 'ifjump frame comment test opnds true false poll?))
(define (ifjump-test gvm-instr) (vector-ref gvm-instr 3))
(define (ifjump-opnds gvm-instr) (vector-ref gvm-instr 4))
(define (ifjump-true gvm-instr) (vector-ref gvm-instr 5))
(define (ifjump-false gvm-instr) (vector-ref gvm-instr 6))
(define (ifjump-poll? gvm-instr) (vector-ref gvm-instr 7))
(define (make-jump opnd nb-args poll? frame comment)
(vector 'jump frame comment opnd nb-args poll?))
(define (jump-opnd gvm-instr) (vector-ref gvm-instr 3))
(define (jump-nb-args gvm-instr) (vector-ref gvm-instr 4))
(define (jump-poll? gvm-instr) (vector-ref gvm-instr 5))
(define (first-class-jump? gvm-instr) (jump-nb-args gvm-instr))
(define (make-comment) (cons 'comment '()))
(define (comment-put! comment name val)
(set-cdr! comment (cons (cons name val) (cdr comment))))
(define (comment-get comment name)
(and comment (let ((x (assq name (cdr comment)))) (if x (cdr x) #f))))
(define (bbs-purify! bbs)
(let loop ()
(bbs-remove-jump-cascades! bbs)
(bbs-remove-dead-code! bbs)
(let* ((changed1? (bbs-remove-common-code! bbs))
(changed2? (bbs-remove-useless-jumps! bbs)))
(if (or changed1? changed2?) (loop) (bbs-order! bbs)))))
(define (bbs-remove-jump-cascades! bbs)
(define (empty-bb? bb)
(and (eq? (bb-label-type bb) 'simple) (null? (bb-non-branch-instrs bb))))
(define (jump-to-non-entry-lbl? branch)
(and (eq? (gvm-instr-type branch) 'jump)
(not (first-class-jump? branch))
(jump-lbl? branch)))
(define (jump-cascade-to lbl-num fs poll? seen thunk)
(if (memq lbl-num seen)
(thunk lbl-num fs poll?)
(let ((bb (lbl-num->bb lbl-num bbs)))
(if (and (empty-bb? bb) (<= (bb-slots-gained bb) 0))
(let ((jump-lbl-num
(jump-to-non-entry-lbl? (bb-branch-instr bb))))
(if jump-lbl-num
(jump-cascade-to
jump-lbl-num
(+ fs (bb-slots-gained bb))
(or poll? (jump-poll? (bb-branch-instr bb)))
(cons lbl-num seen)
thunk)
(thunk lbl-num fs poll?)))
(thunk lbl-num fs poll?)))))
(define (equiv-lbl lbl-num seen)
(if (memq lbl-num seen)
lbl-num
(let ((bb (lbl-num->bb lbl-num bbs)))
(if (empty-bb? bb)
(let ((jump-lbl-num
(jump-to-non-entry-lbl? (bb-branch-instr bb))))
(if (and jump-lbl-num
(not (jump-poll? (bb-branch-instr bb)))
(= (bb-slots-gained bb) 0))
(equiv-lbl jump-lbl-num (cons lbl-num seen))
lbl-num))
lbl-num))))
(define (remove-cascade! bb)
(let ((branch (bb-branch-instr bb)))
(case (gvm-instr-type branch)
((ifjump)
(bb-put-branch!
bb
(make-ifjump
(ifjump-test branch)
(ifjump-opnds branch)
(equiv-lbl (ifjump-true branch) '())
(equiv-lbl (ifjump-false branch) '())
(ifjump-poll? branch)
(gvm-instr-frame branch)
(gvm-instr-comment branch))))
((jump)
(if (not (first-class-jump? branch))
(let ((dest-lbl-num (jump-lbl? branch)))
(if dest-lbl-num
(jump-cascade-to
dest-lbl-num
(frame-size (gvm-instr-frame branch))
(jump-poll? branch)
'()
(lambda (lbl-num fs poll?)
(let* ((dest-bb (lbl-num->bb lbl-num bbs))
(last-branch (bb-branch-instr dest-bb)))
(if (and (empty-bb? dest-bb)
(or (not poll?)
put-poll-on-ifjump?
(not (eq? (gvm-instr-type last-branch)
'ifjump))))
(let* ((new-fs (+ fs (bb-slots-gained dest-bb)))
(new-frame
(frame-truncate
(gvm-instr-frame branch)
new-fs)))
(define (adjust-opnd opnd)
(cond ((stk? opnd)
(make-stk
(+ (- fs (bb-entry-frame-size dest-bb))
(stk-num opnd))))
((clo? opnd)
(make-clo
(adjust-opnd (clo-base opnd))
(clo-index opnd)))
(else opnd)))
(case (gvm-instr-type last-branch)
((ifjump)
(bb-put-branch!
bb
(make-ifjump
(ifjump-test last-branch)
(map adjust-opnd (ifjump-opnds last-branch))
(equiv-lbl (ifjump-true last-branch) '())
(equiv-lbl (ifjump-false last-branch) '())
(or poll? (ifjump-poll? last-branch))
new-frame
(gvm-instr-comment last-branch))))
((jump)
(bb-put-branch!
bb
(make-jump
(adjust-opnd (jump-opnd last-branch))
(jump-nb-args last-branch)
(or poll? (jump-poll? last-branch))
new-frame
(gvm-instr-comment last-branch))))
(else
(compiler-internal-error
"bbs-remove-jump-cascades!, unknown branch type"))))
(bb-put-branch!
bb
(make-jump
(make-lbl lbl-num)
(jump-nb-args branch)
(or poll? (jump-poll? branch))
(frame-truncate (gvm-instr-frame branch) fs)
(gvm-instr-comment branch)))))))))))
(else
(compiler-internal-error
"bbs-remove-jump-cascades!, unknown branch type")))))
(for-each remove-cascade! (queue->list (bbs-bb-queue bbs))))
(define (jump-lbl? branch)
(let ((opnd (jump-opnd branch))) (if (lbl? opnd) (lbl-num opnd) #f)))
(define put-poll-on-ifjump? #f)
(set! put-poll-on-ifjump? #t)
(define (bbs-remove-dead-code! bbs)
(let ((new-bb-queue (queue-empty)) (scan-queue (queue-empty)))
(define (reachable ref bb)
(if bb (bb-add-reference! bb ref))
(if (not (memq ref (queue->list new-bb-queue)))
(begin
(bb-references-set! ref '())
(bb-precedents-set! ref '())
(queue-put! new-bb-queue ref)
(queue-put! scan-queue ref))))
(define (direct-jump to-bb from-bb)
(reachable to-bb from-bb)
(bb-add-precedent! to-bb from-bb))
(define (scan-instr gvm-instr bb)
(define (scan-opnd gvm-opnd)
(cond ((lbl? gvm-opnd)
(reachable (lbl-num->bb (lbl-num gvm-opnd) bbs) bb))
((clo? gvm-opnd) (scan-opnd (clo-base gvm-opnd)))))
(case (gvm-instr-type gvm-instr)
((label) '())
((apply)
(for-each scan-opnd (apply-opnds gvm-instr))
(if (apply-loc gvm-instr) (scan-opnd (apply-loc gvm-instr))))
((copy)
(scan-opnd (copy-opnd gvm-instr))
(scan-opnd (copy-loc gvm-instr)))
((close)
(for-each
(lambda (parm)
(reachable (lbl-num->bb (closure-parms-lbl parm) bbs) bb)
(scan-opnd (closure-parms-loc parm))
(for-each scan-opnd (closure-parms-opnds parm)))
(close-parms gvm-instr)))
((ifjump)
(for-each scan-opnd (ifjump-opnds gvm-instr))
(direct-jump (lbl-num->bb (ifjump-true gvm-instr) bbs) bb)
(direct-jump (lbl-num->bb (ifjump-false gvm-instr) bbs) bb))
((jump)
(let ((opnd (jump-opnd gvm-instr)))
(if (lbl? opnd)
(direct-jump (lbl-num->bb (lbl-num opnd) bbs) bb)
(scan-opnd (jump-opnd gvm-instr)))))
(else
(compiler-internal-error
"bbs-remove-dead-code!, unknown GVM instruction type"))))
(reachable (lbl-num->bb (bbs-entry-lbl-num bbs) bbs) #f)
(let loop ()
(if (not (queue-empty? scan-queue))
(let ((bb (queue-get! scan-queue)))
(begin
(scan-instr (bb-label-instr bb) bb)
(for-each
(lambda (gvm-instr) (scan-instr gvm-instr bb))
(bb-non-branch-instrs bb))
(scan-instr (bb-branch-instr bb) bb)
(loop)))))
(bbs-bb-queue-set! bbs new-bb-queue)))
(define (bbs-remove-useless-jumps! bbs)
(let ((changed? #f))
(define (remove-useless-jump bb)
(let ((branch (bb-branch-instr bb)))
(if (and (eq? (gvm-instr-type branch) 'jump)
(not (first-class-jump? branch))
(not (jump-poll? branch))
(jump-lbl? branch))
(let* ((dest-bb (lbl-num->bb (jump-lbl? branch) bbs))
(frame1 (gvm-instr-frame (bb-last-non-branch-instr bb)))
(frame2 (gvm-instr-frame (bb-label-instr dest-bb))))
(if (and (eq? (bb-label-type dest-bb) 'simple)
(frame-eq? frame1 frame2)
(= (length (bb-precedents dest-bb)) 1))
(begin
(set! changed? #t)
(bb-non-branch-instrs-set!
bb
(append (bb-non-branch-instrs bb)
(bb-non-branch-instrs dest-bb)
'()))
(bb-branch-instr-set! bb (bb-branch-instr dest-bb))
(remove-useless-jump bb)))))))
(for-each remove-useless-jump (queue->list (bbs-bb-queue bbs)))
changed?))
(define (bbs-remove-common-code! bbs)
(let* ((bb-list (queue->list (bbs-bb-queue bbs)))
(n (length bb-list))
(hash-table-length (cond ((< n 50) 43) ((< n 500) 403) (else 4003)))
(hash-table (make-vector hash-table-length '()))
(prim-table '())
(block-map '())
(changed? #f))
(define (hash-prim prim)
(let ((n (length prim-table)) (i (pos-in-list prim prim-table)))
(if i
(- n i)
(begin (set! prim-table (cons prim prim-table)) (+ n 1)))))
(define (hash-opnds l)
(let loop ((l l) (n 0))
(if (pair? l)
(loop (cdr l)
(let ((x (car l)))
(if (lbl? x)
n
(modulo (+ (* n 10000) x) hash-table-length))))
n)))
(define (hash-bb bb)
(let ((branch (bb-branch-instr bb)))
(modulo (case (gvm-instr-type branch)
((ifjump)
(+ (hash-opnds (ifjump-opnds branch))
(* 10 (hash-prim (ifjump-test branch)))
(* 100 (frame-size (gvm-instr-frame branch)))))
((jump)
(+ (hash-opnds (list (jump-opnd branch)))
(* 10 (or (jump-nb-args branch) -1))
(* 100 (frame-size (gvm-instr-frame branch)))))
(else 0))
hash-table-length)))
(define (replacement-lbl-num lbl)
(let ((x (assv lbl block-map))) (if x (cdr x) lbl)))
(define (fix-map! bb1 bb2)
(let loop ((l block-map))
(if (pair? l)
(let ((x (car l)))
(if (= bb1 (cdr x)) (set-cdr! x bb2))
(loop (cdr l))))))
(define (enter-bb! bb)
(let ((h (hash-bb bb)))
(vector-set! hash-table h (add-bb bb (vector-ref hash-table h)))))
(define (add-bb bb l)
(if (pair? l)
(let ((bb* (car l)))
(set! block-map
(cons (cons (bb-lbl-num bb) (bb-lbl-num bb*)) block-map))
(if (eqv-bb? bb bb*)
(begin
(fix-map! (bb-lbl-num bb) (bb-lbl-num bb*))
(set! changed? #t)
l)
(begin
(set! block-map (cdr block-map))
(if (eqv-gvm-instr?
(bb-branch-instr bb)
(bb-branch-instr bb*))
(extract-common-tail
bb
bb*
(lambda (head head* tail)
(if (null? tail)
(cons bb* (add-bb bb (cdr l)))
(let* ((lbl (bbs-new-lbl! bbs))
(branch (bb-branch-instr bb))
(fs** (need-gvm-instrs tail branch))
(frame (frame-truncate
(gvm-instr-frame
(if (null? head)
(bb-label-instr bb)
(car head)))
fs**))
(bb** (make-bb (make-label-simple
lbl
frame
#f)
bbs)))
(bb-non-branch-instrs-set! bb** tail)
(bb-branch-instr-set! bb** branch)
(bb-non-branch-instrs-set! bb* (reverse head*))
(bb-branch-instr-set!
bb*
(make-jump (make-lbl lbl) #f #f frame #f))
(bb-non-branch-instrs-set! bb (reverse head))
(bb-branch-instr-set!
bb
(make-jump (make-lbl lbl) #f #f frame #f))
(set! changed? #t)
(cons bb (cons bb* (add-bb bb** (cdr l))))))))
(cons bb* (add-bb bb (cdr l)))))))
(list bb)))
(define (extract-common-tail bb1 bb2 cont)
(let loop ((l1 (reverse (bb-non-branch-instrs bb1)))
(l2 (reverse (bb-non-branch-instrs bb2)))
(tail '()))
(if (and (pair? l1) (pair? l2))
(let ((i1 (car l1)) (i2 (car l2)))
(if (eqv-gvm-instr? i1 i2)
(loop (cdr l1) (cdr l2) (cons i1 tail))
(cont l1 l2 tail)))
(cont l1 l2 tail))))
(define (eqv-bb? bb1 bb2)
(let ((bb1-non-branch (bb-non-branch-instrs bb1))
(bb2-non-branch (bb-non-branch-instrs bb2)))
(and (= (length bb1-non-branch) (length bb2-non-branch))
(eqv-gvm-instr? (bb-label-instr bb1) (bb-label-instr bb2))
(eqv-gvm-instr? (bb-branch-instr bb1) (bb-branch-instr bb2))
(eqv-list? eqv-gvm-instr? bb1-non-branch bb2-non-branch))))
(define (eqv-list? pred? l1 l2)
(if (pair? l1)
(and (pair? l2)
(pred? (car l1) (car l2))
(eqv-list? pred? (cdr l1) (cdr l2)))
(not (pair? l2))))
(define (eqv-lbl-num? lbl1 lbl2)
(= (replacement-lbl-num lbl1) (replacement-lbl-num lbl2)))
(define (eqv-gvm-opnd? opnd1 opnd2)
(if (not opnd1)
(not opnd2)
(and opnd2
(cond ((lbl? opnd1)
(and (lbl? opnd2)
(eqv-lbl-num? (lbl-num opnd1) (lbl-num opnd2))))
((clo? opnd1)
(and (clo? opnd2)
(= (clo-index opnd1) (clo-index opnd2))
(eqv-gvm-opnd? (clo-base opnd1) (clo-base opnd2))))
(else (eqv? opnd1 opnd2))))))
(define (eqv-gvm-instr? instr1 instr2)
(define (eqv-closure-parms? p1 p2)
(and (eqv-gvm-opnd? (closure-parms-loc p1) (closure-parms-loc p2))
(eqv-lbl-num? (closure-parms-lbl p1) (closure-parms-lbl p2))
(eqv-list?
eqv-gvm-opnd?
(closure-parms-opnds p1)
(closure-parms-opnds p2))))
(let ((type1 (gvm-instr-type instr1)) (type2 (gvm-instr-type instr2)))
(and (eq? type1 type2)
(frame-eq? (gvm-instr-frame instr1) (gvm-instr-frame instr2))
(case type1
((label)
(let ((ltype1 (label-type instr1))
(ltype2 (label-type instr2)))
(and (eq? ltype1 ltype2)
(case ltype1
((simple return task-entry task-return) #t)
((entry)
(and (= (label-entry-min instr1)
(label-entry-min instr2))
(= (label-entry-nb-parms instr1)
(label-entry-nb-parms instr2))
(eq? (label-entry-rest? instr1)
(label-entry-rest? instr2))
(eq? (label-entry-closed? instr1)
(label-entry-closed? instr2))))
(else
(compiler-internal-error
"eqv-gvm-instr?, unknown label type"))))))
((apply)
(and (eq? (apply-prim instr1) (apply-prim instr2))
(eqv-list?
eqv-gvm-opnd?
(apply-opnds instr1)
(apply-opnds instr2))
(eqv-gvm-opnd? (apply-loc instr1) (apply-loc instr2))))
((copy)
(and (eqv-gvm-opnd? (copy-opnd instr1) (copy-opnd instr2))
(eqv-gvm-opnd? (copy-loc instr1) (copy-loc instr2))))
((close)
(eqv-list?
eqv-closure-parms?
(close-parms instr1)
(close-parms instr2)))
((ifjump)
(and (eq? (ifjump-test instr1) (ifjump-test instr2))
(eqv-list?
eqv-gvm-opnd?
(ifjump-opnds instr1)
(ifjump-opnds instr2))
(eqv-lbl-num? (ifjump-true instr1) (ifjump-true instr2))
(eqv-lbl-num? (ifjump-false instr1) (ifjump-false instr2))
(eq? (ifjump-poll? instr1) (ifjump-poll? instr2))))
((jump)
(and (eqv-gvm-opnd? (jump-opnd instr1) (jump-opnd instr2))
(eqv? (jump-nb-args instr1) (jump-nb-args instr2))
(eq? (jump-poll? instr1) (jump-poll? instr2))))
(else
(compiler-internal-error
"eqv-gvm-instr?, unknown 'gvm-instr':"
instr1))))))
(define (update-bb! bb) (replace-label-references! bb replacement-lbl-num))
(for-each enter-bb! bb-list)
(bbs-entry-lbl-num-set! bbs (replacement-lbl-num (bbs-entry-lbl-num bbs)))
(let loop ((i 0) (result '()))
(if (< i hash-table-length)
(let ((bb-kept (vector-ref hash-table i)))
(for-each update-bb! bb-kept)
(loop (+ i 1) (append bb-kept result)))
(bbs-bb-queue-set! bbs (list->queue result))))
changed?))
(define (replace-label-references! bb replacement-lbl-num)
(define (update-gvm-opnd opnd)
(if opnd
(cond ((lbl? opnd) (make-lbl (replacement-lbl-num (lbl-num opnd))))
((clo? opnd)
(make-clo (update-gvm-opnd (clo-base opnd)) (clo-index opnd)))
(else opnd))
opnd))
(define (update-gvm-instr instr)
(define (update-closure-parms p)
(make-closure-parms
(update-gvm-opnd (closure-parms-loc p))
(replacement-lbl-num (closure-parms-lbl p))
(map update-gvm-opnd (closure-parms-opnds p))))
(case (gvm-instr-type instr)
((apply)
(make-apply
(apply-prim instr)
(map update-gvm-opnd (apply-opnds instr))
(update-gvm-opnd (apply-loc instr))
(gvm-instr-frame instr)
(gvm-instr-comment instr)))
((copy)
(make-copy
(update-gvm-opnd (copy-opnd instr))
(update-gvm-opnd (copy-loc instr))
(gvm-instr-frame instr)
(gvm-instr-comment instr)))
((close)
(make-close
(map update-closure-parms (close-parms instr))
(gvm-instr-frame instr)
(gvm-instr-comment instr)))
((ifjump)
(make-ifjump
(ifjump-test instr)
(map update-gvm-opnd (ifjump-opnds instr))
(replacement-lbl-num (ifjump-true instr))
(replacement-lbl-num (ifjump-false instr))
(ifjump-poll? instr)
(gvm-instr-frame instr)
(gvm-instr-comment instr)))
((jump)
(make-jump
(update-gvm-opnd (jump-opnd instr))
(jump-nb-args instr)
(jump-poll? instr)
(gvm-instr-frame instr)
(gvm-instr-comment instr)))
(else
(compiler-internal-error "update-gvm-instr, unknown 'instr':" instr))))
(bb-non-branch-instrs-set!
bb
(map update-gvm-instr (bb-non-branch-instrs bb)))
(bb-branch-instr-set! bb (update-gvm-instr (bb-branch-instr bb))))
(define (bbs-order! bbs)
(let ((new-bb-queue (queue-empty))
(left-to-schedule (queue->list (bbs-bb-queue bbs))))
(define (remove x l)
(if (eq? (car l) x) (cdr l) (cons (car l) (remove x (cdr l)))))
(define (remove-bb! bb)
(set! left-to-schedule (remove bb left-to-schedule))
bb)
(define (prec-bb bb)
(let loop ((l (bb-precedents bb)) (best #f) (best-fs #f))
(if (null? l)
best
(let* ((x (car l)) (x-fs (bb-exit-frame-size x)))
(if (and (memq x left-to-schedule)
(or (not best) (< x-fs best-fs)))
(loop (cdr l) x x-fs)
(loop (cdr l) best best-fs))))))
(define (succ-bb bb)
(define (branches-to-lbl? bb)
(let ((branch (bb-branch-instr bb)))
(case (gvm-instr-type branch)
((ifjump) #t)
((jump) (lbl? (jump-opnd branch)))
(else
(compiler-internal-error "bbs-order!, unknown branch type")))))
(define (best-succ bb1 bb2)
(if (branches-to-lbl? bb1)
bb1
(if (branches-to-lbl? bb2)
bb2
(if (< (bb-exit-frame-size bb1) (bb-exit-frame-size bb2))
bb2
bb1))))
(let ((branch (bb-branch-instr bb)))
(case (gvm-instr-type branch)
((ifjump)
(let* ((true-bb (lbl-num->bb (ifjump-true branch) bbs))
(true-bb* (and (memq true-bb left-to-schedule) true-bb))
(false-bb (lbl-num->bb (ifjump-false branch) bbs))
(false-bb* (and (memq false-bb left-to-schedule) false-bb)))
(if (and true-bb* false-bb*)
(best-succ true-bb* false-bb*)
(or true-bb* false-bb*))))
((jump)
(let ((opnd (jump-opnd branch)))
(and (lbl? opnd)
(let ((bb (lbl-num->bb (lbl-num opnd) bbs)))
(and (memq bb left-to-schedule) bb)))))
(else (compiler-internal-error "bbs-order!, unknown branch type")))))
(define (schedule-from bb)
(queue-put! new-bb-queue bb)
(let ((x (succ-bb bb)))
(if x
(begin
(schedule-around (remove-bb! x))
(let ((y (succ-bb bb)))
(if y (schedule-around (remove-bb! y)))))))
(schedule-refs bb))
(define (schedule-around bb)
(let ((x (prec-bb bb)))
(if x
(let ((bb-list (schedule-back (remove-bb! x) '())))
(queue-put! new-bb-queue x)
(schedule-forw bb)
(for-each schedule-refs bb-list))
(schedule-from bb))))
(define (schedule-back bb bb-list)
(let ((bb-list* (cons bb bb-list)) (x (prec-bb bb)))
(if x
(let ((bb-list (schedule-back (remove-bb! x) bb-list*)))
(queue-put! new-bb-queue x)
bb-list)
bb-list*)))
(define (schedule-forw bb)
(queue-put! new-bb-queue bb)
(let ((x (succ-bb bb)))
(if x
(begin
(schedule-forw (remove-bb! x))
(let ((y (succ-bb bb)))
(if y (schedule-around (remove-bb! y)))))))
(schedule-refs bb))
(define (schedule-refs bb)
(for-each
(lambda (x)
(if (memq x left-to-schedule) (schedule-around (remove-bb! x))))
(bb-references bb)))
(schedule-from (remove-bb! (lbl-num->bb (bbs-entry-lbl-num bbs) bbs)))
(bbs-bb-queue-set! bbs new-bb-queue)
(let ((bb-list (queue->list new-bb-queue)))
(let loop ((l bb-list) (i 1) (lbl-map '()))
(if (pair? l)
(let* ((label-instr (bb-label-instr (car l)))
(old-lbl-num (label-lbl-num label-instr)))
(label-lbl-num-set! label-instr i)
(loop (cdr l) (+ i 1) (cons (cons old-lbl-num i) lbl-map)))
(let ()
(define (replacement-lbl-num x) (cdr (assv x lbl-map)))
(define (update-bb! bb)
(replace-label-references! bb replacement-lbl-num))
(for-each update-bb! bb-list)
(bbs-lbl-counter-set!
bbs
(make-counter
(* (+ 1 (quotient (bbs-new-lbl! bbs) 1000)) 1000)
label-limit
bbs-limit-err))))))))
(define (make-code bb gvm-instr sn) (vector bb gvm-instr sn))
(define (code-bb code) (vector-ref code 0))
(define (code-gvm-instr code) (vector-ref code 1))
(define (code-slots-needed code) (vector-ref code 2))
(define (code-slots-needed-set! code n) (vector-set! code 2 n))
(define (bbs->code-list bbs)
(let ((code-list (linearize bbs)))
(setup-slots-needed! code-list)
code-list))
(define (linearize bbs)
(let ((code-queue (queue-empty)))
(define (put-bb bb)
(define (put-instr gvm-instr)
(queue-put! code-queue (make-code bb gvm-instr #f)))
(put-instr (bb-label-instr bb))
(for-each put-instr (bb-non-branch-instrs bb))
(put-instr (bb-branch-instr bb)))
(for-each put-bb (queue->list (bbs-bb-queue bbs)))
(queue->list code-queue)))
(define (setup-slots-needed! code-list)
(if (null? code-list)
#f
(let* ((code (car code-list))
(gvm-instr (code-gvm-instr code))
(sn-rest (setup-slots-needed! (cdr code-list))))
(case (gvm-instr-type gvm-instr)
((label)
(if (> sn-rest (frame-size (gvm-instr-frame gvm-instr)))
(compiler-internal-error
"setup-slots-needed!, incoherent slots needed for LABEL"))
(code-slots-needed-set! code sn-rest)
#f)
((ifjump jump)
(let ((sn (frame-size (gvm-instr-frame gvm-instr))))
(code-slots-needed-set! code sn)
(need-gvm-instr gvm-instr sn)))
(else
(code-slots-needed-set! code sn-rest)
(need-gvm-instr gvm-instr sn-rest))))))
(define (need-gvm-instrs non-branch branch)
(if (pair? non-branch)
(need-gvm-instr
(car non-branch)
(need-gvm-instrs (cdr non-branch) branch))
(need-gvm-instr branch (frame-size (gvm-instr-frame branch)))))
(define (need-gvm-instr gvm-instr sn-rest)
(case (gvm-instr-type gvm-instr)
((label) sn-rest)
((apply)
(let ((loc (apply-loc gvm-instr)))
(need-gvm-opnds
(apply-opnds gvm-instr)
(need-gvm-loc-opnd loc (need-gvm-loc loc sn-rest)))))
((copy)
(let ((loc (copy-loc gvm-instr)))
(need-gvm-opnd
(copy-opnd gvm-instr)
(need-gvm-loc-opnd loc (need-gvm-loc loc sn-rest)))))
((close)
(let ((parms (close-parms gvm-instr)))
(define (need-parms-opnds p)
(if (null? p)
sn-rest
(need-gvm-opnds
(closure-parms-opnds (car p))
(need-parms-opnds (cdr p)))))
(define (need-parms-loc p)
(if (null? p)
(need-parms-opnds parms)
(let ((loc (closure-parms-loc (car p))))
(need-gvm-loc-opnd
loc
(need-gvm-loc loc (need-parms-loc (cdr p)))))))
(need-parms-loc parms)))
((ifjump) (need-gvm-opnds (ifjump-opnds gvm-instr) sn-rest))
((jump) (need-gvm-opnd (jump-opnd gvm-instr) sn-rest))
(else
(compiler-internal-error
"need-gvm-instr, unknown 'gvm-instr':"
gvm-instr))))
(define (need-gvm-loc loc sn-rest)
(if (and loc (stk? loc) (>= (stk-num loc) sn-rest))
(- (stk-num loc) 1)
sn-rest))
(define (need-gvm-loc-opnd gvm-loc slots-needed)
(if (and gvm-loc (clo? gvm-loc))
(need-gvm-opnd (clo-base gvm-loc) slots-needed)
slots-needed))
(define (need-gvm-opnd gvm-opnd slots-needed)
(cond ((stk? gvm-opnd) (max (stk-num gvm-opnd) slots-needed))
((clo? gvm-opnd) (need-gvm-opnd (clo-base gvm-opnd) slots-needed))
(else slots-needed)))
(define (need-gvm-opnds gvm-opnds slots-needed)
(if (null? gvm-opnds)
slots-needed
(need-gvm-opnd
(car gvm-opnds)
(need-gvm-opnds (cdr gvm-opnds) slots-needed))))
(define (write-bb bb port)
(write-gvm-instr (bb-label-instr bb) port)
(display " [precedents=" port)
(write (map bb-lbl-num (bb-precedents bb)) port)
(display "]" port)
(newline port)
(for-each
(lambda (x) (write-gvm-instr x port) (newline port))
(bb-non-branch-instrs bb))
(write-gvm-instr (bb-branch-instr bb) port))
(define (write-bbs bbs port)
(for-each
(lambda (bb)
(if (= (bb-lbl-num bb) (bbs-entry-lbl-num bbs))
(begin (display "**** Entry block:" port) (newline port)))
(write-bb bb port)
(newline port))
(queue->list (bbs-bb-queue bbs))))
(define (virtual.dump proc port)
(let ((proc-seen (queue-empty)) (proc-left (queue-empty)))
(define (scan-opnd gvm-opnd)
(cond ((obj? gvm-opnd)
(let ((val (obj-val gvm-opnd)))
(if (and (proc-obj? val)
(proc-obj-code val)
(not (memq val (queue->list proc-seen))))
(begin
(queue-put! proc-seen val)
(queue-put! proc-left val)))))
((clo? gvm-opnd) (scan-opnd (clo-base gvm-opnd)))))
(define (dump-proc p)
(define (scan-code code)
(let ((gvm-instr (code-gvm-instr code)))
(write-gvm-instr gvm-instr port)
(newline port)
(case (gvm-instr-type gvm-instr)
((apply)
(for-each scan-opnd (apply-opnds gvm-instr))
(if (apply-loc gvm-instr) (scan-opnd (apply-loc gvm-instr))))
((copy)
(scan-opnd (copy-opnd gvm-instr))
(scan-opnd (copy-loc gvm-instr)))
((close)
(for-each
(lambda (parms)
(scan-opnd (closure-parms-loc parms))
(for-each scan-opnd (closure-parms-opnds parms)))
(close-parms gvm-instr)))
((ifjump) (for-each scan-opnd (ifjump-opnds gvm-instr)))
((jump) (scan-opnd (jump-opnd gvm-instr)))
(else '()))))
(if (proc-obj-primitive? p)
(display "**** #[primitive " port)
(display "**** #[procedure " port))
(display (proc-obj-name p) port)
(display "] =" port)
(newline port)
(let loop ((l (bbs->code-list (proc-obj-code p)))
(prev-filename "")
(prev-line 0))
(if (pair? l)
(let* ((code (car l))
(instr (code-gvm-instr code))
(src (comment-get (gvm-instr-comment instr) 'source))
(loc (and src (source-locat src)))
(filename
(if (and loc (eq? (vector-ref loc 0) 'file))
(vector-ref loc 1)
prev-filename))
(line (if (and loc (eq? (vector-ref loc 0) 'file))
(vector-ref loc 3)
prev-line)))
(if (or (not (string=? filename prev-filename))
(not (= line prev-line)))
(begin
(display "#line " port)
(display line port)
(if (not (string=? filename prev-filename))
(begin (display " " port) (write filename port)))
(newline port)))
(scan-code code)
(loop (cdr l) filename line))
(newline port))))
(scan-opnd (make-obj proc))
(let loop ()
(if (not (queue-empty? proc-left))
(begin (dump-proc (queue-get! proc-left)) (loop))))))
(define (write-gvm-instr gvm-instr port)
(define (write-closure-parms parms)
(display " " port)
(let ((len (+ 1 (write-gvm-opnd (closure-parms-loc parms) port))))
(display " = (" port)
(let ((len (+ len (+ 4 (write-gvm-lbl (closure-parms-lbl parms) port)))))
(+ len
(write-terminated-opnd-list (closure-parms-opnds parms) port)))))
(define (write-terminated-opnd-list l port)
(let loop ((l l) (len 0))
(if (pair? l)
(let ((opnd (car l)))
(display " " port)
(loop (cdr l) (+ len (+ 1 (write-gvm-opnd opnd port)))))
(begin (display ")" port) (+ len 1)))))
(define (write-param-pattern gvm-instr port)
(let ((len (if (not (= (label-entry-min gvm-instr)
(label-entry-nb-parms gvm-instr)))
(let ((len (write-returning-len
(label-entry-min gvm-instr)
port)))
(display "-" port)
(+ len 1))
0)))
(let ((len (+ len
(write-returning-len
(label-entry-nb-parms gvm-instr)
port))))
(if (label-entry-rest? gvm-instr)
(begin (display "+" port) (+ len 1))
len))))
(define (write-prim-applic prim opnds port)
(display "(" port)
(let ((len (+ 1 (display-returning-len (proc-obj-name prim) port))))
(+ len (write-terminated-opnd-list opnds port))))
(define (write-instr gvm-instr)
(case (gvm-instr-type gvm-instr)
((label)
(let ((len (write-gvm-lbl (label-lbl-num gvm-instr) port)))
(display " " port)
(let ((len (+ len
(+ 1
(write-returning-len
(frame-size (gvm-instr-frame gvm-instr))
port)))))
(case (label-type gvm-instr)
((simple) len)
((entry)
(if (label-entry-closed? gvm-instr)
(begin
(display " closure-entry-point " port)
(+ len (+ 21 (write-param-pattern gvm-instr port))))
(begin
(display " entry-point " port)
(+ len (+ 13 (write-param-pattern gvm-instr port))))))
((return) (display " return-point" port) (+ len 13))
((task-entry) (display " task-entry-point" port) (+ len 17))
((task-return) (display " task-return-point" port) (+ len 18))
(else
(compiler-internal-error
"write-gvm-instr, unknown label type"))))))
((apply)
(display " " port)
(let ((len (+ 2
(if (apply-loc gvm-instr)
(let ((len (write-gvm-opnd
(apply-loc gvm-instr)
port)))
(display " = " port)
(+ len 3))
0))))
(+ len
(write-prim-applic
(apply-prim gvm-instr)
(apply-opnds gvm-instr)
port))))
((copy)
(display " " port)
(let ((len (+ 2 (write-gvm-opnd (copy-loc gvm-instr) port))))
(display " = " port)
(+ len (+ 3 (write-gvm-opnd (copy-opnd gvm-instr) port)))))
((close)
(display " close" port)
(let ((len (+ 7 (write-closure-parms (car (close-parms gvm-instr))))))
(let loop ((l (cdr (close-parms gvm-instr))) (len len))
(if (pair? l)
(let ((x (car l)))
(display "," port)
(loop (cdr l) (+ len (+ 1 (write-closure-parms x)))))
len))))
((ifjump)
(display " if " port)
(let ((len (+ 5
(write-prim-applic
(ifjump-test gvm-instr)
(ifjump-opnds gvm-instr)
port))))
(let ((len (+ len
(if (ifjump-poll? gvm-instr)
(begin (display " jump* " port) 7)
(begin (display " jump " port) 6)))))
(let ((len (+ len
(write-returning-len
(frame-size (gvm-instr-frame gvm-instr))
port))))
(display " " port)
(let ((len (+ len
(+ 1
(write-gvm-lbl (ifjump-true gvm-instr) port)))))
(display " else " port)
(+ len (+ 6 (write-gvm-lbl (ifjump-false gvm-instr) port))))))))
((jump)
(display " " port)
(let ((len (+ 2
(if (jump-poll? gvm-instr)
(begin (display "jump* " port) 6)
(begin (display "jump " port) 5)))))
(let ((len (+ len
(write-returning-len
(frame-size (gvm-instr-frame gvm-instr))
port))))
(display " " port)
(let ((len (+ len
(+ 1 (write-gvm-opnd (jump-opnd gvm-instr) port)))))
(+ len
(if (jump-nb-args gvm-instr)
(begin
(display " " port)
(+ 1
(write-returning-len (jump-nb-args gvm-instr) port)))
0))))))
(else
(compiler-internal-error
"write-gvm-instr, unknown 'gvm-instr':"
gvm-instr))))
(define (spaces n)
(if (> n 0)
(if (> n 7)
(begin (display " " port) (spaces (- n 8)))
(begin (display " " port) (spaces (- n 1))))))
(let ((len (write-instr gvm-instr)))
(spaces (- 40 len))
(display " " port)
(write-frame (gvm-instr-frame gvm-instr) port))
(let ((x (gvm-instr-comment gvm-instr)))
(if x
(let ((y (comment-get x 'text)))
(if y (begin (display " ; " port) (display y port)))))))
(define (write-frame frame port)
(define (write-var var opnd sep)
(display sep port)
(write-gvm-opnd opnd port)
(if var
(begin
(display "=" port)
(cond ((eq? var closure-env-var)
(write (map (lambda (var) (var-name var))
(frame-closed frame))
port))
((eq? var ret-var) (display "#" port))
((temp-var? var) (display "." port))
(else (write (var-name var) port))))))
(define (live? var)
(let ((live (frame-live frame)))
(or (set-member? var live)
(and (eq? var closure-env-var)
(not (set-empty?
(set-intersection
live
(list->set (frame-closed frame)))))))))
(let loop1 ((i 1) (l (reverse (frame-slots frame))) (sep "; "))
(if (pair? l)
(let ((var (car l)))
(write-var (if (live? var) var #f) (make-stk i) sep)
(loop1 (+ i 1) (cdr l) " "))
(let loop2 ((i 0) (l (frame-regs frame)) (sep sep))
(if (pair? l)
(let ((var (car l)))
(if (live? var)
(begin
(write-var var (make-reg i) sep)
(loop2 (+ i 1) (cdr l) " "))
(loop2 (+ i 1) (cdr l) sep))))))))
(define (write-gvm-opnd gvm-opnd port)
(define (write-opnd)
(cond ((reg? gvm-opnd)
(display "+" port)
(+ 1 (write-returning-len (reg-num gvm-opnd) port)))
((stk? gvm-opnd)
(display "-" port)
(+ 1 (write-returning-len (stk-num gvm-opnd) port)))
((glo? gvm-opnd) (write-returning-len (glo-name gvm-opnd) port))
((clo? gvm-opnd)
(let ((len (write-gvm-opnd (clo-base gvm-opnd) port)))
(display "(" port)
(let ((len (+ len
(+ 1
(write-returning-len
(clo-index gvm-opnd)
port)))))
(display ")" port)
(+ len 1))))
((lbl? gvm-opnd) (write-gvm-lbl (lbl-num gvm-opnd) port))
((obj? gvm-opnd)
(display "'" port)
(+ (write-gvm-obj (obj-val gvm-opnd) port) 1))
(else
(compiler-internal-error
"write-gvm-opnd, unknown 'gvm-opnd':"
gvm-opnd))))
(write-opnd))
(define (write-gvm-lbl lbl port)
(display "#" port)
(+ (write-returning-len lbl port) 1))
(define (write-gvm-obj val port)
(cond ((false-object? val) (display "#f" port) 2)
((undef-object? val) (display "#[undefined]" port) 12)
((proc-obj? val)
(if (proc-obj-primitive? val)
(display "#[primitive " port)
(display "#[procedure " port))
(let ((len (display-returning-len (proc-obj-name val) port)))
(display "]" port)
(+ len 13)))
(else (write-returning-len val port))))
(define (virtual.begin!)
(set! *opnd-table* (make-vector opnd-table-size))
(set! *opnd-table-alloc* 0)
'())
(define (virtual.end!) (set! *opnd-table* '()) '())
(define (make-target version name)
(define current-target-version 4)
(if (not (= version current-target-version))
(compiler-internal-error
"make-target, version of target package is not current"
name))
(let ((x (make-vector 11))) (vector-set! x 1 name) x))
(define (target-name x) (vector-ref x 1))
(define (target-begin! x) (vector-ref x 2))
(define (target-begin!-set! x y) (vector-set! x 2 y))
(define (target-end! x) (vector-ref x 3))
(define (target-end!-set! x y) (vector-set! x 3 y))
(define (target-dump x) (vector-ref x 4))
(define (target-dump-set! x y) (vector-set! x 4 y))
(define (target-nb-regs x) (vector-ref x 5))
(define (target-nb-regs-set! x y) (vector-set! x 5 y))
(define (target-prim-info x) (vector-ref x 6))
(define (target-prim-info-set! x y) (vector-set! x 6 y))
(define (target-label-info x) (vector-ref x 7))
(define (target-label-info-set! x y) (vector-set! x 7 y))
(define (target-jump-info x) (vector-ref x 8))
(define (target-jump-info-set! x y) (vector-set! x 8 y))
(define (target-proc-result x) (vector-ref x 9))
(define (target-proc-result-set! x y) (vector-set! x 9 y))
(define (target-task-return x) (vector-ref x 10))
(define (target-task-return-set! x y) (vector-set! x 10 y))
(define targets-loaded '())
(define (get-target name)
(let ((x (assq name targets-loaded)))
(if x (cdr x) (compiler-error "Target package is not available" name))))
(define (put-target targ)
(let* ((name (target-name targ)) (x (assq name targets-loaded)))
(if x
(set-cdr! x targ)
(set! targets-loaded (cons (cons name targ) targets-loaded)))
'()))
(define (default-target)
(if (null? targets-loaded)
(compiler-error "No target package is available")
(car (car targets-loaded))))
(define (select-target! name info-port)
(set! target (get-target name))
((target-begin! target) info-port)
(set! target.dump (target-dump target))
(set! target.nb-regs (target-nb-regs target))
(set! target.prim-info (target-prim-info target))
(set! target.label-info (target-label-info target))
(set! target.jump-info (target-jump-info target))
(set! target.proc-result (target-proc-result target))
(set! target.task-return (target-task-return target))
(set! **not-proc-obj (target.prim-info **not-sym))
'())
(define (unselect-target!) ((target-end! target)) '())
(define target '())
(define target.dump '())
(define target.nb-regs '())
(define target.prim-info '())
(define target.label-info '())
(define target.jump-info '())
(define target.proc-result '())
(define target.task-return '())
(define **not-proc-obj '())
(define (target.specialized-prim-info* name decl)
(let ((x (target.prim-info* name decl)))
(and x ((proc-obj-specialize x) decl))))
(define (target.prim-info* name decl)
(and (if (standard-procedure name decl)
(standard-binding? name decl)
(extended-binding? name decl))
(target.prim-info name)))
(define generic-sym (string->canonical-symbol "GENERIC"))
(define fixnum-sym (string->canonical-symbol "FIXNUM"))
(define flonum-sym (string->canonical-symbol "FLONUM"))
(define-namable-decl generic-sym 'arith)
(define-namable-decl fixnum-sym 'arith)
(define-namable-decl flonum-sym 'arith)
(define (arith-implementation name decls)
(declaration-value 'arith name generic-sym decls))
(define (cf source target-name . opts)
(let* ((dest (file-root source))
(module-name (file-name dest))
(info-port (if (memq 'verbose opts) (current-output-port) #f))
(result (compile-program
(list **include-sym source)
(if target-name target-name (default-target))
opts
module-name
dest
info-port)))
(if (and info-port (not (eq? info-port (current-output-port))))
(close-output-port info-port))
result))
(define (ce source target-name . opts)
(let* ((dest "program")
(module-name "program")
(info-port (if (memq 'verbose opts) (current-output-port) #f))
(result (compile-program
source
(if target-name target-name (default-target))
opts
module-name
dest
info-port)))
(if (and info-port (not (eq? info-port (current-output-port))))
(close-output-port info-port))
result))
(define wrap-program #f)
(set! wrap-program (lambda (program) program))
(define (compile-program program target-name opts module-name dest info-port)
(define (compiler-body)
(if (not (valid-module-name? module-name))
(compiler-error
"Invalid characters in file name (must be a symbol with no \"#\")")
(begin
(ptree.begin! info-port)
(virtual.begin!)
(select-target! target-name info-port)
(parse-program
(list (expression->source (wrap-program program) #f))
(make-global-environment)
module-name
(lambda (lst env c-intf)
(let ((parsed-program
(map (lambda (x) (normalize-parse-tree (car x) (cdr x)))
lst)))
(if (memq 'expansion opts)
(let ((port (current-output-port)))
(display "Expansion:" port)
(newline port)
(let loop ((l parsed-program))
(if (pair? l)
(let ((ptree (car l)))
(pp-expression
(parse-tree->expression ptree)
port)
(loop (cdr l)))))
(newline port)))
(let ((module-init-proc
(compile-parsed-program
module-name
parsed-program
env
c-intf
info-port)))
(if (memq 'report opts) (generate-report env))
(if (memq 'gvm opts)
(let ((gvm-port
(open-output-file (string-append dest ".gvm"))))
(virtual.dump module-init-proc gvm-port)
(close-output-port gvm-port)))
(target.dump module-init-proc dest c-intf opts)
(dump-c-intf module-init-proc dest c-intf)))))
(unselect-target!)
(virtual.end!)
(ptree.end!)
#t)))
(let ((successful (with-exception-handling compiler-body)))
(if info-port
(if successful
(begin
(display "Compilation finished." info-port)
(newline info-port))
(begin
(display "Compilation terminated abnormally." info-port)
(newline info-port))))
successful))
(define (valid-module-name? module-name)
(define (valid-char? c)
(and (not (memv c
'(#\#
#\;
#\(
#\)
#\space
#\[
#\]
#\{
#\}
#\"
#\'
#\`
#\,)))
(not (char-whitespace? c))))
(let ((n (string-length module-name)))
(and (> n 0)
(not (string=? module-name "."))
(not (string->number module-name 10))
(let loop ((i 0))
(if (< i n)
(if (valid-char? (string-ref module-name i)) (loop (+ i 1)) #f)
#t)))))
(define (dump-c-intf module-init-proc dest c-intf)
(let ((decls (c-intf-decls c-intf))
(procs (c-intf-procs c-intf))
(inits (c-intf-inits c-intf)))
(if (or (not (null? decls)) (not (null? procs)) (not (null? inits)))
(let* ((module-name (proc-obj-name module-init-proc))
(filename (string-append dest ".c"))
(port (open-output-file filename)))
(display "/* File: \"" port)
(display filename port)
(display "\", C-interface file produced by Gambit " port)
(display compiler-version port)
(display " */" port)
(newline port)
(display "#define " port)
(display c-id-prefix port)
(display "MODULE_NAME \"" port)
(display module-name port)
(display "\"" port)
(newline port)
(display "#define " port)
(display c-id-prefix port)
(display "MODULE_LINKER " port)
(display c-id-prefix port)
(display (scheme-id->c-id module-name) port)
(newline port)
(display "#define " port)
(display c-id-prefix port)
(display "VERSION \"" port)
(display compiler-version port)
(display "\"" port)
(newline port)
(if (not (null? procs))
(begin
(display "#define " port)
(display c-id-prefix port)
(display "C_PRC_COUNT " port)
(display (length procs) port)
(newline port)))
(display "#include \"gambit.h\"" port)
(newline port)
(display c-id-prefix port)
(display "BEGIN_MODULE" port)
(newline port)
(for-each
(lambda (x)
(let ((scheme-name (vector-ref x 0)))
(display c-id-prefix port)
(display "SUPPLY_PRM(" port)
(display c-id-prefix port)
(display "P_" port)
(display (scheme-id->c-id scheme-name) port)
(display ")" port)
(newline port)))
procs)
(newline port)
(for-each (lambda (x) (display x port) (newline port)) decls)
(if (not (null? procs))
(begin
(for-each
(lambda (x)
(let ((scheme-name (vector-ref x 0))
(c-name (vector-ref x 1))
(arity (vector-ref x 2))
(def (vector-ref x 3)))
(display c-id-prefix port)
(display "BEGIN_C_COD(" port)
(display c-name port)
(display "," port)
(display c-id-prefix port)
(display "P_" port)
(display (scheme-id->c-id scheme-name) port)
(display "," port)
(display arity port)
(display ")" port)
(newline port)
(display "#undef ___ARG1" port)
(newline port)
(display "#define ___ARG1 ___R1" port)
(newline port)
(display "#undef ___ARG2" port)
(newline port)
(display "#define ___ARG2 ___R2" port)
(newline port)
(display "#undef ___ARG3" port)
(newline port)
(display "#define ___ARG3 ___R3" port)
(newline port)
(display "#undef ___RESULT" port)
(newline port)
(display "#define ___RESULT ___R1" port)
(newline port)
(display def port)
(display c-id-prefix port)
(display "END_C_COD" port)
(newline port)))
procs)
(newline port)
(display c-id-prefix port)
(display "BEGIN_C_PRC" port)
(newline port)
(let loop ((i 0) (lst procs))
(if (not (null? lst))
(let* ((x (car lst))
(scheme-name (vector-ref x 0))
(c-name (vector-ref x 1))
(arity (vector-ref x 2)))
(if (= i 0) (display " " port) (display "," port))
(display c-id-prefix port)
(display "DEF_C_PRC(" port)
(display c-name port)
(display "," port)
(display c-id-prefix port)
(display "P_" port)
(display (scheme-id->c-id scheme-name) port)
(display "," port)
(display arity port)
(display ")" port)
(newline port)
(loop (+ i 1) (cdr lst)))))
(display c-id-prefix port)
(display "END_C_PRC" port)
(newline port)))
(newline port)
(display c-id-prefix port)
(display "BEGIN_PRM" port)
(newline port)
(for-each (lambda (x) (display x port) (newline port)) inits)
(display c-id-prefix port)
(display "END_PRM" port)
(newline port)
(close-output-port port)))))
(define (generate-report env)
(let ((vars (sort-variables (env-global-variables env)))
(decl (env-declarations env)))
(define (report title pred? vars wrote-something?)
(if (pair? vars)
(let ((var (car vars)))
(if (pred? var)
(begin
(if (not wrote-something?)
(begin (display " ") (display title) (newline)))
(let loop1 ((l (var-refs var)) (r? #f) (c? #f))
(if (pair? l)
(let* ((x (car l)) (y (node-parent x)))
(if (and y (app? y) (eq? x (app-oper y)))
(loop1 (cdr l) r? #t)
(loop1 (cdr l) #t c?)))
(let loop2 ((l (var-sets var)) (d? #f) (a? #f))
(if (pair? l)
(if (set? (car l))
(loop2 (cdr l) d? #t)
(loop2 (cdr l) #t a?))
(begin
(display " [")
(if d? (display "D") (display " "))
(if a? (display "A") (display " "))
(if r? (display "R") (display " "))
(if c? (display "C") (display " "))
(display "] ")
(display (var-name var))
(newline))))))
(report title pred? (cdr vars) #t))
(cons (car vars)
(report title pred? (cdr vars) wrote-something?))))
(begin (if wrote-something? (newline)) '())))
(display "Global variable usage:")
(newline)
(newline)
(report "OTHERS"
(lambda (x) #t)
(report "EXTENDED"
(lambda (x) (target.prim-info (var-name x)))
(report "STANDARD"
(lambda (x) (standard-procedure (var-name x) decl))
vars
#f)
#f)
#f)))
(define (compile-parsed-program module-name program env c-intf info-port)
(if info-port (display "Compiling:" info-port))
(set! trace-indentation 0)
(set! *bbs* (make-bbs))
(set! *global-env* env)
(set! proc-queue '())
(set! constant-vars '())
(set! known-procs '())
(restore-context (make-context 0 '() (list ret-var) '() (entry-poll) #f))
(let* ((entry-lbl (bbs-new-lbl! *bbs*))
(body-lbl (bbs-new-lbl! *bbs*))
(frame (current-frame ret-var-set))
(comment (if (null? program) #f (source-comment (car program)))))
(bbs-entry-lbl-num-set! *bbs* entry-lbl)
(set! entry-bb
(make-bb (make-label-entry entry-lbl 0 0 #f #f frame comment) *bbs*))
(bb-put-branch! entry-bb (make-jump (make-lbl body-lbl) #f #f frame #f))
(set! *bb* (make-bb (make-label-simple body-lbl frame comment) *bbs*))
(let loop1 ((l (c-intf-procs c-intf)))
(if (not (null? l))
(let* ((x (car l))
(name (vector-ref x 0))
(sym (string->canonical-symbol name))
(var (env-lookup-global-var *global-env* sym)))
(add-constant-var
var
(make-obj (make-proc-obj name #t #f 0 #t '() '(#f))))
(loop1 (cdr l)))))
(let loop2 ((l program))
(if (not (null? l))
(let ((node (car l)))
(if (def? node)
(let* ((var (def-var node)) (val (global-val var)))
(if (and val (prc? val))
(add-constant-var
var
(make-obj
(make-proc-obj
(symbol->string (var-name var))
#t
#f
(call-pattern val)
#t
'()
'(#f)))))))
(loop2 (cdr l)))))
(let loop3 ((l program))
(if (null? l)
(let ((ret-opnd (var->opnd ret-var)))
(seal-bb #t 'return)
(dealloc-slots nb-slots)
(bb-put-branch!
*bb*
(make-jump ret-opnd #f #f (current-frame (set-empty)) #f)))
(let ((node (car l)))
(if (def? node)
(begin
(gen-define (def-var node) (def-val node) info-port)
(loop3 (cdr l)))
(if (null? (cdr l))
(gen-node node ret-var-set 'tail)
(begin
(gen-node node ret-var-set 'need)
(loop3 (cdr l))))))))
(let loop4 ()
(if (pair? proc-queue)
(let ((x (car proc-queue)))
(set! proc-queue (cdr proc-queue))
(gen-proc (car x) (cadr x) (caddr x) info-port)
(trace-unindent info-port)
(loop4))))
(if info-port (begin (newline info-port) (newline info-port)))
(bbs-purify! *bbs*)
(let ((proc (make-proc-obj
(string-append "#!" module-name)
#t
*bbs*
'(0)
#t
'()
'(#f))))
(set! *bb* '())
(set! *bbs* '())
(set! *global-env* '())
(set! proc-queue '())
(set! constant-vars '())
(set! known-procs '())
(clear-context)
proc)))
(define *bb* '())
(define *bbs* '())
(define *global-env* '())
(define proc-queue '())
(define constant-vars '())
(define known-procs '())
(define trace-indentation '())
(define (trace-indent info-port)
(set! trace-indentation (+ trace-indentation 1))
(if info-port
(begin
(newline info-port)
(let loop ((i trace-indentation))
(if (> i 0) (begin (display " " info-port) (loop (- i 1))))))))
(define (trace-unindent info-port)
(set! trace-indentation (- trace-indentation 1)))
(define (gen-define var node info-port)
(if (prc? node)
(let* ((p-bbs *bbs*)
(p-bb *bb*)
(p-proc-queue proc-queue)
(p-known-procs known-procs)
(p-context (current-context))
(bbs (make-bbs))
(lbl1 (bbs-new-lbl! bbs))
(lbl2 (bbs-new-lbl! bbs))
(context (entry-context node '()))
(frame (context->frame
context
(set-union (free-variables (prc-body node)) ret-var-set)))
(bb1 (make-bb (make-label-entry
lbl1
(length (prc-parms node))
(prc-min node)
(prc-rest node)
#f
frame
(source-comment node))
bbs))
(bb2 (make-bb (make-label-simple lbl2 frame (source-comment node))
bbs)))
(define (do-body)
(gen-proc node bb2 context info-port)
(let loop ()
(if (pair? proc-queue)
(let ((x (car proc-queue)))
(set! proc-queue (cdr proc-queue))
(gen-proc (car x) (cadr x) (caddr x) info-port)
(trace-unindent info-port)
(loop))))
(trace-unindent info-port)
(bbs-purify! *bbs*))
(context-entry-bb-set! context bb1)
(bbs-entry-lbl-num-set! bbs lbl1)
(bb-put-branch! bb1 (make-jump (make-lbl lbl2) #f #f frame #f))
(set! *bbs* bbs)
(set! proc-queue '())
(set! known-procs '())
(if (constant-var? var)
(let-constant-var
var
(make-lbl lbl1)
(lambda () (add-known-proc lbl1 node) (do-body)))
(do-body))
(set! *bbs* p-bbs)
(set! *bb* p-bb)
(set! proc-queue p-proc-queue)
(set! known-procs p-known-procs)
(restore-context p-context)
(let* ((x (assq var constant-vars))
(proc (if x
(let ((p (cdr x)))
(proc-obj-code-set! (obj-val p) bbs)
p)
(make-obj
(make-proc-obj
(symbol->string (var-name var))
#f
bbs
(call-pattern node)
#t
'()
'(#f))))))
(put-copy
proc
(make-glo (var-name var))
#f
ret-var-set
(source-comment node))))
(put-copy
(gen-node node ret-var-set 'need)
(make-glo (var-name var))
#f
ret-var-set
(source-comment node))))
(define (call-pattern node)
(make-pattern (prc-min node) (length (prc-parms node)) (prc-rest node)))
(define (make-context nb-slots slots regs closed poll entry-bb)
(vector nb-slots slots regs closed poll entry-bb))
(define (context-nb-slots x) (vector-ref x 0))
(define (context-slots x) (vector-ref x 1))
(define (context-regs x) (vector-ref x 2))
(define (context-closed x) (vector-ref x 3))
(define (context-poll x) (vector-ref x 4))
(define (context-entry-bb x) (vector-ref x 5))
(define (context-entry-bb-set! x y) (vector-set! x 5 y))
(define nb-slots '())
(define slots '())
(define regs '())
(define closed '())
(define poll '())
(define entry-bb '())
(define (restore-context context)
(set! nb-slots (context-nb-slots context))
(set! slots (context-slots context))
(set! regs (context-regs context))
(set! closed (context-closed context))
(set! poll (context-poll context))
(set! entry-bb (context-entry-bb context)))
(define (clear-context)
(restore-context (make-context '() '() '() '() '() '())))
(define (current-context)
(make-context nb-slots slots regs closed poll entry-bb))
(define (current-frame live) (make-frame nb-slots slots regs closed live))
(define (context->frame context live)
(make-frame
(context-nb-slots context)
(context-slots context)
(context-regs context)
(context-closed context)
live))
(define (make-poll since-entry? delta) (cons since-entry? delta))
(define (poll-since-entry? x) (car x))
(define (poll-delta x) (cdr x))
(define (entry-poll) (make-poll #f (- poll-period poll-head)))
(define (return-poll poll)
(let ((delta (poll-delta poll)))
(make-poll (poll-since-entry? poll) (+ poll-head (max delta poll-tail)))))
(define (poll-merge poll other-poll)
(make-poll
(or (poll-since-entry? poll) (poll-since-entry? other-poll))
(max (poll-delta poll) (poll-delta other-poll))))
(define poll-period #f)
(set! poll-period 90)
(define poll-head #f)
(set! poll-head 15)
(define poll-tail #f)
(set! poll-tail 15)
(define (entry-context proc closed)
(define (empty-vars-list n)
(if (> n 0) (cons empty-var (empty-vars-list (- n 1))) '()))
(let* ((parms (prc-parms proc))
(pc (target.label-info
(prc-min proc)
(length parms)
(prc-rest proc)
(not (null? closed))))
(fs (pcontext-fs pc))
(slots-list (empty-vars-list fs))
(regs-list (empty-vars-list target.nb-regs)))
(define (assign-var-to-loc var loc)
(let ((x (cond ((reg? loc)
(let ((i (reg-num loc)))
(if (<= i target.nb-regs)
(nth-after regs-list i)
(compiler-internal-error
"entry-context, reg out of bound in back-end's pcontext"))))
((stk? loc)
(let ((i (stk-num loc)))
(if (<= i fs)
(nth-after slots-list (- fs i))
(compiler-internal-error
"entry-context, stk out of bound in back-end's pcontext"))))
(else
(compiler-internal-error
"entry-context, loc other than reg or stk in back-end's pcontext")))))
(if (eq? (car x) empty-var)
(set-car! x var)
(compiler-internal-error
"entry-context, duplicate location in back-end's pcontext"))))
(let loop ((l (pcontext-map pc)))
(if (not (null? l))
(let* ((couple (car l)) (name (car couple)) (loc (cdr couple)))
(cond ((eq? name 'return) (assign-var-to-loc ret-var loc))
((eq? name 'closure-env)
(assign-var-to-loc closure-env-var loc))
(else (assign-var-to-loc (list-ref parms (- name 1)) loc)))
(loop (cdr l)))))
(make-context fs slots-list regs-list closed (entry-poll) #f)))
(define (get-var opnd)
(cond ((glo? opnd) (env-lookup-global-var *global-env* (glo-name opnd)))
((reg? opnd) (list-ref regs (reg-num opnd)))
((stk? opnd) (list-ref slots (- nb-slots (stk-num opnd))))
(else
(compiler-internal-error
"get-var, location must be global, register or stack slot"))))
(define (put-var opnd new)
(define (put-v opnd new)
(cond ((reg? opnd) (set! regs (replace-nth regs (reg-num opnd) new)))
((stk? opnd)
(set! slots (replace-nth slots (- nb-slots (stk-num opnd)) new)))
(else
(compiler-internal-error
"put-var, location must be register or stack slot, for var:"
(var-name new)))))
(if (eq? new ret-var)
(let ((x (var->opnd ret-var))) (and x (put-v x empty-var))))
(put-v opnd new))
(define (flush-regs) (set! regs '()))
(define (push-slot)
(set! nb-slots (+ nb-slots 1))
(set! slots (cons empty-var slots)))
(define (dealloc-slots n)
(set! nb-slots (- nb-slots n))
(set! slots (nth-after slots n)))
(define (pop-slot) (dealloc-slots 1))
(define (replace-nth l i v)
(if (null? l)
(if (= i 0) (list v) (cons empty-var (replace-nth l (- i 1) v)))
(if (= i 0)
(cons v (cdr l))
(cons (car l) (replace-nth (cdr l) (- i 1) v)))))
(define (live-vars live)
(if (not (set-empty? (set-intersection live (list->set closed))))
(set-adjoin live closure-env-var)
live))
(define (dead-slots live)
(let ((live-v (live-vars live)))
(define (loop s l i)
(cond ((null? l) (list->set (reverse s)))
((set-member? (car l) live-v) (loop s (cdr l) (- i 1)))
(else (loop (cons i s) (cdr l) (- i 1)))))
(loop '() slots nb-slots)))
(define (live-slots live)
(let ((live-v (live-vars live)))
(define (loop s l i)
(cond ((null? l) (list->set (reverse s)))
((set-member? (car l) live-v) (loop (cons i s) (cdr l) (- i 1)))
(else (loop s (cdr l) (- i 1)))))
(loop '() slots nb-slots)))
(define (dead-regs live)
(let ((live-v (live-vars live)))
(define (loop s l i)
(cond ((>= i target.nb-regs) (list->set (reverse s)))
((null? l) (loop (cons i s) l (+ i 1)))
((and (set-member? (car l) live-v) (not (memq (car l) slots)))
(loop s (cdr l) (+ i 1)))
(else (loop (cons i s) (cdr l) (+ i 1)))))
(loop '() regs 0)))
(define (live-regs live)
(let ((live-v (live-vars live)))
(define (loop s l i)
(cond ((null? l) (list->set (reverse s)))
((and (set-member? (car l) live-v) (not (memq (car l) slots)))
(loop (cons i s) (cdr l) (+ i 1)))
(else (loop s (cdr l) (+ i 1)))))
(loop '() regs 0)))
(define (lowest-dead-slot live)
(make-stk (or (lowest (dead-slots live)) (+ nb-slots 1))))
(define (highest-live-slot live) (make-stk (or (highest (live-slots live)) 0)))
(define (lowest-dead-reg live)
(let ((x (lowest (set-remove (dead-regs live) 0)))) (if x (make-reg x) #f)))
(define (highest-dead-reg live)
(let ((x (highest (dead-regs live)))) (if x (make-reg x) #f)))
(define (highest set) (if (set-empty? set) #f (apply max (set->list set))))
(define (lowest set) (if (set-empty? set) #f (apply min (set->list set))))
(define (above set n) (set-keep (lambda (x) (> x n)) set))
(define (below set n) (set-keep (lambda (x) (< x n)) set))
(define (var->opnd var)
(let ((x (assq var constant-vars)))
(if x
(cdr x)
(if (global? var)
(make-glo (var-name var))
(let ((n (pos-in-list var regs)))
(if n
(make-reg n)
(let ((n (pos-in-list var slots)))
(if n
(make-stk (- nb-slots n))
(let ((n (pos-in-list var closed)))
(if n
(make-clo (var->opnd closure-env-var) (+ n 1))
(compiler-internal-error
"var->opnd, variable is not accessible:"
(var-name var))))))))))))
(define (source-comment node)
(let ((x (make-comment))) (comment-put! x 'source (node-source node)) x))
(define (sort-variables lst)
(sort-list
lst
(lambda (x y)
(string<? (symbol->string (var-name x)) (symbol->string (var-name y))))))
(define (add-constant-var var opnd)
(set! constant-vars (cons (cons var opnd) constant-vars)))
(define (let-constant-var var opnd thunk)
(let* ((x (assq var constant-vars)) (temp (cdr x)))
(set-cdr! x opnd)
(thunk)
(set-cdr! x temp)))
(define (constant-var? var) (assq var constant-vars))
(define (not-constant-var? var) (not (constant-var? var)))
(define (add-known-proc label proc)
(set! known-procs (cons (cons label proc) known-procs)))
(define (gen-proc proc bb context info-port)
(trace-indent info-port)
(if info-port
(if (prc-name proc)
(display (prc-name proc) info-port)
(display "\"unknown\"" info-port)))
(let ((lbl (bb-lbl-num bb))
(live (set-union (free-variables (prc-body proc)) ret-var-set)))
(set! *bb* bb)
(restore-context context)
(gen-node (prc-body proc) ret-var-set 'tail)))
(define (schedule-gen-proc proc closed-list)
(let* ((lbl1 (bbs-new-lbl! *bbs*))
(lbl2 (bbs-new-lbl! *bbs*))
(context (entry-context proc closed-list))
(frame (context->frame
context
(set-union (free-variables (prc-body proc)) ret-var-set)))
(bb1 (make-bb (make-label-entry
lbl1
(length (prc-parms proc))
(prc-min proc)
(prc-rest proc)
(not (null? closed-list))
frame
(source-comment proc))
*bbs*))
(bb2 (make-bb (make-label-simple lbl2 frame (source-comment proc))
*bbs*)))
(context-entry-bb-set! context bb1)
(bb-put-branch! bb1 (make-jump (make-lbl lbl2) #f #f frame #f))
(set! proc-queue (cons (list proc bb2 context) proc-queue))
(make-lbl lbl1)))
(define (gen-node node live why)
(cond ((cst? node) (gen-return (make-obj (cst-val node)) why node))
((ref? node)
(let* ((var (ref-var node)) (name (var-name var)))
(gen-return
(cond ((eq? why 'side) (make-obj undef-object))
((global? var)
(let ((prim (target.prim-info* name (node-decl node))))
(if prim (make-obj prim) (var->opnd var))))
(else (var->opnd var)))
why
node)))
((set? node)
(let* ((src (gen-node
(set-val node)
(set-adjoin live (set-var node))
'keep))
(dst (var->opnd (set-var node))))
(put-copy src dst #f live (source-comment node))
(gen-return (make-obj undef-object) why node)))
((def? node)
(compiler-internal-error
"gen-node, 'def' node not at root of parse tree"))
((tst? node) (gen-tst node live why))
((conj? node) (gen-conj/disj node live why))
((disj? node) (gen-conj/disj node live why))
((prc? node)
(let* ((closed (not-constant-closed-vars node))
(closed-list (sort-variables (set->list closed)))
(proc-lbl (schedule-gen-proc node closed-list)))
(let ((opnd (if (null? closed-list)
(begin
(add-known-proc (lbl-num proc-lbl) node)
proc-lbl)
(begin
(dealloc-slots
(- nb-slots
(stk-num (highest-live-slot
(set-union closed live)))))
(push-slot)
(let ((slot (make-stk nb-slots))
(var (make-temp-var 'closure)))
(put-var slot var)
(bb-put-non-branch!
*bb*
(make-close
(list (make-closure-parms
slot
(lbl-num proc-lbl)
(map var->opnd closed-list)))
(current-frame (set-adjoin live var))
(source-comment node)))
slot)))))
(gen-return opnd why node))))
((app? node) (gen-call node live why))
((fut? node) (gen-fut node live why))
(else
(compiler-internal-error
"gen-node, unknown parse tree node type:"
node))))
(define (gen-return opnd why node)
(cond ((eq? why 'tail)
(let ((var (make-temp-var 'result)))
(put-copy
opnd
target.proc-result
var
ret-var-set
(source-comment node))
(let ((ret-opnd (var->opnd ret-var)))
(seal-bb (intrs-enabled? (node-decl node)) 'return)
(dealloc-slots nb-slots)
(bb-put-branch!
*bb*
(make-jump
ret-opnd
#f
#f
(current-frame (set-singleton var))
#f)))))
(else opnd)))
(define (not-constant-closed-vars val)
(set-keep not-constant-var? (free-variables val)))
(define (predicate node live cont)
(define (cont* true-lbl false-lbl) (cont false-lbl true-lbl))
(define (generic-true-test)
(predicate-test node live **not-proc-obj '0 (list node) cont*))
(cond ((or (conj? node) (disj? node)) (predicate-conj/disj node live cont))
((app? node)
(let ((proc (node->proc (app-oper node))))
(if proc
(let ((spec (specialize-for-call proc (node-decl node))))
(if (and (proc-obj-test spec)
(nb-args-conforms?
(length (app-args node))
(proc-obj-call-pat spec)))
(if (eq? spec **not-proc-obj)
(predicate (car (app-args node)) live cont*)
(predicate-test
node
live
spec
(proc-obj-strict-pat proc)
(app-args node)
cont))
(generic-true-test)))
(generic-true-test))))
(else (generic-true-test))))
(define (predicate-conj/disj node live cont)
(let* ((pre (if (conj? node) (conj-pre node) (disj-pre node)))
(alt (if (conj? node) (conj-alt node) (disj-alt node)))
(alt-live (set-union live (free-variables alt))))
(predicate
pre
alt-live
(lambda (true-lbl false-lbl)
(let ((pre-context (current-context)))
(set! *bb*
(make-bb (make-label-simple
(if (conj? node) true-lbl false-lbl)
(current-frame alt-live)
(source-comment alt))
*bbs*))
(predicate
alt
live
(lambda (true-lbl2 false-lbl2)
(let ((alt-context (current-context)))
(restore-context pre-context)
(set! *bb*
(make-bb (make-label-simple
(if (conj? node) false-lbl true-lbl)
(current-frame live)
(source-comment alt))
*bbs*))
(merge-contexts-and-seal-bb
alt-context
live
(intrs-enabled? (node-decl node))
'internal
(source-comment node))
(bb-put-branch!
*bb*
(make-jump
(make-lbl (if (conj? node) false-lbl2 true-lbl2))
#f
#f
(current-frame live)
#f))
(cont true-lbl2 false-lbl2)))))))))
(define (predicate-test node live test strict-pat args cont)
(let loop ((args* args) (liv live) (vars* '()))
(if (not (null? args*))
(let* ((needed (vals-live-vars liv (cdr args*)))
(var (save-var
(gen-node (car args*) needed 'need)
(make-temp-var 'predicate)
needed
(source-comment (car args*)))))
(loop (cdr args*) (set-adjoin liv var) (cons var vars*)))
(let* ((true-lbl (bbs-new-lbl! *bbs*))
(false-lbl (bbs-new-lbl! *bbs*)))
(seal-bb (intrs-enabled? (node-decl node)) 'internal)
(bb-put-branch!
*bb*
(make-ifjump
test
(map var->opnd (reverse vars*))
true-lbl
false-lbl
#f
(current-frame live)
(source-comment node)))
(cont true-lbl false-lbl)))))
(define (gen-tst node live why)
(let ((pre (tst-pre node)) (con (tst-con node)) (alt (tst-alt node)))
(predicate
pre
(set-union live (free-variables con) (free-variables alt))
(lambda (true-lbl false-lbl)
(let ((pre-context (current-context))
(true-bb (make-bb (make-label-simple
true-lbl
(current-frame
(set-union live (free-variables con)))
(source-comment con))
*bbs*))
(false-bb
(make-bb (make-label-simple
false-lbl
(current-frame (set-union live (free-variables alt)))
(source-comment alt))
*bbs*)))
(set! *bb* true-bb)
(let ((con-opnd (gen-node con live why)))
(if (eq? why 'tail)
(begin
(restore-context pre-context)
(set! *bb* false-bb)
(gen-node alt live why))
(let* ((result-var (make-temp-var 'result))
(live-after (set-adjoin live result-var)))
(save-opnd-to-reg
con-opnd
target.proc-result
result-var
live
(source-comment con))
(let ((con-context (current-context)) (con-bb *bb*))
(restore-context pre-context)
(set! *bb* false-bb)
(save-opnd-to-reg
(gen-node alt live why)
target.proc-result
result-var
live
(source-comment alt))
(let ((next-lbl (bbs-new-lbl! *bbs*)) (alt-bb *bb*))
(if (> (context-nb-slots con-context) nb-slots)
(begin
(seal-bb (intrs-enabled? (node-decl node))
'internal)
(let ((alt-context (current-context)))
(restore-context con-context)
(set! *bb* con-bb)
(merge-contexts-and-seal-bb
alt-context
live-after
(intrs-enabled? (node-decl node))
'internal
(source-comment node))))
(let ((alt-context (current-context)))
(restore-context con-context)
(set! *bb* con-bb)
(seal-bb (intrs-enabled? (node-decl node))
'internal)
(let ((con-context* (current-context)))
(restore-context alt-context)
(set! *bb* alt-bb)
(merge-contexts-and-seal-bb
con-context*
live-after
(intrs-enabled? (node-decl node))
'internal
(source-comment node)))))
(let ((frame (current-frame live-after)))
(bb-put-branch!
con-bb
(make-jump (make-lbl next-lbl) #f #f frame #f))
(bb-put-branch!
alt-bb
(make-jump (make-lbl next-lbl) #f #f frame #f))
(set! *bb*
(make-bb (make-label-simple
next-lbl
frame
(source-comment node))
*bbs*))
target.proc-result)))))))))))
(define (nb-args-conforms? n call-pat) (pattern-member? n call-pat))
(define (merge-contexts-and-seal-bb other-context live poll? where comment)
(let ((live-v (live-vars live))
(other-nb-slots (context-nb-slots other-context))
(other-regs (context-regs other-context))
(other-slots (context-slots other-context))
(other-poll (context-poll other-context))
(other-entry-bb (context-entry-bb other-context)))
(let loop1 ((i (- target.nb-regs 1)))
(if (>= i 0)
(let ((other-var (reg->var other-regs i)) (var (reg->var regs i)))
(if (and (not (eq? var other-var)) (set-member? other-var live-v))
(let ((r (make-reg i)))
(put-var r empty-var)
(if (not (or (not (set-member? var live-v))
(memq var regs)
(memq var slots)))
(let ((top (make-stk (+ nb-slots 1))))
(put-copy r top var live-v comment)))
(put-copy (var->opnd other-var) r other-var live-v comment)))
(loop1 (- i 1)))))
(let loop2 ((i 1))
(if (<= i other-nb-slots)
(let ((other-var (stk->var other-slots i)) (var (stk->var slots i)))
(if (and (not (eq? var other-var)) (set-member? other-var live-v))
(let ((s (make-stk i)))
(if (<= i nb-slots) (put-var s empty-var))
(if (not (or (not (set-member? var live-v))
(memq var regs)
(memq var slots)))
(let ((top (make-stk (+ nb-slots 1))))
(put-copy s top var live-v comment)))
(put-copy (var->opnd other-var) s other-var live-v comment))
(if (> i nb-slots)
(let ((top (make-stk (+ nb-slots 1))))
(put-copy
(make-obj undef-object)
top
empty-var
live-v
comment))))
(loop2 (+ i 1)))))
(dealloc-slots (- nb-slots other-nb-slots))
(let loop3 ((i (- target.nb-regs 1)))
(if (>= i 0)
(let ((other-var (reg->var other-regs i)) (var (reg->var regs i)))
(if (not (eq? var other-var)) (put-var (make-reg i) empty-var))
(loop3 (- i 1)))))
(let loop4 ((i 1))
(if (<= i other-nb-slots)
(let ((other-var (stk->var other-slots i)) (var (stk->var slots i)))
(if (not (eq? var other-var)) (put-var (make-stk i) empty-var))
(loop4 (+ i 1)))))
(seal-bb poll? where)
(set! poll (poll-merge poll other-poll))
(if (not (eq? entry-bb other-entry-bb))
(compiler-internal-error
"merge-contexts-and-seal-bb, entry-bb's do not agree"))))
(define (seal-bb poll? where)
(define (my-last-pair l) (if (pair? (cdr l)) (my-last-pair (cdr l)) l))
(define (poll-at split-point)
(let loop ((i 0) (l1 (bb-non-branch-instrs *bb*)) (l2 '()))
(if (< i split-point)
(loop (+ i 1) (cdr l1) (cons (car l1) l2))
(let* ((label-instr (bb-label-instr *bb*))
(non-branch-instrs1 (reverse l2))
(non-branch-instrs2 l1)
(frame (gvm-instr-frame
(car (my-last-pair
(cons label-instr non-branch-instrs1)))))
(prec-bb (make-bb label-instr *bbs*))
(new-lbl (bbs-new-lbl! *bbs*)))
(bb-non-branch-instrs-set! prec-bb non-branch-instrs1)
(bb-put-branch!
prec-bb
(make-jump (make-lbl new-lbl) #f #t frame #f))
(bb-label-instr-set! *bb* (make-label-simple new-lbl frame #f))
(bb-non-branch-instrs-set! *bb* non-branch-instrs2)
(set! poll (make-poll #t 0))))))
(define (poll-at-end) (poll-at (length (bb-non-branch-instrs *bb*))))
(define (impose-polling-constraints)
(let ((n (+ (length (bb-non-branch-instrs *bb*)) 1))
(delta (poll-delta poll)))
(if (> (+ delta n) poll-period)
(begin
(poll-at (max (- poll-period delta) 0))
(impose-polling-constraints)))))
(if poll? (impose-polling-constraints))
(let* ((n (+ (length (bb-non-branch-instrs *bb*)) 1))
(delta (+ (poll-delta poll) n))
(since-entry? (poll-since-entry? poll)))
(if (and poll?
(case where
((call) (> delta (- poll-period poll-head)))
((tail-call) (> delta poll-tail))
((return) (and since-entry? (> delta (+ poll-head poll-tail))))
((internal) #f)
(else
(compiler-internal-error "seal-bb, unknown 'where':" where))))
(poll-at-end)
(set! poll (make-poll since-entry? delta)))))
(define (reg->var regs i)
(cond ((null? regs) '())
((> i 0) (reg->var (cdr regs) (- i 1)))
(else (car regs))))
(define (stk->var slots i)
(let ((j (- (length slots) i))) (if (< j 0) '() (list-ref slots j))))
(define (gen-conj/disj node live why)
(let ((pre (if (conj? node) (conj-pre node) (disj-pre node)))
(alt (if (conj? node) (conj-alt node) (disj-alt node))))
(let ((needed (set-union live (free-variables alt)))
(bool? (boolean-value? pre))
(predicate-var (make-temp-var 'predicate)))
(define (general-predicate node live cont)
(let* ((con-lbl (bbs-new-lbl! *bbs*)) (alt-lbl (bbs-new-lbl! *bbs*)))
(save-opnd-to-reg
(gen-node pre live 'need)
target.proc-result
predicate-var
live
(source-comment pre))
(seal-bb (intrs-enabled? (node-decl node)) 'internal)
(bb-put-branch!
*bb*
(make-ifjump
**not-proc-obj
(list target.proc-result)
alt-lbl
con-lbl
#f
(current-frame (set-adjoin live predicate-var))
(source-comment node)))
(cont con-lbl alt-lbl)))
(define (alternative con-lbl alt-lbl)
(let* ((pre-context (current-context))
(result-var (make-temp-var 'result))
(con-live (if bool? live (set-adjoin live predicate-var)))
(alt-live (set-union live (free-variables alt)))
(con-bb (make-bb (make-label-simple
con-lbl
(current-frame con-live)
(source-comment alt))
*bbs*))
(alt-bb (make-bb (make-label-simple
alt-lbl
(current-frame alt-live)
(source-comment alt))
*bbs*)))
(if bool?
(begin
(set! *bb* con-bb)
(save-opnd-to-reg
(make-obj (if (conj? node) false-object #t))
target.proc-result
result-var
live
(source-comment node)))
(put-var (var->opnd predicate-var) result-var))
(let ((con-context (current-context)))
(set! *bb* alt-bb)
(restore-context pre-context)
(let ((alt-opnd (gen-node alt live why)))
(if (eq? why 'tail)
(begin
(restore-context con-context)
(set! *bb* con-bb)
(let ((ret-opnd (var->opnd ret-var))
(result-set (set-singleton result-var)))
(seal-bb (intrs-enabled? (node-decl node)) 'return)
(dealloc-slots nb-slots)
(bb-put-branch!
*bb*
(make-jump
ret-opnd
#f
#f
(current-frame result-set)
#f))))
(let ((alt-context* (current-context)) (alt-bb* *bb*))
(restore-context con-context)
(set! *bb* con-bb)
(seal-bb (intrs-enabled? (node-decl node)) 'internal)
(let ((con-context* (current-context))
(next-lbl (bbs-new-lbl! *bbs*)))
(restore-context alt-context*)
(set! *bb* alt-bb*)
(save-opnd-to-reg
alt-opnd
target.proc-result
result-var
live
(source-comment alt))
(merge-contexts-and-seal-bb
con-context*
(set-adjoin live result-var)
(intrs-enabled? (node-decl node))
'internal
(source-comment node))
(let ((frame (current-frame
(set-adjoin live result-var))))
(bb-put-branch!
*bb*
(make-jump (make-lbl next-lbl) #f #f frame #f))
(bb-put-branch!
con-bb
(make-jump (make-lbl next-lbl) #f #f frame #f))
(set! *bb*
(make-bb (make-label-simple
next-lbl
frame
(source-comment node))
*bbs*))
target.proc-result))))))))
((if bool? predicate general-predicate)
pre
needed
(lambda (true-lbl false-lbl)
(if (conj? node)
(alternative false-lbl true-lbl)
(alternative true-lbl false-lbl)))))))
(define (gen-call node live why)
(let* ((oper (app-oper node)) (args (app-args node)) (nb-args (length args)))
(if (and (prc? oper)
(not (prc-rest oper))
(= (length (prc-parms oper)) nb-args))
(gen-let (prc-parms oper) args (prc-body oper) live why)
(if (inlinable-app? node)
(let ((eval-order (arg-eval-order #f args))
(vars (map (lambda (x) (cons x #f)) args)))
(let loop ((l eval-order) (liv live))
(if (not (null? l))
(let* ((needed (vals-live-vars liv (map car (cdr l))))
(arg (car (car l)))
(pos (cdr (car l)))
(var (save-var
(gen-node arg needed 'need)
(make-temp-var pos)
needed
(source-comment arg))))
(set-cdr! (assq arg vars) var)
(loop (cdr l) (set-adjoin liv var)))
(let ((loc (if (eq? why 'side)
(make-reg 0)
(or (lowest-dead-reg live)
(lowest-dead-slot live)))))
(if (and (stk? loc) (> (stk-num loc) nb-slots))
(push-slot))
(let* ((args (map var->opnd (map cdr vars)))
(var (make-temp-var 'result))
(proc (node->proc oper))
(strict-pat (proc-obj-strict-pat proc)))
(if (not (eq? why 'side)) (put-var loc var))
(bb-put-non-branch!
*bb*
(make-apply
(specialize-for-call proc (node-decl node))
args
(if (eq? why 'side) #f loc)
(current-frame
(if (eq? why 'side) live (set-adjoin live var)))
(source-comment node)))
(gen-return loc why node))))))
(let* ((calling-local-proc?
(and (ref? oper)
(let ((opnd (var->opnd (ref-var oper))))
(and (lbl? opnd)
(let ((x (assq (lbl-num opnd) known-procs)))
(and x
(let ((proc (cdr x)))
(and (not (prc-rest proc))
(= (prc-min proc) nb-args)
(= (length (prc-parms proc))
nb-args)
(lbl-num opnd)))))))))
(jstate (get-jump-state
args
(if calling-local-proc?
(target.label-info nb-args nb-args #f #f)
(target.jump-info nb-args))))
(in-stk (jump-state-in-stk jstate))
(in-reg (jump-state-in-reg jstate))
(eval-order
(arg-eval-order (if calling-local-proc? #f oper) in-reg))
(live-after
(if (eq? why 'tail) (set-remove live ret-var) live))
(live-for-regs (args-live-vars live eval-order))
(return-lbl (if (eq? why 'tail) #f (bbs-new-lbl! *bbs*))))
(save-regs
(live-regs live-after)
(stk-live-vars live-for-regs in-stk why)
(source-comment node))
(let ((frame-start (stk-num (highest-live-slot live-after))))
(let loop1 ((l in-stk) (liv live-after) (i (+ frame-start 1)))
(if (not (null? l))
(let ((arg (car l))
(slot (make-stk i))
(needed (set-union
(stk-live-vars liv (cdr l) why)
live-for-regs)))
(if arg
(let ((var (if (and (eq? arg 'return)
(eq? why 'tail))
ret-var
(make-temp-var (- frame-start i)))))
(save-opnd-to-stk
(if (eq? arg 'return)
(if (eq? why 'tail)
(var->opnd ret-var)
(make-lbl return-lbl))
(gen-node arg needed 'need))
slot
var
needed
(source-comment
(if (eq? arg 'return) node arg)))
(loop1 (cdr l) (set-adjoin liv var) (+ i 1)))
(begin
(if (> i nb-slots)
(put-copy
(make-obj undef-object)
slot
empty-var
liv
(source-comment node)))
(loop1 (cdr l) liv (+ i 1)))))
(let loop2 ((l eval-order)
(liv liv)
(reg-map '())
(oper-var '()))
(if (not (null? l))
(let* ((arg (car (car l)))
(pos (cdr (car l)))
(needed (args-live-vars liv (cdr l)))
(var (if (and (eq? arg 'return)
(eq? why 'tail))
ret-var
(make-temp-var pos)))
(opnd (if (eq? arg 'return)
(if (eq? why 'tail)
(var->opnd ret-var)
(make-lbl return-lbl))
(gen-node arg needed 'need))))
(if (eq? pos 'operator)
(if (and (ref? arg)
(not (or (obj? opnd) (lbl? opnd))))
(loop2 (cdr l)
(set-adjoin liv (ref-var arg))
reg-map
(ref-var arg))
(begin
(save-arg
opnd
var
needed
(source-comment
(if (eq? arg 'return) node arg)))
(loop2 (cdr l)
(set-adjoin liv var)
reg-map
var)))
(let ((reg (make-reg pos)))
(if (all-args-trivial? (cdr l))
(save-opnd-to-reg
opnd
reg
var
needed
(source-comment
(if (eq? arg 'return) node arg)))
(save-in-slot
opnd
var
needed
(source-comment
(if (eq? arg 'return) node arg))))
(loop2 (cdr l)
(set-adjoin liv var)
(cons (cons pos var) reg-map)
oper-var))))
(let loop3 ((i (- target.nb-regs 1)))
(if (>= i 0)
(let ((couple (assq i reg-map)))
(if couple
(let ((var (cdr couple)))
(if (not (eq? (reg->var regs i) var))
(save-opnd-to-reg
(var->opnd var)
(make-reg i)
var
liv
(source-comment node)))))
(loop3 (- i 1)))
(let ((opnd (if calling-local-proc?
(make-lbl
(+ calling-local-proc? 1))
(var->opnd oper-var))))
(seal-bb (intrs-enabled? (node-decl node))
(if return-lbl 'call 'tail-call))
(dealloc-slots
(- nb-slots
(+ frame-start (length in-stk))))
(bb-put-branch!
*bb*
(make-jump
opnd
(if calling-local-proc? #f nb-args)
#f
(current-frame liv)
(source-comment node)))
(let ((result-var (make-temp-var 'result)))
(dealloc-slots (- nb-slots frame-start))
(flush-regs)
(put-var target.proc-result result-var)
(if return-lbl
(begin
(set! poll (return-poll poll))
(set! *bb*
(make-bb (make-label-return
return-lbl
(current-frame
(set-adjoin
live
result-var))
(source-comment
node))
*bbs*))))
target.proc-result))))))))))))))
(define (contained-reg/slot opnd)
(cond ((reg? opnd) opnd)
((stk? opnd) opnd)
((clo? opnd) (contained-reg/slot (clo-base opnd)))
(else #f)))
(define (opnd-needed opnd needed)
(let ((x (contained-reg/slot opnd)))
(if x (set-adjoin needed (get-var x)) needed)))
(define (save-opnd opnd live comment)
(let ((slot (lowest-dead-slot live)))
(put-copy opnd slot (get-var opnd) live comment)))
(define (save-regs regs live comment)
(for-each
(lambda (i) (save-opnd (make-reg i) live comment))
(set->list regs)))
(define (save-opnd-to-reg opnd reg var live comment)
(if (set-member? (reg-num reg) (live-regs live))
(save-opnd reg (opnd-needed opnd live) comment))
(put-copy opnd reg var live comment))
(define (save-opnd-to-stk opnd stk var live comment)
(if (set-member? (stk-num stk) (live-slots live))
(save-opnd stk (opnd-needed opnd live) comment))
(put-copy opnd stk var live comment))
(define (all-args-trivial? l)
(if (null? l)
#t
(let ((arg (car (car l))))
(or (eq? arg 'return)
(and (trivial? arg) (all-args-trivial? (cdr l)))))))
(define (every-trivial? l)
(or (null? l) (and (trivial? (car l)) (every-trivial? (cdr l)))))
(define (trivial? node)
(or (cst? node)
(ref? node)
(and (set? node) (trivial? (set-val node)))
(and (inlinable-app? node) (every-trivial? (app-args node)))))
(define (inlinable-app? node)
(if (app? node)
(let ((proc (node->proc (app-oper node))))
(and proc
(let ((spec (specialize-for-call proc (node-decl node))))
(and (proc-obj-inlinable spec)
(nb-args-conforms?
(length (app-args node))
(proc-obj-call-pat spec))))))
#f))
(define (boolean-value? node)
(or (and (conj? node)
(boolean-value? (conj-pre node))
(boolean-value? (conj-alt node)))
(and (disj? node)
(boolean-value? (disj-pre node))
(boolean-value? (disj-alt node)))
(boolean-app? node)))
(define (boolean-app? node)
(if (app? node)
(let ((proc (node->proc (app-oper node))))
(if proc (eq? (type-name (proc-obj-type proc)) 'boolean) #f))
#f))
(define (node->proc node)
(cond ((cst? node) (if (proc-obj? (cst-val node)) (cst-val node) #f))
((ref? node)
(if (global? (ref-var node))
(target.prim-info* (var-name (ref-var node)) (node-decl node))
#f))
(else #f)))
(define (specialize-for-call proc decl) ((proc-obj-specialize proc) decl))
(define (get-jump-state args pc)
(define (empty-node-list n)
(if (> n 0) (cons #f (empty-node-list (- n 1))) '()))
(let* ((fs (pcontext-fs pc))
(slots-list (empty-node-list fs))
(regs-list (empty-node-list target.nb-regs)))
(define (assign-node-to-loc var loc)
(let ((x (cond ((reg? loc)
(let ((i (reg-num loc)))
(if (<= i target.nb-regs)
(nth-after regs-list i)
(compiler-internal-error
"jump-state, reg out of bound in back-end's pcontext"))))
((stk? loc)
(let ((i (stk-num loc)))
(if (<= i fs)
(nth-after slots-list (- i 1))
(compiler-internal-error
"jump-state, stk out of bound in back-end's pcontext"))))
(else
(compiler-internal-error
"jump-state, loc other than reg or stk in back-end's pcontext")))))
(if (not (car x))
(set-car! x var)
(compiler-internal-error
"jump-state, duplicate location in back-end's pcontext"))))
(let loop ((l (pcontext-map pc)))
(if (not (null? l))
(let* ((couple (car l)) (name (car couple)) (loc (cdr couple)))
(cond ((eq? name 'return) (assign-node-to-loc 'return loc))
(else (assign-node-to-loc (list-ref args (- name 1)) loc)))
(loop (cdr l)))))
(vector slots-list regs-list)))
(define (jump-state-in-stk x) (vector-ref x 0))
(define (jump-state-in-reg x) (vector-ref x 1))
(define (arg-eval-order oper nodes)
(define (loop nodes pos part1 part2)
(cond ((null? nodes)
(let ((p1 (reverse part1)) (p2 (free-vars-order part2)))
(cond ((not oper) (append p1 p2))
((trivial? oper)
(append p1 p2 (list (cons oper 'operator))))
(else (append (cons (cons oper 'operator) p1) p2)))))
((not (car nodes)) (loop (cdr nodes) (+ pos 1) part1 part2))
((or (eq? (car nodes) 'return) (trivial? (car nodes)))
(loop (cdr nodes)
(+ pos 1)
part1
(cons (cons (car nodes) pos) part2)))
(else
(loop (cdr nodes)
(+ pos 1)
(cons (cons (car nodes) pos) part1)
part2))))
(loop nodes 0 '() '()))
(define (free-vars-order l)
(let ((bins '()) (ordered-args '()))
(define (free-v x) (if (eq? x 'return) (set-empty) (free-variables x)))
(define (add-to-bin! x)
(let ((y (assq x bins)))
(if y (set-cdr! y (+ (cdr y) 1)) (set! bins (cons (cons x 1) bins)))))
(define (payoff-if-removed node)
(let ((x (free-v node)))
(let loop ((l (set->list x)) (r 0))
(if (null? l)
r
(let ((y (cdr (assq (car l) bins))))
(loop (cdr l) (+ r (quotient 1000 (* y y)))))))))
(define (remove-free-vars! x)
(let loop ((l (set->list x)))
(if (not (null? l))
(let ((y (assq (car l) bins)))
(set-cdr! y (- (cdr y) 1))
(loop (cdr l))))))
(define (find-max-payoff l thunk)
(if (null? l)
(thunk '() -1)
(find-max-payoff
(cdr l)
(lambda (best-arg best-payoff)
(let ((payoff (payoff-if-removed (car (car l)))))
(if (>= payoff best-payoff)
(thunk (car l) payoff)
(thunk best-arg best-payoff)))))))
(define (remove x l)
(cond ((null? l) '())
((eq? x (car l)) (cdr l))
(else (cons (car l) (remove x (cdr l))))))
(for-each
(lambda (x) (for-each add-to-bin! (set->list (free-v (car x)))))
l)
(let loop ((args l) (ordered-args '()))
(if (null? args)
(reverse ordered-args)
(find-max-payoff
args
(lambda (best-arg best-payoff)
(remove-free-vars! (free-v (car best-arg)))
(loop (remove best-arg args) (cons best-arg ordered-args))))))))
(define (args-live-vars live order)
(cond ((null? order) live)
((eq? (car (car order)) 'return)
(args-live-vars (set-adjoin live ret-var) (cdr order)))
(else
(args-live-vars
(set-union live (free-variables (car (car order))))
(cdr order)))))
(define (stk-live-vars live slots why)
(cond ((null? slots) live)
((not (car slots)) (stk-live-vars live (cdr slots) why))
((eq? (car slots) 'return)
(stk-live-vars
(if (eq? why 'tail) (set-adjoin live ret-var) live)
(cdr slots)
why))
(else
(stk-live-vars
(set-union live (free-variables (car slots)))
(cdr slots)
why))))
(define (gen-let vars vals node live why)
(let ((var-val-map (pair-up vars vals))
(var-set (list->set vars))
(all-live
(set-union
live
(free-variables node)
(apply set-union (map free-variables vals)))))
(define (var->val var) (cdr (assq var var-val-map)))
(define (proc-var? var) (prc? (var->val var)))
(define (closed-vars var const-proc-vars)
(set-difference
(not-constant-closed-vars (var->val var))
const-proc-vars))
(define (no-closed-vars? var const-proc-vars)
(set-empty? (closed-vars var const-proc-vars)))
(define (closed-vars? var const-proc-vars)
(not (no-closed-vars? var const-proc-vars)))
(define (compute-const-proc-vars proc-vars)
(let loop1 ((const-proc-vars proc-vars))
(let ((new-const-proc-vars
(set-keep
(lambda (x) (no-closed-vars? x const-proc-vars))
const-proc-vars)))
(if (not (set-equal? new-const-proc-vars const-proc-vars))
(loop1 new-const-proc-vars)
const-proc-vars))))
(let* ((proc-vars (set-keep proc-var? var-set))
(const-proc-vars (compute-const-proc-vars proc-vars))
(clo-vars
(set-keep (lambda (x) (closed-vars? x const-proc-vars)) proc-vars))
(clo-vars-list (set->list clo-vars)))
(for-each
(lambda (proc-var)
(let ((label (schedule-gen-proc (var->val proc-var) '())))
(add-known-proc (lbl-num label) (var->val proc-var))
(add-constant-var proc-var label)))
(set->list const-proc-vars))
(let ((non-clo-vars-list
(set->list
(set-keep
(lambda (var)
(and (not (set-member? var const-proc-vars))
(not (set-member? var clo-vars))))
vars)))
(liv (set-union
live
(apply set-union
(map (lambda (x) (closed-vars x const-proc-vars))
clo-vars-list))
(free-variables node))))
(let loop2 ((vars* non-clo-vars-list))
(if (not (null? vars*))
(let* ((var (car vars*))
(val (var->val var))
(needed (vals-live-vars liv (map var->val (cdr vars*)))))
(if (var-useless? var)
(gen-node val needed 'side)
(save-val
(gen-node val needed 'need)
var
needed
(source-comment val)))
(loop2 (cdr vars*)))))
(if (pair? clo-vars-list)
(begin
(dealloc-slots (- nb-slots (stk-num (highest-live-slot liv))))
(let loop3 ((l clo-vars-list))
(if (not (null? l))
(begin
(push-slot)
(let ((var (car l)) (slot (make-stk nb-slots)))
(put-var slot var)
(loop3 (cdr l))))))
(bb-put-non-branch!
*bb*
(make-close
(map (lambda (var)
(let ((closed-list
(sort-variables
(set->list (closed-vars var const-proc-vars)))))
(if (null? closed-list)
(compiler-internal-error
"gen-let, no closed variables:"
(var-name var))
(make-closure-parms
(var->opnd var)
(lbl-num (schedule-gen-proc
(var->val var)
closed-list))
(map var->opnd closed-list)))))
clo-vars-list)
(current-frame liv)
(source-comment node)))))
(gen-node node live why)))))
(define (save-arg opnd var live comment)
(if (glo? opnd)
(add-constant-var var opnd)
(save-val opnd var live comment)))
(define (save-val opnd var live comment)
(cond ((or (obj? opnd) (lbl? opnd)) (add-constant-var var opnd))
((and (reg? opnd) (not (set-member? (reg-num opnd) (live-regs live))))
(put-var opnd var))
((and (stk? opnd) (not (set-member? (stk-num opnd) (live-slots live))))
(put-var opnd var))
(else (save-in-slot opnd var live comment))))
(define (save-in-slot opnd var live comment)
(let ((slot (lowest-dead-slot live))) (put-copy opnd slot var live comment)))
(define (save-var opnd var live comment)
(cond ((or (obj? opnd) (lbl? opnd)) (add-constant-var var opnd) var)
((or (glo? opnd) (reg? opnd) (stk? opnd)) (get-var opnd))
(else
(let ((dest (or (highest-dead-reg live) (lowest-dead-slot live))))
(put-copy opnd dest var live comment)
var))))
(define (put-copy opnd loc var live comment)
(if (and (stk? loc) (> (stk-num loc) nb-slots)) (push-slot))
(if var (put-var loc var))
(if (not (eq? opnd loc))
(bb-put-non-branch!
*bb*
(make-copy
opnd
loc
(current-frame (if var (set-adjoin live var) live))
comment))))
(define (var-useless? var)
(and (set-empty? (var-refs var)) (set-empty? (var-sets var))))
(define (vals-live-vars live vals)
(if (null? vals)
live
(vals-live-vars
(set-union live (free-variables (car vals)))
(cdr vals))))
(define (gen-fut node live why)
(let* ((val (fut-val node))
(clo-vars (not-constant-closed-vars val))
(clo-vars-list (set->list clo-vars))
(ret-var* (make-temp-var 0))
(live-after live)
(live-starting-task
(set-adjoin (set-union live-after clo-vars) ret-var*))
(task-lbl (bbs-new-lbl! *bbs*))
(return-lbl (bbs-new-lbl! *bbs*)))
(save-regs (live-regs live-after) live-starting-task (source-comment node))
(let ((frame-start (stk-num (highest-live-slot live-after))))
(save-opnd-to-reg
(make-lbl return-lbl)
target.task-return
ret-var*
(set-remove live-starting-task ret-var*)
(source-comment node))
(let loop1 ((l clo-vars-list) (i 0))
(if (null? l)
(dealloc-slots (- nb-slots (+ frame-start i)))
(let ((var (car l)) (rest (cdr l)))
(if (memq var regs)
(loop1 rest i)
(let loop2 ((j (- target.nb-regs 1)))
(if (>= j 0)
(if (or (>= j (length regs))
(not (set-member?
(list-ref regs j)
live-starting-task)))
(let ((reg (make-reg j)))
(put-copy
(var->opnd var)
reg
var
live-starting-task
(source-comment node))
(loop1 rest i))
(loop2 (- j 1)))
(let ((slot (make-stk (+ frame-start (+ i 1))))
(needed (list->set rest)))
(if (and (or (> (stk-num slot) nb-slots)
(not (memq (list-ref
slots
(- nb-slots (stk-num slot)))
regs)))
(set-member?
(stk-num slot)
(live-slots needed)))
(save-opnd
slot
live-starting-task
(source-comment node)))
(put-copy
(var->opnd var)
slot
var
live-starting-task
(source-comment node))
(loop1 rest (+ i 1)))))))))
(seal-bb (intrs-enabled? (node-decl node)) 'call)
(bb-put-branch!
*bb*
(make-jump
(make-lbl task-lbl)
#f
#f
(current-frame live-starting-task)
#f))
(let ((task-context
(make-context
(- nb-slots frame-start)
(reverse (nth-after (reverse slots) frame-start))
(cons ret-var (cdr regs))
'()
poll
entry-bb))
(return-context
(make-context
frame-start
(nth-after slots (- nb-slots frame-start))
'()
closed
(return-poll poll)
entry-bb)))
(restore-context task-context)
(set! *bb*
(make-bb (make-label-task-entry
task-lbl
(current-frame live-starting-task)
(source-comment node))
*bbs*))
(gen-node val ret-var-set 'tail)
(let ((result-var (make-temp-var 'future)))
(restore-context return-context)
(put-var target.proc-result result-var)
(set! *bb*
(make-bb (make-label-task-return
return-lbl
(current-frame (set-adjoin live result-var))
(source-comment node))
*bbs*))
(gen-return target.proc-result why node))))))
Reference in New Issue View Git Blame Copy Permalink