diff --git a/src/ikarus.boot b/src/ikarus.boot index a177b95..0dc407e 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.compiler.ss b/src/ikarus.compiler.ss index 65c63fd..7ba860e 100644 --- a/src/ikarus.compiler.ss +++ b/src/ikarus.compiler.ss @@ -1,7 +1,6 @@ (library (ikarus compiler) (export compile-core-expr-to-port - alt-compile-core-expr-to-port assembler-output current-primitive-locations eval-core) (import @@ -1854,580 +1853,6 @@ (include "libcogen1.ss") - - -(define (lift-codes x) ;;; NOT USED - (define who 'lift-codes) - (define all-codes '()) - (define (do-code x) - (record-case x - [(clambda label cls* free) - (let ([cls* (map - (lambda (x) - (record-case x - [(clambda-case info body) - (make-clambda-case info (E body))])) - cls*)]) - (let ([g (make-code-loc label)]) - (set! all-codes - (cons (make-clambda label cls* free) all-codes)) - g))])) - (define (E x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(bind lhs* rhs* body) - (make-bind lhs* (map E rhs*) (E body))] - [(fix lhs* rhs* body) - (make-fix lhs* (map E rhs*) (E body))] - [(conditional test conseq altern) - (make-conditional (E test) (E conseq) (E altern))] - [(seq e0 e1) (make-seq (E e0) (E e1))] - [(closure c free) (make-closure (do-code c) free)] - [(primcall op rand*) (make-primcall op (map E rand*))] - [(forcall op rand*) (make-forcall op (map E rand*))] - [(funcall rator rand*) (make-funcall (E rator) (map E rand*))] - [else (error who "invalid expression ~s" (unparse x))])) - (let ([x (E x)]) - (make-codes all-codes x))) - -(define (syntactically-valid? op rand*) - (define (valid-arg-count? op rand*) - (let ([n (open-coded-primitive-args op)] [m (length rand*)]) - (cond - [(eq? n 'any) #t] - [(eq? n 'positive) (fx> m 1)] - [(eq? n 'no-code) - (error 'syntactically-valid - "should not primcall non codable prim ~s" op)] - [(fixnum? n) - (cond - [(fx= n m) #t] - [else - (error 'compile - "Possible incorrect number of args in ~s" - (cons op (map unparse rand*))) - #f])] - [else (error 'do-primcall "BUG: what ~s" n)]))) - (define (check op pred?) - (lambda (arg) - (record-case arg - [(constant c) - (cond - [(pred? c) #t] - [else - (error 'compile "Possible argument error to primitive ~s" op) - #f])] - [(primref) - (cond - [(pred? (lambda (x) x)) #t] - [else - (error 'compile "Possible argument error to primitive ~s" op) - #f])] - [else #t]))) - (define (nonnegative-fixnum? n) - (and (fixnum? n) (fx>= n 0))) - (define (byte? n) - (and (fixnum? n) (fx<= 0 n) (fx<= n 127))) - (define (valid-arg-types? op rand*) - (case op - [(fixnum? flonum? bignum? immediate? boolean? char? vector? string? procedure? - null? pair? not cons eq? vector symbol? error eof-object eof-object? - void base-rtd $unbound-object? code? $forward-ptr? bwp-object? - pointer-value top-level-value car cdr list* list $record - port? input-port? output-port? $bytevector-set! - $bytevector-length $bytevector-u8-ref $bytevector-s8-ref - $make-bytevector $bytevector-ref bytevector? - $bignum-byte-ref $bignum-positive? $bignum-size - $make-port/input $make-port/output $make-port/both - $port-handler - $port-input-buffer $port-input-index $port-input-size - $port-output-buffer $port-output-index $port-output-size - $set-port-input-index! $set-port-input-size! - $set-port-output-index! $set-port-output-size! ) - '#t] - [($fxadd1 $fxsub1 $fxzero? $fxlognot $fxlogor $fxlogand $fx+ $fx- $fx* - $fx= $fx< $fx<= $fx> $fx>= $fxquotient $fxmodulo $fxsll $fxsra $fxlogxor $exit) - (andmap (check op fixnum?) rand*)] - [($fixnum->char) - (andmap (check op fixnum?) rand*)] - [($char->fixnum $char= $char< $char<= $char> $char>= $string) - (andmap (check op char?) rand*)] - [($make-vector $make-string) - (andmap (check op nonnegative-fixnum?) rand*)] - [($car $cdr) - (andmap (check op pair?) rand*)] - [($vector-length) - (andmap (check op vector?) rand*)] - [($string-length) - (andmap (check op string?) rand*)] - [($set-car! $set-cdr!) - ((check op pair?) (car rand*))] - [($vector-ref $vector-set!) - (and ((check op vector?) (car rand*)) - ((check op nonnegative-fixnum?) (cadr rand*)))] - [($string-ref $string-set!) - (and ((check op string?) (car rand*)) - ((check op nonnegative-fixnum?) (cadr rand*)))] - [($symbol-string $symbol-unique-string) - (andmap (check op symbol?) rand*)] - [($constant-ref $set-constant! $intern $pcb-set! $pcb-ref $make-symbol - $make-ratnum ratnum? $ratnum-n $ratnum-d - $symbol-value $set-symbol-value! $set-symbol-function! $symbol-plist $set-symbol-plist! - $set-symbol-system-value! $set-symbol-system-value! - $set-symbol-unique-string! - $set-symbol-string! - $seal-frame-and-call $frame->continuation $code->closure - $closure-code - $code-size $code-reloc-vector $code-freevars - $code-ref $code-set! - $make-record $record? $record/rtd? $record-rtd $record-ref $record-set! - $make-tcbucket $tcbucket-key $tcbucket-val $tcbucket-next - $set-tcbucket-val! - $set-tcbucket-next! $set-tcbucket-tconc!) - #t] - [else (error 'valid-arg-types? "unhandled op ~s" op)])) - (and (valid-arg-count? op rand*) - (or (null? rand*) - (valid-arg-types? op rand*)))) - -(module (mark-uninlined uninlined-stats) ;;; UNINLINED ANALYSIS - ;;; the output of simplify-operands differs from the input in that the - ;;; operands to primcalls are all simple (variables, primrefs, or constants). - ;;; funcalls to open-codable primrefs whos arguments are "ok" are converted to - ;;; primcalls. - (define uninlined '()) - (define (mark-uninlined x) - (cond - [(assq x uninlined) => - (lambda (p) (set-cdr! p (fxadd1 (cdr p))))] - [else (set! uninlined (cons (cons x 1) uninlined))])) - (define uninlined-stats - (lambda () - (let f ([ls uninlined] [ac '()]) - (cond - [(null? ls) ac] - [(fx> (cdar ls) 15) - (f (cdr ls) (cons (car ls) ac))] - [else (f (cdr ls) ac)]))))) - -(define (introduce-primcalls x) - (define who 'introduce-primcalls) - (define (Expr x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(closure) x] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Expr body))] - [(fix lhs* rhs* body) - (make-fix lhs* (map Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (make-seq (Expr e0) (Expr e1))] - [(primcall op arg*) - (case op - ;[(values) - ; (if (fx= (length arg*) 1) - ; (Expr (car arg*)) - ; (begin - ; (warning 'compile "possible incorrect number of values") - ; (make-funcall (make-primref 'values) (map Expr arg*))))] - [else - (make-primcall op (map Expr arg*))])] - [(forcall op arg*) - (make-forcall op (map Expr arg*))] - [(funcall rator rand*) - (cond - [(and (primref? rator) - (open-codeable? (primref-name rator)) - (syntactically-valid? (primref-name rator) rand*)) - (Expr (make-primcall (primref-name rator) rand*))] - [else - (when (primref? rator) - (mark-uninlined (primref-name rator))) - (make-funcall (Expr rator) (map Expr rand*))])] - [(jmpcall label op arg*) - (make-jmpcall label (Expr op) (map Expr arg*))] - [(mvcall p c) - (record-case c - [(clambda label cases free) - (make-mvcall (Expr p) - (make-clambda label - (map (lambda (x) - (record-case x - [(clambda-case info body) - (make-clambda-case info (Expr body))])) - cases) - free))])] - [else (error who "invalid expression ~s" (unparse x))])) - (define (Tail x) - (record-case x - [(constant) (make-return x)] - [(var) (make-return x)] - [(primref) (make-return x)] - [(closure) (make-return x)] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Tail body))] - [(fix lhs* rhs* body) - (make-fix lhs* (map Expr rhs*) (Tail body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Tail conseq) (Tail altern))] - [(seq e0 e1) (make-seq (Expr e0) (Tail e1))] - [(primcall op arg*) - (case op - ;[(values) - ; (if (fx= (length arg*) 1) - ; (make-return (Expr (car arg*))) - ; (make-return* (map Expr arg*)))] - [else - (make-return (make-primcall op (map Expr arg*)))])] - [(forcall op arg*) - (make-return (make-forcall op (map Expr arg*)))] - [(funcall rator rand*) - (cond - [(and (primref? rator) - (open-codeable? (primref-name rator)) - (syntactically-valid? (primref-name rator) rand*)) - (Tail (make-primcall (primref-name rator) rand*))] - [else - (make-funcall (Expr rator) (map Expr rand*))])] - [(jmpcall label op arg*) - (make-jmpcall label (Expr op) (map Expr arg*))] - [(mvcall p c) - (record-case c - [(clambda label cases free) - (make-mvcall (Expr p) - (make-clambda label - (map (lambda (x) - (record-case x - [(clambda-case info body) - (make-clambda-case info (Tail body))])) - cases) - free))])] - [else (error who "invalid expression ~s" (unparse x))])) - (define (CaseExpr x) - (record-case x - [(clambda-case info body) - (make-clambda-case info (Tail body))])) - (define (CodeExpr x) - (record-case x - [(clambda L cases free) - (make-clambda L (map CaseExpr cases) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) (Tail body))])) - (CodesExpr x)) - -(define (simplify-operands x) - (define who 'simplify-operands) - (define (simple? x) - (or (constant? x) (var? x) (primref? x) - (and (closure? x) (null? (closure-free* x))))) - (define (simplify arg lhs* rhs* k) - (if (simple? arg) - (k arg lhs* rhs*) - (let ([v (unique-var 'tp)]) - (k v (cons v lhs*) (cons (Expr arg) rhs*))))) - (define (simplify* arg* lhs* rhs* k) - (cond - [(null? arg*) (k '() lhs* rhs*)] - [else - (simplify (car arg*) lhs* rhs* - (lambda (a lhs* rhs*) - (simplify* (cdr arg*) lhs* rhs* - (lambda (d lhs* rhs*) - (k (cons a d) lhs* rhs*)))))])) - (define (make-bind^ lhs* rhs* body) - (if (null? lhs*) - body - (make-bind lhs* rhs* body))) - (define (Expr x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(closure) x] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Expr body))] - [(fix lhs* rhs* body) - (make-fix lhs* (map Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (make-seq (Expr e0) (Expr e1))] - [(primcall op arg*) - (cond - [(memq op '(not car cdr cadr fxadd1 fxsub1 - null? pair? fixnum? vector? string? - char? symbol? eof-object? - )) ;;; SIMPLIFY - (make-primcall op (map Expr arg*))] - [(memq op '(fx+)) - (cond - [(simple? (cadr arg*)) - (make-primcall op - (list (Expr (car arg*)) (cadr arg*)))] - [(simple? (car arg*)) - (make-primcall op - (list (car arg*) (Expr (cadr arg*))))] - [else - (simplify* (cdr arg*) '() '() - (lambda (a* lhs* rhs*) - (make-bind^ lhs* rhs* - (make-primcall op - (cons (Expr (car arg*)) a*)))))])] - [else - (simplify* arg* '() '() - (lambda (arg* lhs* rhs*) - (make-bind^ lhs* rhs* - (make-primcall op arg*))))])] - [(forcall op arg*) - (make-forcall op (map Expr arg*))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(jmpcall label op arg*) - (make-jmpcall label (Expr op) (map Expr arg*))] - [(mvcall p c) - (make-mvcall (Expr p) (CodeExpr c))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (Tail x) - (record-case x - [(return v) (make-return (Expr v))] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Tail body))] - [(fix lhs* rhs* body) - (make-fix lhs* (map Expr rhs*) (Tail body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Tail conseq) (Tail altern))] - [(seq e0 e1) (make-seq (Expr e0) (Tail e1))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(jmpcall label op arg*) - (make-jmpcall label (Expr op) (map Expr arg*))] - [(mvcall p c) - (make-mvcall (Expr p) (CodeExpr c))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (CaseExpr x) - (record-case x - [(clambda-case info body) - (make-clambda-case info (Tail body))])) - (define (CodeExpr x) - (record-case x - [(clambda L clauses free) - (make-clambda L (map CaseExpr clauses) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) (Tail body))])) - (CodesExpr x)) - -(define (insert-stack-overflow-checks x) - (define who 'insert-stack-overflow-checks) - (define (insert-check body) - (make-seq - (make-interrupt-call - (make-primcall '$fp-overflow '()) - (make-funcall (make-primref 'do-stack-overflow) '())) - body)) - (define (Expr x) - (record-case x - [(constant) #f] - [(var) #f] - [(primref) #f] - [(closure code free*) #f] - [(bind lhs* rhs* body) - (or (ormap Expr rhs*) (Expr body))] - [(fix lhs* rhs* body) (Expr body)] - [(conditional test conseq altern) - (or (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (or (Expr e0) (Expr e1))] - [(primcall op arg*) (ormap Expr arg*)] - [(forcall op arg*) (ormap Expr arg*)] - [(funcall rator arg*) #t] - [(jmpcall label rator arg*) #t] - [(mvcall p c) #t] - [else (error who "invalid expression ~s" (unparse x))])) - (define (Tail x) - (record-case x - [(return v) (Expr v)] - [(bind lhs* rhs* body) - (or (ormap Expr rhs*) (Tail body))] - [(fix lhs* rhs* body) (Tail body)] - [(conditional test conseq altern) - (or (Expr test) (Tail conseq) (Tail altern))] - [(seq e0 e1) (or (Expr e0) (Tail e1))] - [(funcall rator arg*) (or (Expr rator) (ormap Expr arg*))] - [(jmpcall label rator arg*) (or (Expr rator) (ormap Expr arg*))] - [(mvcall p c) #t] - [else (error who "invalid tail expression ~s" (unparse x))])) - (define (CaseExpr x) - (record-case x - [(clambda-case info body) - (if (Tail body) - (make-clambda-case info (insert-check body)) - x)])) - (define (CodeExpr x) - (record-case x - [(clambda L cases free) - (make-clambda L (map CaseExpr cases) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) - (if (Tail body) - (insert-check body) - body))])) - (CodesExpr x)) - -(define (insert-allocation-checks x) - (define who 'insert-allocation-checks) - (define (check-bytes n var body) - (make-seq - (make-interrupt-call - (make-primcall '$ap-check-bytes - (list (make-constant n) var)) - (make-forcall "ik_collect" - (list - (make-primcall '$fx+ - (list (make-constant (fx+ n 4096)) var))))) - body)) - (define (check-words n var body) - (make-seq - (make-interrupt-call - (make-primcall '$ap-check-words - (list (make-constant n) var)) - (make-forcall "ik_collect" ; (make-primref 'do-overflow-words) - (list - (make-primcall '$fx+ - (list (make-constant (fx+ n 4096)) var))))) - body)) - (define (check-const n body) - (cond - [(fxzero? n) body] - [else - (make-seq - (make-interrupt-call - (make-primcall '$ap-check-const - (list (make-constant n))) - (make-forcall "ik_collect" ;(make-primref 'do-overflow) - (list (make-constant (fx+ n 4096))))) - body)])) - (define (closure-size x) - (record-case x - [(closure code free*) - (if (null? free*) - 0 - (align (fx+ disp-closure-data (fx* (length free*) wordsize))))] - [else (error 'closure-size "~s is not a closure" x)])) - (define (sum ac ls) - (cond - [(null? ls) ac] - [else (sum (fx+ ac (car ls)) (cdr ls))])) - (define (Expr x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(closure) - (check-const (closure-size x) x)] - [(fix lhs* rhs* body) - (if (null? lhs*) - (Expr body) - (check-const (sum 0 (map closure-size rhs*)) - (make-fix lhs* rhs* - (Expr body))))] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (make-seq (Expr e0) (Expr e1))] - [(primcall op arg*) - (let ([x (make-primcall op (map Expr arg*))]) - (case op - [(cons) (check-const pair-size x)] - [($make-symbol) (check-const symbol-record-size x)] - [($make-tcbucket) (check-const tcbucket-size x)] - [($frame->continuation $code->closure) - (check-const - (fx+ disp-closure-data (fx* (length arg*) wordsize)) x)] - [($make-bytevector) - (record-case (car arg*) - [(constant i) - (check-const (fx+ i (fx+ disp-string-data 1)) x)] - [else - (check-bytes (fxadd1 disp-string-data) (car arg*) x)])] - [($make-port/input $make-port/output $make-port/both) - (check-const port-size x)] - [($make-vector $make-string) - (record-case (car arg*) - [(constant i) - (check-const (fx+ (fx* i wordsize) disp-vector-data) x)] - [else - (check-words (fxadd1 disp-vector-data) (car arg*) x)])] - [($make-record) - (record-case (cadr arg*) - [(constant i) - (check-const (fx+ (fx* i wordsize) disp-record-data) x)] - [else - (check-words (fxadd1 disp-record-data) (cadr arg*) x)])] - [(list*) - (check-const (fx* (fxsub1 (length arg*)) pair-size) x)] - [(list) - (check-const (fx* (length arg*) pair-size) x)] - [(vector $record $string) - (check-const (fx+ (fx* (length arg*) wordsize) disp-vector-data) x)] - [($make-ratnum) (check-const ratnum-size x)] - [else x]))] - [(forcall op arg*) - (make-forcall op (map Expr arg*))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(jmpcall label op arg*) - (make-jmpcall label (Expr op) (map Expr arg*))] - [(interrupt-call e0 e1) - (make-interrupt-call (Expr e0) (Expr e1))] - [(mvcall p c) - (make-mvcall (Expr p) (CodeExpr c))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (Tail x) - (record-case x - [(return v) (make-return (Expr v))] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Tail body))] - [(fix lhs* rhs* body) - (if (null? lhs*) - (Tail body) - (check-const (sum 0 (map closure-size rhs*)) - (make-fix lhs* rhs* - (Tail body))))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Tail conseq) (Tail altern))] - [(seq e0 e1) (make-seq (Expr e0) (Tail e1))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(jmpcall label op arg*) - (make-jmpcall label (Expr op) (map Expr arg*))] - [(mvcall p c) - (make-mvcall (Expr p) (CodeExpr c))] - [else (error who "invalid tail expression ~s" (unparse x))])) - (define (CaseExpr x) - (record-case x - [(clambda-case info body) - (make-clambda-case info (Tail body))])) - (define (CodeExpr x) - (record-case x - [(clambda L cases free) - (make-clambda L (map CaseExpr cases) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) (Tail body))])) - (CodesExpr x)) - - (define (insert-engine-checks x) (define (Tail x) (make-seq @@ -2449,473 +1874,6 @@ (make-codes (map CodeExpr list) (Tail body))])) (CodesExpr x)) -(define (remove-local-variables x) - (define who 'remove-local-variables) - (define (Body orig-x orig-si orig-r orig-live save-cp?) - (define (simple* x* r) - (map (lambda (x) - (cond - [(assq x r) => cdr] - [else - (when (var? x) (error who "unbound var ~s" x)) - x])) - x*)) - (define (env->live-mask r sz) - (let ([s (make-vector (fxsra (fx+ sz 7) 3) 0)]) - (for-each - (lambda (idx) - (let ([q (fxsra idx 3)] - [r (fxlogand idx 7)]) - (vector-set! s q - (fxlogor (vector-ref s q) (fxsll 1 r))))) - r) - s)) - (define (check? x) - (cond - [(primref? x) #f] ;;;; PRIMREF CHECK - [(closure? x) #f] - [else #t])) - (define (do-new-frame label op rand* si r - call-convention rp-convention orig-live) - (let ([start-si (if save-cp? (fxadd1 si) si)]) - (make-new-frame start-si (fx+ (length rand*) 2) - (let f ([r* rand*] [nsi (fxadd1 start-si)] [live orig-live]) - (cond - [(null? r*) - (make-seq - (make-seq - (if save-cp? - (make-save-cp (make-frame-var si)) - (nop)) - (case call-convention - [(normal apply) - (make-eval-cp (check? op) - (Expr op nsi r - (if save-cp? - (cons si live) - live)))] - [(direct) - (if (closure? op) - (nop) - (make-eval-cp #f - (Expr op nsi r - (if save-cp? - (cons si live) - live))))] - [(foreign) - (make-eval-cp #f (make-foreign-label op))] - [else (error who "invalid convention ~s" call-convention)])) - (make-call-cp call-convention label save-cp? - rp-convention - start-si ; frame size - (length rand*) ; argc - (env->live-mask - (if save-cp? (cons si orig-live) orig-live) - start-si)))] ; mask-size ~~ frame size - [else - (make-seq - (make-assign (make-frame-var nsi) - (Expr (car r*) nsi r live)) - (f (cdr r*) (fxadd1 nsi) (cons nsi live)))]))))) - (define (nop) (make-primcall 'void '())) - (define (do-bind lhs* rhs* body si r live k) - (let f ([lhs* lhs*] [rhs* rhs*] [si si] [nr r] [live live]) - (cond - [(null? lhs*) (k body si nr live)] - [else - (let ([v (make-frame-var si)]) - (make-seq - (make-assign v (Expr (car rhs*) si r live)) - (f (cdr lhs*) (cdr rhs*) (fxadd1 si) - (cons (cons (car lhs*) v) nr) - (cons si live))))]))) - (define (do-closure r) - (lambda (x) - (record-case x - [(closure code free*) - (make-closure code (simple* free* r))]))) - (define (do-fix lhs* rhs* body si r live k) - (let f ([l* lhs*] [nlhs* '()] [si si] [r r] [live live]) - (cond - [(null? l*) - (make-fix (reverse nlhs*) - (map (do-closure r) rhs*) - (k body si r live))] - [else - (let ([v (make-frame-var si)]) - (f (cdr l*) (cons v nlhs*) (fxadd1 si) - (cons (cons (car l*) v) r) - (cons si live)))]))) - (define (do-tail-frame-unoptimized label op rand* si r call-conv live) - (let f ([i si] [r* rand*] [live live]) - (cond - [(null? r*) - (make-seq - (make-eval-cp (check? op) (Expr op i r live)) - (let f ([i 1] [j si] [r* rand*]) - (cond - [(null? r*) - (make-tailcall-cp call-conv label (length rand*))] - [else - (make-seq - (make-assign (make-frame-var i) - (make-frame-var j)) - (f (fxadd1 i) (fxadd1 j) (cdr r*)))])))] - [else - (let ([fv (make-frame-var i)] - [rhs (Expr (car r*) i r live)]) - (make-seq - (make-assign fv rhs) - (f (fxadd1 i) (cdr r*) (cons i live))))]))) - (define (do-tail-frame label op rand* si r call-conv live) - (define (const? x) - (record-case x - [(constant) #t] - [(primref) #t] - [else #f])) - (define (evalrand* rand* i si r live ac) - (cond - [(null? rand*) - ;;; evaluate operator after all operands - (make-seq - (make-eval-cp (check? op) (Expr op si r live)) - ac)] - [(const? (car rand*)) - ;;; constants are not live since they can be assigned - ;;; after all args are evaluated - (evalrand* (cdr rand*) (fxadd1 i) (fxadd1 si) r live - (make-seq ac - (make-assign (make-frame-var i) (car rand*))))] - [else - (let ([vsi (make-frame-var si)] - [rhs (Expr (car rand*) si r live)]) - (cond - [(and (frame-var? rhs) - (fx= (frame-var-idx rhs) i)) - ;;; value of rhs is already in f[i] - ;;; just mark it live - (evalrand* (cdr rand*) (fx+ i 1) (fx+ si 1) r live ac)] - [(fx= i si) - (make-seq - (make-assign vsi rhs) - (evalrand* (cdr rand*) (fx+ i 1) (fx+ si 1) r - (cons si live) ac))] - [else - (make-seq - (make-assign vsi rhs) - (evalrand* (cdr rand*) (fxadd1 i) (fxadd1 si) r (cons si live) - (make-seq ac - (make-assign (make-frame-var i) vsi))))]))])) - (make-seq - (evalrand* rand* 1 si r live (make-primcall 'void '())) - (make-tailcall-cp call-conv label (length rand*)))) - (define (Tail x si r live) - (record-case x - [(return v) (make-return (Expr v si r live))] - [(bind lhs* rhs* body) - (do-bind lhs* rhs* body si r live Tail)] - [(fix lhs* rhs* body) - (do-fix lhs* rhs* body si r live Tail)] - [(conditional test conseq altern) - (make-conditional - (Expr test si r live) - (Tail conseq si r live) - (Tail altern si r live))] - [(seq e0 e1) (make-seq (Effect e0 si r live) (Tail e1 si r live))] - [(primcall op arg*) - (make-return - (make-primcall op - (map (lambda (x) (Expr x si r live)) arg*)))] - [(funcall op rand*) - (do-tail-frame #f op rand* si r 'normal live)] - [(jmpcall label op rand*) - (do-tail-frame label op rand* si r 'direct live)] - [(mvcall p c) - (do-mvcall p c x si r live Tail)] - [else (error who "invalid expression ~s" (unparse x))])) - (define (do-mvcall p c x si r live k) - (define (make-mv-rp c si r live k) - (define (do-clambda-case x) - (record-case x - [(clambda-case info body) - (record-case info - [(case-info label fml* proper) - (let-values ([(fml* si r live) - (bind-fml* fml* - (if save-cp? (fx+ si 2) (fx+ si 1)) - r live)]) - (make-clambda-case - (make-case-info label fml* proper) - (k body si r live)))])])) - (record-case c - [(clambda L cases free) - (make-clambda L (map do-clambda-case cases) free)])) - (record-case p - [(funcall op rand*) - (do-new-frame #f op rand* si r 'normal - (make-mv-rp c si r live k) - live)] - [(jmpcall label op rand*) - (do-new-frame label op rand* si r 'direct - (make-mv-rp c si r live k) - live)] - [else (error who "invalid mvcall producer ~s" - (unparse p))])) - (define (Effect x si r live) - (record-case x - [(constant) (nop)] - [(var) (nop)] - [(primref) (nop)] - [(closure code free*) (nop)] - [(bind lhs* rhs* body) - (do-bind lhs* rhs* body si r live Effect)] - [(fix lhs* rhs* body) - (do-fix lhs* rhs* body si r live Effect)] - [(conditional test conseq altern) - (make-conditional - (Expr test si r live) - (Effect conseq si r live) - (Effect altern si r live))] - [(seq e0 e1) (make-seq (Effect e0 si r live) (Effect e1 si r live))] - [(primcall op arg*) - (make-primcall op - (map (lambda (x) (Expr x si r live)) arg*))] - [(forcall op rand*) - (do-new-frame #f op rand* si r 'foreign 'effect live)] - [(funcall op rand*) - (do-new-frame #f op rand* si r 'normal 'effect live)] - [(mvcall p c) - (do-mvcall p c x si r live Effect)] - [(jmpcall label op rand*) - (do-new-frame label op rand* si r 'direct 'effect live)] - [(interrupt-call e0 e1) - (make-interrupt-call - (Expr e0 si r live) - (Effect e1 si r live))] - [else (error who "invalid effect expression ~s" (unparse x))])) - (define (Expr x si r live) - (record-case x - [(constant) x] - [(var) - (cond - [(assq x r) => cdr] - [else (error who "unbound var ~s" x)])] - [(primref) x] - [(closure code free*) - (make-closure code (simple* free* r))] - [(bind lhs* rhs* body) - (do-bind lhs* rhs* body si r live Expr)] - [(fix lhs* rhs* body) - (do-fix lhs* rhs* body si r live Expr)] - [(conditional test conseq altern) - (make-conditional - (Expr test si r live) - (Expr conseq si r live) - (Expr altern si r live))] - [(seq e0 e1) (make-seq (Effect e0 si r live) (Expr e1 si r live))] - [(primcall op arg*) - (make-primcall op - (map (lambda (x) (Expr x si r live)) arg*))] - [(forcall op rand*) - (do-new-frame #f op rand* si r 'foreign 'value live)] - [(funcall op rand*) - (do-new-frame #f op rand* si r 'normal 'value live)] - [(jmpcall label op rand*) - (do-new-frame label op rand* si r 'direct 'value live)] - [(mvcall p c) - (do-mvcall p c x si r live Expr)] - [else (error who "invalid expression ~s" (unparse x))])) - (Tail orig-x orig-si orig-r orig-live)) - (define (bind-fml* fml* si r live) - (let f ([si si] [fml* fml*]) - (cond - [(null? fml*) (values '() si r live)] - [else - (let-values ([(nfml* nsi r live) - (f (fxadd1 si) (cdr fml*))]) - (let ([v (make-frame-var si)]) - (values (cons v nfml*) - nsi - (cons (cons (car fml*) v) r) - (cons si live))))]))) - (define (bind-free* free*) - (let f ([free* free*] [idx 0] [r '()]) - (cond - [(null? free*) r] - [else - (f (cdr free*) (fxadd1 idx) - (cons (cons (car free*) (make-cp-var idx)) r))]))) - (define CaseExpr - (lambda (r save-cp?) - (lambda (x) - (record-case x - [(clambda-case info body) - (record-case info - [(case-info label fml* proper) - (let-values ([(fml* si r live) (bind-fml* fml* 1 r '())]) - (make-clambda-case - (make-case-info label fml* proper) - (Body body si r live save-cp?)))])])))) - (define (CodeExpr x) - (record-case x - [(clambda L cases free) - (let ([r (bind-free* free)]) - (make-clambda L (map (CaseExpr r (not (null? free))) cases) free))])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) - (Body body 1 '() '() #f))])) - (CodesExpr x)) - -(define (optimize-ap-check x) - (define who 'optimize-ap-check) - (define (min x y) - (if (fx< x y) x y)) - (define (Tail x f) - (record-case x - [(return v) - (let-values ([(v f) (NonTail v f)]) - (make-return v))] - [(fix lhs* rhs* body) - (make-fix lhs* rhs* (Tail body f))] - [(conditional test conseq altern) - (let-values ([(test f) (NonTail test f)]) - (make-conditional - test - (Tail conseq f) - (Tail altern f)))] - [(seq e0 e1) - (let-values ([(e0 f) (NonTail e0 f)]) - (make-seq e0 (Tail e1 f)))] - [(tailcall-cp) x] - [(new-frame base-idx size body) - (make-new-frame base-idx size (Tail body f))] - [(call-cp call-conv) - (let-values ([(x f) - (do-cp-call x f - (lambda (x f) - (values (Tail x f) 0)))]) - x)] - [else (error who "invalid tail expression ~s" (unparse x))])) - (define (do-primcall op arg* f) - (case op - [($ap-check-const) - (let ([n (constant-value (car arg*))]) - (cond - [(fx< n f) - (values (make-constant #f) (fx- f n))] - [(fx<= n 4096) - (values (make-primcall '$ap-check-const - (list (make-constant 4096))) - (fx- 4096 n))] - [else - (values (make-primcall '$ap-check-const - (list (make-constant (fx+ n 4096)))) - 4096)]))] - [($ap-check-bytes $ap-check-words) - (values (make-primcall op - (list (make-constant (fx+ (constant-value (car arg*)) - 4096)) - (cadr arg*))) - 4096)] - [else (values (make-primcall op arg*) f)])) - (define (do-cp-call x f k) - (record-case x - [(call-cp call-conv label save-cp? rp-conv si argc mask) - (record-case rp-conv - [(clambda L cases free) - (let-values ([(cases f) - (let g ([cases cases]) - (cond - [(null? cases) - (values '() f)] - [else - (let-values ([(c* f) (g (cdr cases))]) - (record-case (car cases) - [(clambda-case info body) - (let-values ([(c f0) (k body f)]) - (values - (cons (make-clambda-case info c) c*) - (min f f0)))]))]))]) - (values - (make-call-cp call-conv label save-cp? - (make-clambda L cases free) si argc mask) - f))] - [else - (values x f)])])) - (define (NonTail x f) - (record-case x - [(constant) (values x f)] - [(frame-var) (values x f)] - [(cp-var) (values x f)] - [(save-cp) (values x f)] - [(foreign-label) (values x f)] - [(primref) (values x f)] - [(closure) (values x f)] - [(call-cp call-conv) - (let-values ([(x f) (do-cp-call x f NonTail)]) - (cond - [(eq? call-conv 'foreign) - (values x f)] - [else - (values x 0)]))] - [(primcall op arg*) - (let loop ([arg* arg*] [ls '()] [f f]) - (cond - [(null? arg*) - (do-primcall op (reverse ls) f)] - [else - (let-values ([(a f) (NonTail (car arg*) f)]) - (loop (cdr arg*) (cons a ls) f))]))] - [(fix lhs* rhs* body) - (let-values ([(body f) (NonTail body f)]) - (values (make-fix lhs* rhs* body) f))] - [(conditional test conseq altern) - (let-values ([(test f) (NonTail test f)]) - (if (constant? test) - (if (constant-value test) - (NonTail conseq f) - (NonTail altern f)) - (let-values ([(conseq f0) (NonTail conseq f)] - [(altern f1) (NonTail altern f)]) - (values (make-conditional test conseq altern) - (min f0 f1)))))] - [(seq e0 e1) - (let-values ([(e0 f) (NonTail e0 f)]) - (let-values ([(e1 f) (NonTail e1 f)]) - (values (make-seq e0 e1) f)))] - [(assign lhs rhs) - (let-values ([(rhs f) (NonTail rhs f)]) - (values (make-assign lhs rhs) f))] - [(eval-cp check body) - (let-values ([(body f) (NonTail body f)]) - (values (make-eval-cp check body) f))] - [(new-frame base-idx size body) - (let-values ([(body f) (NonTail body f)]) - (values (make-new-frame base-idx size body) f))] - [(interrupt-call e0 e1) ;;; FIXME: suboptimal - (let-values ([(e0 f0) (NonTail e0 f)]) - (let-values ([(e1 f1) (NonTail e1 f0)]) - (values (make-interrupt-call e0 e1) - (min f0 f1))))] - [else (error who "invalid nontail expression ~s" (unparse x))])) - (define CaseExpr - (lambda (x) - (record-case x - [(clambda-case info body) - (make-clambda-case info (Tail body 0))]))) - (define (CodeExpr x) - (record-case x - [(clambda L cases free) - (make-clambda L (map CaseExpr cases) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) - (Tail body 0))])) - (CodesExpr x)) - (begin ;;; DEFINITIONS (define fx-shift 2) (define fx-mask #x03) @@ -3151,1770 +2109,6 @@ (obj (primref->symbol op)))) -(define (generate-code x) - (define who 'generate-code) - (define (rp-label x L_multi) - (case x - [(value) (label-address (sl-mv-error-rp-label))] - [(effect) (label-address (sl-mv-ignore-rp-label))] - [else - (if (clambda? x) - (label-address L_multi) - (error who "invalid rp-convention ~s" x))])) - (define unique-label - (lambda () - (label (gensym)))) - (define handlers '()) - (define (add-handler! ls) - (set-cdr! handlers (append ls (cdr handlers)))) - (define (constant-val x) - (cond - [(fixnum? x) (obj x)] - [(boolean? x) (int (if x bool-t bool-f))] - [(null? x) (int nil)] - [(char? x) (int (fx+ (fxsll (char->integer x) char-shift) char-tag))] - [(eq? x (void)) (int void-object)] - [else (obj x)])) - (define (cond-branch op Lt Lf ac) - (define (opposite x) - (cond - [(assq x '([je jne] [jne je] [jl jge] [jle jg] [jg jle] [jge jl])) - => cadr] - [else (error who "BUG: no opposite of ~s" x)])) - (unless (or Lt Lf) - (error 'cond-branch "no labels")) - (cond - [(not Lf) (cons (list op Lt) ac)] - [(not Lt) (cons (list (opposite op) Lf) ac)] - [else (list* (list op Lt) (jmp Lf) ac)])) - (define (indirect-type-pred pri-mask pri-tag sec-mask sec-tag rand* Lt Lf ac) - (NonTail (car rand*) - (cond - [(and Lt Lf) - (list* (movl eax ebx) - (andl (int pri-mask) ebx) - (cmpl (int pri-tag) ebx) - (jne Lf) - (movl (mem (fx- 0 pri-tag) eax) ebx) - (if sec-mask - (andl (int sec-mask) ebx) - '(nop)) - (cmpl (int sec-tag) ebx) - (jne Lf) - (jmp Lt) - ac)] - [Lf - (list* (movl eax ebx) - (andl (int pri-mask) ebx) - (cmpl (int pri-tag) ebx) - (jne Lf) - (movl (mem (fx- 0 pri-tag) eax) ebx) - (if sec-mask - (andl (int sec-mask) ebx) - '(nop)) - (cmpl (int sec-tag) ebx) - (jne Lf) - ac)] - [Lt - (let ([L_END (unique-label)]) - (list* (movl eax ebx) - (andl (int pri-mask) ebx) - (cmpl (int pri-tag) ebx) - (jne L_END) - (movl (mem (fx- 0 pri-tag) eax) ebx) - (if sec-mask - (andl (int sec-mask) ebx) - '(nop)) - (cmpl (int sec-tag) ebx) - (je Lt) - L_END - ac))] - [else ac]))) - (define (type-pred mask tag rand* Lt Lf ac) - (let* ([ac (cond-branch 'je Lt Lf ac)] - [ac (cons (cmpl (int tag) eax) ac)] - [ac (if mask - (cons (andl (int mask) eax) ac) - ac)]) - (NonTail (car rand*) ac))) - (define (compare-and-branch op rand* Lt Lf ac) - (define (opposite x) - (cadr (assq x '([je je] [jl jg] [jle jge] [jg jl] [jge jle])))) - (cond - [(and (constant? (car rand*)) (constant? (cadr rand*))) - (list* - (movl (Simple (car rand*)) eax) - (cmpl (Simple (cadr rand*)) eax) - (cond-branch op Lt Lf ac))] - [(constant? (cadr rand*)) - (list* - (cmpl (Simple (cadr rand*)) (Simple (car rand*))) - (cond-branch op Lt Lf ac))] - [(constant? (car rand*)) - (list* - (cmpl (Simple (car rand*)) (Simple (cadr rand*))) - (cond-branch (opposite op) Lt Lf ac))] - [else - (list* - (movl (Simple (car rand*)) eax) - (cmpl (Simple (cadr rand*)) eax) - (cond-branch op Lt Lf ac))])) - (define (do-pred-prim op rand* Lt Lf ac) - (case op - [(fixnum?) (type-pred fx-mask fx-tag rand* Lt Lf ac)] - [(pair?) (type-pred pair-mask pair-tag rand* Lt Lf ac)] - [(char?) (type-pred char-mask char-tag rand* Lt Lf ac)] - [(string?) (type-pred string-mask string-tag rand* Lt Lf ac)] - [(bytevector?) (type-pred bytevector-mask bytevector-tag rand* Lt Lf ac)] - [(symbol?) - (indirect-type-pred vector-mask vector-tag #f - symbol-record-tag rand* Lt Lf ac)] - [(ratnum?) - (indirect-type-pred vector-mask vector-tag #f - ratnum-tag rand* Lt Lf ac)] - [(procedure?) (type-pred closure-mask closure-tag rand* Lt Lf ac)] - [(boolean?) (type-pred bool-mask bool-tag rand* Lt Lf ac)] - [(null?) (type-pred #f nil rand* Lt Lf ac)] - [($unbound-object?) (type-pred #f unbound rand* Lt Lf ac)] - [($forward-ptr?) (type-pred #f -1 rand* Lt Lf ac)] - [(not) (Pred (car rand*) Lf Lt ac)] - [(eof-object?) (type-pred #f eof rand* Lt Lf ac)] - [(bwp-object?) (type-pred #f bwp-object rand* Lt Lf ac)] - [(code?) - (indirect-type-pred vector-mask vector-tag #f code-tag - rand* Lt Lf ac)] - [($fxzero?) (type-pred #f 0 rand* Lt Lf ac)] - [($fx= $char= eq?) (compare-and-branch 'je rand* Lt Lf ac)] - [($fx< $char<) (compare-and-branch 'jl rand* Lt Lf ac)] - [($fx<= $char<=) (compare-and-branch 'jle rand* Lt Lf ac)] - [($fx> $char>) (compare-and-branch 'jg rand* Lt Lf ac)] - [($fx>= $char>=) (compare-and-branch 'jge rand* Lt Lf ac)] - [($bignum-positive?) - (list* - (movl (Simple (car rand*)) eax) - (movl (mem (- 0 record-tag) eax) eax) - (andl (int bignum-sign-mask) eax) - (cond-branch 'je Lt Lf ac))] - [(vector?) - (indirect-type-pred vector-mask vector-tag fx-mask fx-tag - rand* Lt Lf ac)] - [($record?) - (indirect-type-pred record-pmask record-ptag record-pmask record-ptag - rand* Lt Lf ac)] - [(output-port?) - (indirect-type-pred - vector-mask vector-tag #f output-port-tag rand* Lt Lf ac)] - [(input-port?) - (indirect-type-pred - vector-mask vector-tag #f input-port-tag rand* Lt Lf ac)] - [(port?) - (indirect-type-pred - vector-mask vector-tag port-mask port-tag rand* Lt Lf ac)] - [(bignum?) - (indirect-type-pred - vector-mask vector-tag bignum-mask bignum-tag rand* Lt Lf ac)] - [(flonum?) - (indirect-type-pred - vector-mask vector-tag #f flonum-tag rand* Lt Lf ac)] - [($record/rtd?) - (cond - [Lf - (list* (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int vector-mask) eax) - (cmpl (int vector-tag) eax) - (jne Lf) - (movl (Simple (cadr rand*)) eax) - (cmpl (mem (fx- disp-record-rtd vector-tag) ebx) eax) - (jne Lf) - (if Lt - (cons (jmp Lt) ac) - ac))] - [Lt - (let ([Ljoin (unique-label)]) - (list* (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int vector-mask) eax) - (cmpl (int vector-tag) eax) - (jne Ljoin) - (movl (Simple (cadr rand*)) eax) - (cmpl (mem (fx- disp-record-rtd vector-tag) ebx) eax) - (je Lt) - Ljoin - ac))] - [else ac])] - [(immediate?) - (cond - [(and Lt Lf) - (list* (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int fx-mask) ebx) - (je Lt) - (andl (int 7) eax) - (cmpl (int 7) eax) - (je Lt) - (jmp Lf) - ac)] - [Lt - (list* (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int fx-mask) ebx) - (je Lt) - (andl (int 7) eax) - (cmpl (int 7) eax) - (je Lt) - ac)] - [Lf - (let ([Ljoin (unique-label)]) - (list* - (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int fx-mask) ebx) - (je Ljoin) - (andl (int 7) eax) - (cmpl (int 7) eax) - (jne Lf) - Ljoin - ac))] - [else ac])] - [($ap-check-words) - (record-case (car rand*) - [(constant i) - (list* (movl (pcb-ref 'allocation-redline) eax) - (subl (Simple (cadr rand*)) eax) - (subl (int i) eax) - (cmpl eax apr) - (cond-branch 'jge Lt Lf ac))] - [else (error who "ap-check-words")])] - [($ap-check-bytes) - (record-case (car rand*) - [(constant i) - (list* (movl (Simple (cadr rand*)) eax) - (negl eax) - (addl (pcb-ref 'allocation-redline) eax) - (subl (int i) eax) - (cmpl eax apr) - (cond-branch 'jge Lt Lf ac))] - [else (error who "ap-check-bytes")])] - [($ap-check-const) - (record-case (car rand*) - [(constant i) - (if (fx<= i pagesize) - (list* - (cmpl (pcb-ref 'allocation-redline) apr) - (cond-branch 'jge Lt Lf ac)) - (list* - (movl (pcb-ref 'allocation-redline) eax) - (subl (int i) eax) - (cmpl eax apr) - (cond-branch 'jge Lt Lf ac)))] - [else (error who "ap-check-const")])] - [($fp-at-base) - (list* - (movl (pcb-ref 'frame-base) eax) - (subl (int wordsize) eax) - (cmpl eax fpr) - (cond-branch 'je Lt Lf ac))] - [($interrupted?) - (list* (movl (pcb-ref 'interrupted) eax) - (cmpl (int 0) eax) - (cond-branch 'jne Lt Lf ac))] - [($fp-overflow) - (list* (cmpl (pcb-ref 'frame-redline) fpr) - (cond-branch 'jle Lt Lf ac))] - [($memq) - (record-case (cadr rand*) - [(constant ls) - (let-values ([(Lt ac) - (if Lt - (values Lt ac) - (let ([L (unique-label)]) - (values L (cons L ac))))]) - (NonTail (car rand*) - (let f ([ls ls]) - (cond - [(null? ls) - (if Lf (list* (jmp Lf) ac) ac)] - [else - (list* (cmpl (Simple (make-constant (car ls))) eax) - (je Lt) - (f (cdr ls)))]))))] - [else - (error 'compile - "BUG: second arg to $memq should be constant")])] - [($engine-check) - (list* (addl (int 1) (pcb-ref 'engine-counter)) - (cond-branch 'je Lt Lf ac))] - [($vector-ref top-level-value car cdr $record-ref) - (do-value-prim op rand* - (do-simple-test eax Lt Lf ac))] - [(cons void $fxadd1 $fxsub1) - ;;; always true - (do-effect-prim op rand* - (cond - [(not Lt) ac] - [else (cons (jmp Lt) ac)]))] - [else - (error 'pred-prim "HERE unhandled ~s" op)])) - (define (do-pred->value-prim op rand* ac) - (case op - [else - (let ([Lf (unique-label)] [Lj (unique-label)]) - (do-pred-prim op rand* #f Lf - (list* (movl (constant-val #t) eax) - (jmp Lj) - Lf - (movl (constant-val #f) eax) - Lj - ac)))])) - (define (indirect-ref arg* off ac) - (list* - (movl (Simple (car arg*)) eax) - (movl (mem off eax) eax) - ac)) - (define (do-make-port tag args ac) - (let f ([args args] [idx disp-vector-data]) - (cond - [(null? args) - (if (fx= idx port-size) - (list* - (movl (int tag) (mem 0 apr)) - (movl apr eax) - (addl (int port-size) apr) - (addl (int vector-tag) eax) - ac) - (error 'do-make-port "BUG"))] - [else - (list* - (movl (Simple (car args)) eax) - (movl eax (mem idx apr)) - (f (cdr args) (fx+ idx wordsize)))]))) - (define (do-value-prim op arg* ac) - (case op - [(eof-object) (cons (movl (int eof) eax) ac)] - [(void) (cons (movl (int void-object) eax) ac)] - [($fxadd1) - (list* (movl (Simple (car arg*)) eax) - (addl (constant-val 1) eax) - ac)] - [(fxadd1) - (NonTail (car arg*) - (list* (movl eax ebx) - (andl (int fx-mask) ebx) - (jne (label (sl-fxadd1-error-label))) - (addl (int (fxsll 1 fx-shift)) eax) - (jo (label (sl-fxadd1-error-label))) - ac))] - [(fx+) - (let foo ([a0 (car arg*)] [a1 (cadr arg*)]) - (cond - [(simple? a1) - (cond - [(constant? a1) - (let ([v (constant-value a1)]) - (cond - [(fixnum? v) - (let ([L - (let ([L (unique-label)]) - (add-handler! - (list L - (movl (Simple a1) ebx) - (jmp (label (sl-fx+-overflow-label))))) - L)]) - (NonTail a0 - (list* - (movl eax ebx) - (andl (int fx-mask) ebx) - ;;; arg in eax - (jne (label (sl-fx+-type-label))) - (addl (Simple a1) eax) - (jo L) - ac)))] - [else - (NonTail a0 - (list* - (movl (Simple a1) eax) - ;;; arg in eax - (jmp (label (sl-fx+-type-label))) - ac))]))] - [else - (NonTail a0 - (list* - (movl eax ecx) - (movl (Simple a1) ebx) - (orl ebx ecx) - (andl (int fx-mask) ecx) - ;;; args in eax, ebx - (jne (label (sl-fx+-types-label))) - (addl ebx eax) - ;;; args in eax (ac),ebx - (jo (label (sl-fx+-overflow-label))) - ac))])] - [else (foo a1 a0)]))] - [(fxsub1) - (NonTail (car arg*) - (list* (movl eax ebx) - (andl (int fx-mask) ebx) - (jne (label (sl-fxsub1-error-label))) - (subl (int (fxsll 1 fx-shift)) eax) - (jo (label (sl-fxsub1-error-label))) - ac))] - [($fxsub1) - (list* (movl (Simple (car arg*)) eax) - (addl (constant-val -1) eax) - ac)] - [($fx+) - (list* (movl (Simple (car arg*)) eax) - (addl (Simple (cadr arg*)) eax) - ac)] - [($fx-) - (list* (movl (Simple (car arg*)) eax) - (subl (Simple (cadr arg*)) eax) - ac)] - ;X; [(fx-) - ;X; (let ([a0 (car arg*)] [a1 (cadr arg*)]) - ;X; (cond - ;X; [(simple? a1) - ;X; (cond - ;X; [(and (constant? a1) (fixnum? (constant-value a1))) - ;X; (NonTail a0 - ;X; (movl eax ebx) - ;X; (andl (int fx-mask) ebx) - ;X; (jne (label SL_fx-_eax_error)) - ;X; (subl (Simple a1) eax) - ;X; (jo (label SL_fx-_overflow)) - ;X; ac)] - ;X; [else - ;X; (NonTail a0 - ;X; (movl eax ebx) - ;X; (movl (Simple a1) ecx) - ;X; (orl ecx ebx) - ;X; (andl (int fx-mask) ebx) - ;X; (jne (label SL_fx-_eax/ecx_error)) - ;X; (subl ecx eax) - ;X; (jo (label SL_fx-_overflow)) - ;X; ac)])] - ;X; ljfhjdhfkjdhfjk] - [($fx*) - (cond - [(constant? (car arg*)) - (record-case (car arg*) - [(constant c) - (unless (fixnum? c) - (error who "invalid arg ~s to fx*" c)) - (list* (movl (Simple (cadr arg*)) eax) - (imull (int c) eax) - ac)])] - [(constant? (cadr arg*)) - (record-case (cadr arg*) - [(constant c) - (unless (fixnum? c) - (error who "invalid arg ~s to fx*" c)) - (list* (movl (Simple (car arg*)) eax) - (imull (int c) eax) - ac)])] - [else - (list* (movl (Simple (car arg*)) eax) - (sarl (int fx-shift) eax) - (imull (Simple (cadr arg*)) eax) - ac)])] - [($fxquotient) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ecx) - (cltd) - (idivl ecx) - (sall (int fx-shift) eax) - ac)] - [($fxmodulo) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl eax ecx) - (xorl ebx ecx) - (sarl (int (fxsub1 (fx* wordsize 8))) ecx) - (andl ebx ecx) - (cltd) ;;; sign extend eax into edx:eax - (idivl ebx) ;;; divide edx:eax by ebx - ;;; quotient goes to eax - ;;; remainder to edx - (movl edx eax) - (addl ecx eax) - ac)] - [($fxlogor) - (list* (movl (Simple (car arg*)) eax) - (orl (Simple (cadr arg*)) eax) - ac)] - [($fxlogand) - (list* (movl (Simple (car arg*)) eax) - (andl (Simple (cadr arg*)) eax) - ac)] - [($fxlogxor) - (list* (movl (Simple (car arg*)) eax) - (xorl (Simple (cadr arg*)) eax) - ac)] - [($fxsra) - (record-case (cadr arg*) - [(constant i) - (unless (fixnum? i) (error who "invalid arg to fxsra")) - (list* (movl (Simple (car arg*)) eax) - (sarl (int (fx+ i fx-shift)) eax) - (sall (int fx-shift) eax) - ac)] - [else - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ecx) - (sarl (int fx-shift) ecx) - (sarl (int fx-shift) eax) - (sarl cl eax) - (sall (int fx-shift) eax) - ac)])] - [($fxsll) - (record-case (cadr arg*) - [(constant i) - (unless (fixnum? i) (error who "invalid arg to fxsll")) - (list* (movl (Simple (car arg*)) eax) - (sall (int i) eax) - ac)] - [else - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ecx) - (sarl (int fx-shift) ecx) - (sall cl eax) - ac)])] - [($fixnum->char) - (list* (movl (Simple (car arg*)) eax) - (sall (int (fx- char-shift fx-shift)) eax) - (orl (int char-tag) eax) - ac)] - [($char->fixnum) - (list* (movl (Simple (car arg*)) eax) - (sarl (int (fx- char-shift fx-shift)) eax) - ac)] - [($fxlognot) - (list* (movl (Simple (car arg*)) eax) - (orl (int fx-mask) eax) - (notl eax) - ac)] - [($car) (indirect-ref arg* (fx- disp-car pair-tag) ac)] - [($cdr) (indirect-ref arg* (fx- disp-cdr pair-tag) ac)] - [($vector-length) - (indirect-ref arg* (fx- disp-vector-length vector-tag) ac)] - [($bytevector-length) - (indirect-ref arg* (fx- disp-bytevector-length bytevector-tag) ac)] - [($string-length) - (indirect-ref arg* (fx- disp-string-length string-tag) ac)] - [($bignum-size) - (indirect-ref arg* (fx- 0 record-tag) - (list* - (sarl (int bignum-length-shift) eax) - (sall (int (* 2 fx-shift)) eax) - ac))] - [($symbol-string) - (indirect-ref arg* (fx- disp-symbol-record-string record-tag) ac)] - [($symbol-unique-string) - (indirect-ref arg* (fx- disp-symbol-record-ustring record-tag) ac)] - [($symbol-value) - (indirect-ref arg* (fx- disp-symbol-record-value record-tag) ac)] - [($tcbucket-key) - (indirect-ref arg* (fx- disp-tcbucket-key vector-tag) ac)] - [($tcbucket-val) - (indirect-ref arg* (fx- disp-tcbucket-val vector-tag) ac)] - [($tcbucket-next) - (indirect-ref arg* (fx- disp-tcbucket-next vector-tag) ac)] - [($port-handler) - (indirect-ref arg* (fx- disp-port-handler vector-tag) ac)] - [($port-input-buffer) - (indirect-ref arg* (fx- disp-port-input-buffer vector-tag) ac)] - [($port-input-index) - (indirect-ref arg* (fx- disp-port-input-index vector-tag) ac)] - [($port-input-size) - (indirect-ref arg* (fx- disp-port-input-size vector-tag) ac)] - [($port-output-buffer) - (indirect-ref arg* (fx- disp-port-output-buffer vector-tag) ac)] - [($port-output-index) - (indirect-ref arg* (fx- disp-port-output-index vector-tag) ac)] - [($port-output-size) - (indirect-ref arg* (fx- disp-port-output-size vector-tag) ac)] - [($ratnum-n) - (indirect-ref arg* (fx- disp-ratnum-num vector-tag) ac)] - [($ratnum-d) - (indirect-ref arg* (fx- disp-ratnum-den vector-tag) ac)] - [(pointer-value) - (list* - (movl (Simple (car arg*)) eax) - (sarl (int fx-shift) eax) - (sall (int fx-shift) eax) - ac)] - [($symbol-plist) - (indirect-ref arg* (fx- disp-symbol-record-plist record-tag) ac)] - [($record-rtd) - (indirect-ref arg* (fx- disp-record-rtd record-ptag) ac)] - [($constant-ref) - (list* (movl (Simple (car arg*)) eax) ac)] - [(car cdr) - (let ([x (car arg*)]) - (NonTail x - (list* - (movl eax ebx) - (andl (int pair-mask) eax) - (cmpl (int pair-tag) eax) - (if (eq? op 'car) - (list* - (jne (label (sl-car-error-label))) - (movl (mem (fx- disp-car pair-tag) ebx) eax) - ac) - (list* - (jne (label (sl-cdr-error-label))) - (movl (mem (fx- disp-cdr pair-tag) ebx) eax) - ac)))))] - [(cadr) - (NonTail (car arg*) - (list* - (movl eax ebx) - (andl (int pair-mask) eax) - (cmpl (int pair-tag) eax) - (jne (label (sl-cadr-error-label))) - (movl (mem (fx- disp-cdr pair-tag) ebx) eax) - (movl eax ecx) - (andl (int pair-mask) eax) - (cmpl (int pair-tag) eax) - (jne (label (sl-cadr-error-label))) - (movl (mem (fx- disp-car pair-tag) ecx) eax) - ac))] - [(top-level-value) - (let ([x (car arg*)]) - (cond - [(constant? x) - (let ([v (constant-value x)]) - (cond - [(symbol? v) - (list* - (movl (mem (fx- disp-symbol-record-value record-tag) (obj v)) eax) - (movl (obj v) ebx) - (cmpl (int unbound) eax) - (je (label (sl-top-level-value-error-label))) - ac)] - [else - (list* - (movl (obj v) ebx) - (jmp (label (sl-top-level-value-error-label))) - ac)]))] - [else - (NonTail x - (list* - (movl eax ebx) - (andl (int record-mask) eax) - (cmpl (int record-tag) eax) - (jne (label (sl-top-level-value-error-label))) - (movl (mem (- record-tag) ebx) eax) - (cmpl (int symbol-record-tag) eax) - (jne (label (sl-top-level-value-error-label))) - (movl (mem (fx- disp-symbol-record-value record-tag) ebx) eax) - (cmpl (int unbound) eax) - (je (label (sl-top-level-value-error-label))) - ac))]))] - [($vector-ref) - (list* (movl (Simple (car arg*)) ebx) - (addl (Simple (cadr arg*)) ebx) - (movl (mem (fx- disp-vector-data vector-tag) ebx) eax) - ac)] - [($record-ref) - (list* (movl (Simple (car arg*)) ebx) - (addl (Simple (cadr arg*)) ebx) - (movl (mem (fx- disp-record-data record-ptag) ebx) eax) - ac)] - [($code-ref) - (list* (movl (Simple (cadr arg*)) ebx) - (sarl (int fx-shift) ebx) - (addl (Simple (car arg*)) ebx) - (movl (int 0) eax) - (movb (mem (fx- disp-code-data vector-tag) ebx) ah) - (sarl (int (fx- 8 fx-shift)) eax) - ac)] - [($bytevector-s8-ref) - (list* (movl (Simple (cadr arg*)) ebx) - (sarl (int fx-shift) ebx) - (addl (Simple (car arg*)) ebx) - (movb (mem (fx- disp-bytevector-data bytevector-tag) ebx) al) - (sall (int (* (sub1 wordsize) 8)) eax) - (sarl (int (- (* (sub1 wordsize) 8) fx-shift)) eax) - ac)] - [($bytevector-u8-ref) - (list* (movl (Simple (cadr arg*)) ebx) - (sarl (int fx-shift) ebx) - (addl (Simple (car arg*)) ebx) - (movl (int 0) eax) - (movb (mem (fx- disp-bytevector-data bytevector-tag) ebx) al) - (sall (int fx-shift) eax) - ac)] - [($bignum-byte-ref) - (list* (movl (Simple (cadr arg*)) ebx) - (sarl (int fx-shift) ebx) - (addl (Simple (car arg*)) ebx) - (movl (int 0) eax) - (movb (mem (fx- disp-bignum-data record-tag) ebx) al) - (sall (int fx-shift) eax) - ac)] - ; STRING - [($string-ref) - (list* (movl (Simple (cadr arg*)) ebx) - (addl (Simple (car arg*)) ebx) - (movl (mem (fx- disp-string-data string-tag) ebx) eax) - ac)] - [($string-ref) - (list* (movl (Simple (cadr arg*)) ebx) - (sarl (int fx-shift) ebx) - (addl (Simple (car arg*)) ebx) - (movl (int char-tag) eax) - (movb (mem (fx- disp-string-data string-tag) ebx) ah) - ac)] - ; STRING - [($make-string) - (list* (movl (Simple (car arg*)) ebx) - (movl ebx (mem disp-string-length apr)) - (movl apr eax) - (addl (int string-tag) eax) - (addl ebx apr) - (addl (int (fx+ disp-string-data (fxsub1 object-alignment))) apr) - (sarl (int align-shift) apr) - (sall (int align-shift) apr) - ac)] - [($make-string) - (list* (movl (Simple (car arg*)) ebx) - (movl ebx (mem disp-string-length apr)) - (movl apr eax) - (addl (int string-tag) eax) - (sarl (int fx-shift) ebx) - (addl ebx apr) - (movb (int 0) (mem disp-string-data apr)) - (addl (int (fx+ disp-string-data object-alignment)) apr) - (sarl (int align-shift) apr) - (sall (int align-shift) apr) - ac)] - [($make-bytevector) - (list* (movl (Simple (car arg*)) ebx) - (movl ebx (mem disp-bytevector-length apr)) - (movl apr eax) - (addl (int bytevector-tag) eax) - (sarl (int fx-shift) ebx) - (addl ebx apr) - (movb (int 0) (mem disp-bytevector-data apr)) - (addl (int (fx+ disp-bytevector-data object-alignment)) apr) - (sarl (int align-shift) apr) - (sall (int align-shift) apr) - ac)] - [($make-vector) - (list* (movl (Simple (car arg*)) ebx) - (movl ebx (mem disp-vector-length apr)) - (movl apr eax) - (addl (int vector-tag) eax) - (addl ebx apr) - (addl (int (fx+ disp-vector-data (fxsub1 object-alignment))) apr) - (sarl (int align-shift) apr) - (sall (int align-shift) apr) - ac)] - [($make-record) - (list* (movl (Simple (car arg*)) eax) - (movl eax (mem disp-record-rtd apr)) - (movl apr eax) - (addl (int record-ptag) eax) - (addl (Simple (cadr arg*)) apr) - (addl (int (fx+ disp-record-data (fxsub1 object-alignment))) apr) - (sarl (int align-shift) apr) - (sall (int align-shift) apr) - ac)] - [(cons) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl eax (mem disp-car apr)) - (movl ebx (mem disp-cdr apr)) - (leal (mem pair-tag apr) eax) - (addl (int (align pair-size)) apr) - ac)] - [(list) - (cond - [(null? arg*) (NonTail (make-constant '()) ac)] - [else - (list* - (addl (int pair-tag) apr) - (movl apr eax) - (let f ([a (car arg*)] [d (cdr arg*)]) - (list* - (movl (Simple a) ebx) - (movl ebx (mem (fx- disp-car pair-tag) apr)) - (if (null? d) - (list* - (movl (int nil) (mem (fx- disp-cdr pair-tag) apr)) - (addl (int (fx- pair-size pair-tag)) apr) - ac) - (list* - (addl (int pair-size) apr) - (movl apr - (mem (fx- disp-cdr (fx+ pair-tag pair-size)) apr)) - (f (car d) (cdr d)))))))])] - [(list*) - (cond - [(fx= (length arg*) 1) (NonTail (car arg*) ac)] - [(fx= (length arg*) 2) (NonTail (make-primcall 'cons arg*) ac)] - [else - (list* - (addl (int pair-tag) apr) - (movl apr eax) - (let f ([a (car arg*)] [b (cadr arg*)] [d (cddr arg*)]) - (list* - (movl (Simple a) ebx) - (movl ebx (mem (fx- disp-car pair-tag) apr)) - (if (null? d) - (list* - (movl (Simple b) ebx) - (movl ebx (mem (fx- disp-cdr pair-tag) apr)) - (addl (int (fx- pair-size pair-tag)) apr) - ac) - (list* - (addl (int pair-size) apr) - (movl apr - (mem (fx- disp-cdr (fx+ pair-tag pair-size)) apr)) - (f b (car d) (cdr d)))))))])] - [($make-symbol) - (list* (movl (int symbol-record-tag) (mem 0 apr)) - (movl (Simple (car arg*)) eax) - (movl eax (mem disp-symbol-record-string apr)) - (movl (int 0) (mem disp-symbol-record-ustring apr)) - (movl (int unbound) (mem disp-symbol-record-value apr)) - (movl (int 0) (mem disp-symbol-record-proc apr)) - (movl (int nil) (mem disp-symbol-record-plist apr)) - (movl apr eax) - (addl (int record-tag) eax) - (addl (int (align symbol-record-size)) apr) - ac)] - [($make-ratnum) - (list* - (movl (int ratnum-tag) (mem 0 apr)) - (movl (Simple (car arg*)) eax) - (movl eax (mem disp-ratnum-num apr)) - (movl (Simple (cadr arg*)) eax) - (movl eax (mem disp-ratnum-den apr)) - (movl apr eax) - (addl (int vector-tag) eax) - (addl (int ratnum-size) apr) - ac)] - [($make-port/input) (do-make-port input-port-tag arg* ac)] - [($make-port/output) (do-make-port output-port-tag arg* ac)] - [($make-port/both) (do-make-port input/output-port-tag arg* ac)] - [($make-tcbucket) - (list* (movl (Simple (car arg*)) eax) - (movl eax (mem disp-tcbucket-tconc apr)) - (movl (Simple (cadr arg*)) eax) - (movl eax (mem disp-tcbucket-key apr)) - (movl (Simple (caddr arg*)) eax) - (movl eax (mem disp-tcbucket-val apr)) - (movl (Simple (cadddr arg*)) eax) - (movl eax (mem disp-tcbucket-next apr)) - (movl apr eax) - (addl (int vector-tag) eax) - (addl (int (align tcbucket-size)) apr) - ac)] - [($record) - (let ([rtd (car arg*)] - [ac - (let f ([arg* (cdr arg*)] [idx disp-record-data]) - (cond - [(null? arg*) - (list* (movl apr eax) - (addl (int vector-tag) eax) - (addl (int (align idx)) apr) - ac)] - [else - (list* (movl (Simple (car arg*)) eax) - (movl eax (mem idx apr)) - (f (cdr arg*) (fx+ idx wordsize)))]))]) - (cond - [(constant? rtd) - (list* (movl (Simple rtd) (mem 0 apr)) ac)] - [else - (list* (movl (Simple rtd) eax) (movl eax (mem 0 apr)) ac)]))] - [(vector) - (let f ([arg* arg*] [idx disp-vector-data]) - (cond - [(null? arg*) - (list* (movl apr eax) - (addl (int vector-tag) eax) - (movl (int (fx- idx disp-vector-data)) - (mem disp-vector-length apr)) - (addl (int (align idx)) apr) - ac)] - [else - (list* (movl (Simple (car arg*)) eax) - (movl eax (mem idx apr)) - (f (cdr arg*) (fx+ idx wordsize)))]))] - ; STRING - [($string) - (let f ([arg* arg*] [idx disp-string-data]) - (cond - [(null? arg*) - (list* (movl apr eax) - (addl (int string-tag) eax) - (movl (int (fx- idx disp-string-data)) - (mem disp-string-length apr)) - (addl (int (align idx)) apr) - ac)] - [else - (list* (movl (Simple (car arg*)) eax) - (movl eax (mem idx apr)) - (f (cdr arg*) (fx+ idx wordsize)))]))] - [($string) - (let f ([arg* arg*] [idx disp-string-data]) - (cond - [(null? arg*) - (list* (movb (int 0) (mem idx apr)) - (movl apr eax) - (addl (int string-tag) eax) - (movl (int (fx* (fx- idx disp-string-data) wordsize)) - (mem disp-string-length apr)) - (addl (int (align (fxadd1 idx))) apr) - ac)] - [else - (record-case (car arg*) - [(constant c) - (unless (char? c) (error who "invalid arg to string ~s" x)) - (list* (movb (int (char->integer c)) (mem idx apr)) - (f (cdr arg*) (fxadd1 idx)))] - [else - (list* (movl (Simple (car arg*)) ebx) - (movb bh (mem idx apr)) - (f (cdr arg*) (fxadd1 idx)))])]))] - [($current-frame) - (list* (movl (pcb-ref 'next-continuation) eax) ac)] - [(base-rtd) - (list* (movl (pcb-ref 'base-rtd) eax) ac)] - [($arg-list) - (list* (movl (pcb-ref 'arg-list) eax) ac)] - [($seal-frame-and-call) - (list* (movl (Simple (car arg*)) cpr) ; proc - (movl (pcb-ref 'frame-base) eax) - ; eax=baseofstack - (movl (mem (fx- 0 wordsize) eax) ebx) ; underflow handler - (movl ebx (mem (fx- 0 wordsize) fpr)) ; set - ; create a new cont record - (movl (int continuation-tag) (mem 0 apr)) - (movl fpr (mem disp-continuation-top apr)) - ; compute the size of the captured frame - (movl eax ebx) - (subl fpr ebx) - (subl (int wordsize) ebx) - ; and store it - (movl ebx (mem disp-continuation-size apr)) - ; load next cont (K 20) - (movl (pcb-ref 'next-continuation) ebx) - ; and store it - (movl ebx (mem disp-continuation-next apr)) - ; adjust ap - (movl apr eax) - (addl (int vector-tag) eax) - (addl (int continuation-size) apr) - ; store new cont in current-cont - (movl eax (pcb-ref 'next-continuation)) - ; adjust fp - (movl fpr (pcb-ref 'frame-base)) - (subl (int wordsize) fpr) - ; tail-call f - (movl eax (mem (fx- 0 wordsize) fpr)) - (movl (int (argc-convention 1)) eax) - (tail-indirect-cpr-call) - ac)] - [($code-size) - (indirect-ref arg* (fx- disp-code-instrsize vector-tag) ac)] - [($code-reloc-vector) - (indirect-ref arg* (fx- disp-code-relocsize vector-tag) ac)] - [($code-freevars) - (indirect-ref arg* (fx- disp-code-freevars vector-tag) ac)] - [($closure-code) - (indirect-ref arg* (fx- disp-closure-code closure-tag) - (list* (addl (int (fx- vector-tag disp-code-data)) eax) - ac))] - [($set-car! $set-cdr! $vector-set! $string-set! $exit - $set-symbol-value! $set-symbol-plist! - $code-set! $bytevector-set! - $set-code-object! $set-code-object+offset! $set-code-object+offset/rel! - $record-set! - $set-port-input-index! $set-port-input-size! - $set-port-output-index! $set-port-output-size!) - (do-effect-prim op arg* - (cons (movl (int void-object) eax) ac))] - [(fixnum? bignum? flonum? ratnum? immediate? $fxzero? boolean? char? pair? - vector? bytevector? string? symbol? - procedure? null? not eof-object? $fx= $fx< $fx<= $fx> $fx>= eq? - $char= $char< $char<= $char> $char>= $unbound-object? code? - $record? $record/rtd? bwp-object? port? input-port? output-port?) - (do-pred->value-prim op arg* ac)] - [($code->closure) - (list* - (movl (Simple (car arg*)) eax) - (addl (int (fx- disp-code-data vector-tag)) eax) - (movl eax (mem 0 apr)) - (movl apr eax) - (addl (int closure-tag) eax) - (addl (int (align disp-closure-data)) apr) - ac)] - [($frame->continuation) - (NonTail - (make-closure (make-code-loc (sl-continuation-code-label)) arg*) - ac)] - [($make-call-with-values-procedure) - (NonTail - (make-closure (make-code-loc (sl-cwv-label)) arg*) - ac)] - [($make-values-procedure) - (NonTail - (make-closure (make-code-loc (sl-values-label)) arg*) - ac)] - [($memq) - (record-case (cadr arg*) - [(constant ls) - (let-values ([(Lt ac) - (let ([L (unique-label)]) - (values L (cons L ac)))]) - (NonTail (car arg*) - (list* - (movl eax ebx) - (let f ([ls ls]) - (cond - [(null? ls) - (list* (movl (int bool-f) eax) ac)] - [else - (list* - (movl (obj ls) eax) - (cmpl (Simple (make-constant (car ls))) ebx) - (je Lt) - (f (cdr ls)))])))))] - [else - (error 'compile - "BUG: second arg to $memq should be constant")])] - [else - (error 'value-prim "unhandled ~s" op)])) - (define (indirect-assignment arg* offset ac) - (list* - (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem offset eax)) - ;;; record side effect - (addl (int offset) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)) - (define (do-effect-prim op arg* ac) - (case op - [($vector-set!) - (list* (movl (Simple (car arg*)) ebx) - (addl (Simple (cadr arg*)) ebx) - (addl (int (fx- disp-vector-data vector-tag)) ebx) - (movl (Simple (caddr arg*)) eax) - (movl eax (mem 0 ebx)) - ;;; record side effect - (shrl (int pageshift) ebx) - (sall (int wordshift) ebx) - (addl (pcb-ref 'dirty-vector) ebx) - (movl (int dirty-word) (mem 0 ebx)) - ac)] - [($code-set!) - (list* (movl (Simple (cadr arg*)) eax) ;;; index - (sarl (int fx-shift) eax) ;;; unfixed - (addl (Simple (car arg*)) eax) ;;; + code - (movl (Simple (caddr arg*)) ebx) ;;; value (fixnum) - (sall (int (fx- 8 fx-shift)) ebx) ;;; move to high byte - (movb bh (mem (fx- disp-code-data vector-tag) eax)) - ac)] - ; STRING - [($string-set!) - (list* (movl (Simple (cadr arg*)) eax) - (addl (Simple (car arg*)) eax) - (movl (Simple (caddr arg*)) ebx) - (movl ebx (mem (fx- disp-string-data string-tag) eax)) - ac)] - [($string-set!) - (list* (movl (Simple (cadr arg*)) eax) - (sarl (int fx-shift) eax) - (addl (Simple (car arg*)) eax) - (movl (Simple (caddr arg*)) ebx) - (movb bh (mem (fx- disp-string-data string-tag) eax)) - ac)] - [($bytevector-set!) - (list* (movl (Simple (cadr arg*)) eax) - (sarl (int fx-shift) eax) - (addl (Simple (car arg*)) eax) - (movl (Simple (caddr arg*)) ebx) - (sall (int (- 8 fx-shift)) ebx) - (movb bh (mem (fx- disp-bytevector-data bytevector-tag) eax)) - ac)] - [($set-car!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-car pair-tag) eax)) - ;;; record side effect - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-cdr!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-cdr pair-tag) eax)) - ;;; record side effect - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-tcbucket-key!) - (indirect-assignment arg* (fx- disp-tcbucket-key vector-tag) ac)] - [($set-tcbucket-val!) - (indirect-assignment arg* (fx- disp-tcbucket-val vector-tag) ac)] - [($set-tcbucket-next!) - (indirect-assignment arg* (fx- disp-tcbucket-next vector-tag) ac)] - [($set-tcbucket-tconc!) - (indirect-assignment arg* (fx- disp-tcbucket-tconc vector-tag) ac)] - [($set-port-input-index!) - (list* - (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-port-input-index vector-tag) eax)) - ac)] - [($set-port-input-size!) - (list* - (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl (int 0) (mem (fx- disp-port-input-index vector-tag) eax)) - (movl ebx (mem (fx- disp-port-input-size vector-tag) eax)) - ac)] - [($set-port-output-index!) - (list* - (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-port-output-index vector-tag) eax)) - ac)] - [($set-port-output-size!) - (list* - (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl (int 0) (mem (fx- disp-port-output-index vector-tag) eax)) - (movl ebx (mem (fx- disp-port-output-size vector-tag) eax)) - ac)] - [($set-symbol-value!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-record-value record-tag) eax)) - ;;; record side effect - (addl (int (fx- disp-symbol-record-value record-tag)) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-symbol-plist!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-record-plist record-tag) eax)) - ;;; record side effect - (addl (int (fx- disp-symbol-record-plist record-tag)) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-symbol-unique-string!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-record-ustring record-tag) eax)) - ;;; record side effect - (addl (int (fx- disp-symbol-record-ustring record-tag)) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-symbol-string!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-record-string record-tag) eax)) - ;;; record side effect - (addl (int (fx- disp-symbol-record-string record-tag)) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($record-set!) - (list* (movl (Simple (car arg*)) ebx) - (addl (Simple (cadr arg*)) ebx) - (movl (Simple (caddr arg*)) eax) - (addl (int (fx- disp-record-data record-ptag)) ebx) - (movl eax (mem 0 ebx)) - ;;; record side effect - (shrl (int pageshift) ebx) - (sall (int wordshift) ebx) - (addl (pcb-ref 'dirty-vector) ebx) - (movl (int dirty-word) (mem 0 ebx)) - ac)] - [($unset-interrupted!) - (list* (movl (int 0) (pcb-ref 'interrupted)) - ac)] - [(cons pair? void $fxadd1 $fxsub1 $record-ref $fx= - symbol? eq?) - (let f ([arg* arg*]) - (cond - [(null? arg*) ac] - [else - (Effect (car arg*) (f (cdr arg*)))]))] - [(car cdr top-level-value) ;;; may signal an error - (do-value-prim op arg* ac)] - [else - (error 'do-effect-prim "unhandled op ~s" op)])) - (define (do-simple-test x Lt Lf ac) - (unless (or Lt Lf) - (error 'Pred "no labels")) - (cond - [(not Lt) - (list* (cmpl (int bool-f) x) (je Lf) ac)] - [(not Lf) - (list* (cmpl (int bool-f) x) (jne Lt) ac)] - [else - (list* (cmpl (int bool-f) x) (je Lf) (jmp Lt) ac)])) - (define (simple? x) - (record-case x - [(cp-var) #t] - [(frame-var) #t] - [(constant) #t] - [(code-loc) #t] - [(primref) #t] - [(closure) #t] - [else #f])) - (define (Simple x) - (record-case x - [(cp-var i) - (mem (fx+ (fx* i wordsize) (fx- disp-closure-data closure-tag)) cpr)] - [(frame-var i) (mem (fx* i (fx- 0 wordsize)) fpr)] - [(constant c) (constant-val c)] - [(code-loc label) (label-address label)] - [(primref op) (primref-loc op)] - [(closure label free) - (cond - [(null? free) (obj x)] - [else (error 'Simple "BUG: not a thunk ~s" x)])] - [else (error 'Simple "what ~s" x)])) - (define (do-fix lhs* rhs* ac) - ;;; 1. first, set the code pointers in the right places - ;;; 2. next, for every variable appearing in the rhs* but is not in - ;;; the lhs*, load it once and set it everywhere it occurs. - ;;; 3. next, compute the values of the lhs*, and for every computed - ;;; value, store it on the stack, and set it everywhere it occurs - ;;; in the rhs* - ;;; 4. that's it. - (define (closure-size x) - (align (fx+ disp-closure-data - (fx* wordsize (length (closure-free* x)))))) - (define (assign-codes rhs* n* i ac) - (cond - [(null? rhs*) ac] - [else - (record-case (car rhs*) - [(closure label free*) - (cons (movl (Simple label) (mem i apr)) - (assign-codes - (cdr rhs*) (cdr n*) (fx+ i (car n*)) ac))])])) - (define (whack-free x i n* rhs* ac) - (cond - [(null? rhs*) ac] - [else - (let ([free (closure-free* (car rhs*))]) - (let f ([free free] [j (fx+ i disp-closure-data)]) - (cond - [(null? free) - (whack-free x (fx+ i (car n*)) (cdr n*) (cdr rhs*) ac)] - [(eq? (car free) x) - (cons - (movl eax (mem j apr)) - (f (cdr free) (fx+ j wordsize)))] - [else (f (cdr free) (fx+ j wordsize))])))])) - (define (assign-nonrec-free* rhs* all-rhs* n* seen ac) - (cond - [(null? rhs*) ac] - [else - (let f ([ls (closure-free* (car rhs*))] [seen seen]) - (cond - [(null? ls) - (assign-nonrec-free* (cdr rhs*) all-rhs* n* seen ac)] - [(memq (car ls) seen) (f (cdr ls) seen)] - [else - (cons - (movl (Simple (car ls)) eax) - (whack-free (car ls) 0 n* all-rhs* - (f (cdr ls) (cons (car ls) seen))))]))])) - (define (assign-rec-free* lhs* rhs* all-n* ac) - (list* (movl apr eax) - (addl (int closure-tag) eax) - (let f ([lhs* lhs*] [n* all-n*]) - (cond - [(null? (cdr lhs*)) - (cons - (movl eax (Simple (car lhs*))) - (whack-free (car lhs*) 0 all-n* rhs* ac))] - [else - (cons - (movl eax (Simple (car lhs*))) - (whack-free (car lhs*) 0 all-n* rhs* - (cons - (addl (int (car n*)) eax) - (f (cdr lhs*) (cdr n*)))))])))) - (define (sum ac ls) - (cond - [(null? ls) ac] - [else (sum (fx+ ac (car ls)) (cdr ls))])) - (define partition - (lambda (lhs* rhs*) - (let f ([lhs* lhs*] [rhs* rhs*] - [tlhs* '()] [trhs* '()] - [clhs* '()] [crhs* '()]) - (cond - [(null? lhs*) - (values tlhs* trhs* clhs* crhs*)] - [(null? (closure-free* (car rhs*))) - (f (cdr lhs*) (cdr rhs*) - (cons (car lhs*) tlhs*) (cons (car rhs*) trhs*) - clhs* crhs*)] - [else - (f (cdr lhs*) (cdr rhs*) - tlhs* trhs* - (cons (car lhs*) clhs*) - (cons (car rhs*) crhs*))])))) - (define do-closures - (lambda (lhs* rhs* ac) - (let* ([n* (map closure-size rhs*)]) - (assign-codes rhs* n* 0 - (assign-nonrec-free* rhs* rhs* n* lhs* - (assign-rec-free* lhs* rhs* n* - (cons (addl (int (sum 0 n*)) apr) ac))))))) - (define do-thunks - (lambda (lhs* rhs* ac) - (cond - [(null? lhs*) ac] - [else - (do-thunks (cdr lhs*) (cdr rhs*) - (cons (movl (obj (car rhs*)) - (idx->frame-loc - (frame-var-idx (car lhs*)))) - ac))]))) - (let-values ([(tlhs* trhs* clhs* crhs*) - (partition lhs* rhs*)]) - (cond - [(null? clhs*) - (do-thunks tlhs* trhs* ac)] - [(null? tlhs*) - (do-closures clhs* crhs* ac)] - [else - (do-thunks tlhs* trhs* - (do-closures clhs* crhs* ac))]))) - (define (frame-adjustment offset) - (fx* (fxsub1 offset) (fx- 0 wordsize))) - (define (NonTail x ac) - (record-case x - [(constant c) - (cons (movl (constant-val c) eax) ac)] - [(frame-var) - (cons (movl (Simple x) eax) ac)] - [(cp-var) - (cons (movl (Simple x) eax) ac)] - [(foreign-label L) - (cons (movl (list 'foreign-label L) eax) ac)] - [(primref c) - (cons (movl (primref-loc c) eax) ac)] - [(closure label arg*) - (cond - [(null? arg*) - (cons (movl (obj x) eax) ac)] - [else - (let f ([arg* arg*] [off disp-closure-data]) - (cond - [(null? arg*) - (list* (movl (Simple label) (mem 0 apr)) - (movl apr eax) - (addl (int (align off)) apr) - (addl (int closure-tag) eax) - ac)] - [else - (list* (movl (Simple (car arg*)) eax) - (movl eax (mem off apr)) - (f (cdr arg*) (fx+ off wordsize)))]))])] - [(conditional test conseq altern) - (let ([Lj (unique-label)] [Lf (unique-label)]) - (Pred test #f Lf - (NonTail conseq - (list* (jmp Lj) Lf (NonTail altern (cons Lj ac))))))] - [(seq e0 e1) - (Effect e0 (NonTail e1 ac))] - [(fix lhs* rhs* body) - (do-fix lhs* rhs* (NonTail body ac))] - [(primcall op rand*) - (do-value-prim op rand* ac)] - [(new-frame base-idx size body) - (NonTail body ac)] - [(call-cp) - (handle-call-cp x ac NonTail)] - [else (error 'NonTail "invalid expression ~s" x)])) - (define (Pred x Lt Lf ac) - (record-case x - [(frame-var i) - (do-simple-test (idx->frame-loc i) Lt Lf ac)] - [(cp-var i) - (do-simple-test (Simple x) Lt Lf ac)] - [(constant c) - (if c - (if Lt (cons (jmp Lt) ac) ac) - (if Lf (cons (jmp Lf) ac) ac))] - [(closure) - (if Lt (cons (jmp Lt) ac) ac)] - [(fix lhs* rhs* body) - (do-fix lhs* rhs* (Pred body Lt Lf ac))] - [(primcall op rand*) - (do-pred-prim op rand* Lt Lf ac)] - [(conditional test conseq altern) - (cond - [(not Lt) - (let ([Lj^ (unique-label)] [Lf^ (unique-label)]) - (Pred test #f Lf^ - (Pred conseq Lj^ Lf - (cons Lf^ - (Pred altern #f Lf - (cons Lj^ ac))))))] - [(not Lf) - (let ([Lj^ (unique-label)] [Lf^ (unique-label)]) - (Pred test #f Lf^ - (Pred conseq Lt Lj^ - (cons Lf^ - (Pred altern Lt #f - (cons Lj^ ac))))))] - [else - (let ([Lf^ (unique-label)]) - (Pred test #f Lf^ - (Pred conseq Lt Lf - (cons Lf^ - (Pred altern Lt Lf ac)))))])] - [(seq e0 e1) - (Effect e0 (Pred e1 Lt Lf ac))] - [(new-frame) - (NonTail x (do-simple-test eax Lt Lf ac))] - [else (error 'Pred "invalid expression ~s" x)])) - (define (idx->frame-loc i) - (mem (fx* i (fx- 0 wordsize)) fpr)) - (define (Effect x ac) - (record-case x - [(constant) ac] - [(primcall op rand*) - (do-effect-prim op rand* ac)] - [(conditional test conseq altern) - (let* ([Ljoin (unique-label)] - [ac (cons Ljoin ac)] - [altern-ac (Effect altern ac)]) - (cond - [(eq? altern-ac ac) ;; altern is nop - (let* ([conseq-ac (Effect conseq ac)]) - (cond - [(eq? conseq-ac ac) ;; conseq is nop too! - (Effect test ac)] - [else ; "when" pattern - (Pred test #f Ljoin conseq-ac)]))] - [else - (let* ([Lf (unique-label)] - [nac (list* (jmp Ljoin) Lf altern-ac)] - [conseq-ac (Effect conseq nac)]) - (cond - [(eq? conseq-ac nac) ;; "unless" pattern" - (Pred test Ljoin #f altern-ac)] - [else - (Pred test #f Lf conseq-ac)]))]))] - [(interrupt-call test handler) - (let ([Ljoin (unique-label)] - [Lint (unique-label)]) - (let ([handler - (Effect handler - (list* (jmp Ljoin) '()))]) - (add-handler! (cons Lint handler)) - (Pred test Lint #f - (cons Ljoin ac))))] - [(seq e0 e1) - (Effect e0 (Effect e1 ac))] - [(fix lhs* rhs* body) - (do-fix lhs* rhs* (Effect body ac))] - [(assign loc val) - (record-case loc - [(frame-var i) - (record-case val - [(constant c) - (cons (movl (constant-val c) (idx->frame-loc i)) ac)] - [else - (NonTail val - (cons (movl eax (idx->frame-loc i)) ac))])] - [else (error who "invalid assign loc ~s" loc)])] - [(eval-cp check body) - (cond - [check - (NonTail body - (list* - (movl eax cpr) - (andl (int closure-mask) eax) - (cmpl (int closure-tag) eax) - (jne (label (sl-nonprocedure-error-label))) - ac))] - [(primref? body) - (list* (movl (primref-loc (primref-name body)) cpr) ac)] - [else - (NonTail body (list* (movl eax cpr) ac))])] - [(save-cp loc) - (record-case loc - [(frame-var i) - (cons (movl cpr (idx->frame-loc i)) ac)] - [else (error who "invalid cpr loc ~s" x)])] - [(new-frame) (NonTail x ac)] - [(frame-var) ac] - [else (error 'Effect "invalid expression ~s" x)])) - (define (Tail x ac) - (record-case x - [(return x) - (NonTail x (cons (ret) ac))] - [(conditional test conseq altern) - (let ([L (unique-label)]) - (Pred test #f L - (Tail conseq - (cons L (Tail altern ac)))))] - [(seq e0 e1) - (Effect e0 (Tail e1 ac))] - [(fix lhs* rhs* body) - (do-fix lhs* rhs* (Tail body ac))] - [(new-frame idx size body) - (Tail body ac)] - [(tailcall-cp call-convention direct-label argc) - (case call-convention - [(normal) - (list* - (movl (int (argc-convention argc)) eax) - (tail-indirect-cpr-call) - ac)] - [(apply) - (list* - (movl (int (argc-convention argc)) eax) - (jmp (label (sl-apply-label))) - ac)] - [(direct) - (list* - (movl (int (argc-convention argc)) eax) - (jmp (label direct-label)) - ac)] - [else - (error who "invalid tail-call convention ~s" - call-convention)])] - [(call-cp) - (handle-call-cp x ac Tail)] - [else (error 'GenTail "invalid expression ~s" (unparse x))])) - (define (handle-call-cp x ac k) - (record-case x - [(call-cp call-convention direct-label save-cp? - rp-convention offset size mask) - (let* ([L_multi (gensym "L_multi")] - [ac - (record-case rp-convention - [(clambda L cases F) - (record-case (car cases) - [(clambda-case info body) - (record-case info - [(case-info L args proper) - (when (or (fx= (length args) 1) - (not proper)) - (error who "BUG: unhandles single rv")) - (list* - (subl (int (frame-adjustment offset)) fpr) - (movl (int (argc-convention 1)) eax) - (jmp (label (sl-invalid-args-label))) - (label L_multi) - (if save-cp? (movl (mem wordsize fpr) cpr) '(nop)) - (subl (int (frame-adjustment (fxadd1 offset))) fpr) - (cmpl (int (argc-convention (length args))) eax) - (jne (label (sl-invalid-args-label))) - (k body ac))])])] - [else - (list* - (if save-cp? (movl (mem 0 fpr) cpr) '(nop)) - (subl (int (frame-adjustment offset)) fpr) - ac)])] - [L_CALL (unique-label)]) - (case call-convention - [(normal) - (list* (addl (int (frame-adjustment offset)) fpr) - (movl (int (argc-convention size)) eax) - (jmp L_CALL) - ; NEW FRAME - `(byte-vector ,mask) - `(int ,(fx* offset wordsize)) - `(current-frame-offset) - (rp-label rp-convention L_multi) - `(byte 0) ; padding for indirect calls only - `(byte 0) ; direct calls are ok - L_CALL - (indirect-cpr-call) - ac)] - [(direct) - (list* (addl (int (frame-adjustment offset)) fpr) - ;(movl (int (argc-convention size)) eax) - (jmp L_CALL) - ; NEW FRAME - `(byte-vector ,mask) - `(int ,(fx* offset wordsize)) - `(current-frame-offset) - (rp-label rp-convention L_multi) - ;;; no padding for direct calls - L_CALL - (call (label direct-label)) - ac)] - [(foreign) - (list* (addl (int (frame-adjustment offset)) fpr) - (movl (int (argc-convention size)) eax) - (movl '(foreign-label "ik_foreign_call") ebx) - (jmp L_CALL) - ; NEW FRAME - (byte-vector mask) - `(int ,(fx* offset wordsize)) - `(current-frame-offset) - (rp-label rp-convention L_multi) ; should be 0, since C has 1 rv - '(byte 0) - '(byte 0) - '(byte 0) - L_CALL - (call ebx) - ac)] - [else - (error who "invalid convention ~s for call-cp" - call-convention)]))])) - (define (handle-vararg fml-count ac) - (define CONTINUE_LABEL (unique-label)) - (define DONE_LABEL (unique-label)) - (define CONS_LABEL (unique-label)) - (define LOOP_HEAD (unique-label)) - (define L_CALL (unique-label)) - (list* (cmpl (int (argc-convention (fxsub1 fml-count))) eax) - (jg (label (sl-invalid-args-label))) - (jl CONS_LABEL) - (movl (int nil) ebx) - (jmp DONE_LABEL) - CONS_LABEL - (movl (pcb-ref 'allocation-redline) ebx) - (addl eax ebx) - (addl eax ebx) - (cmpl ebx apr) - (jle LOOP_HEAD) - ; overflow - (addl eax esp) ; advance esp to cover args - (pushl cpr) ; push current cp - (pushl eax) ; push argc - (negl eax) ; make argc positive - (addl (int (fx* 4 wordsize)) eax) ; add 4 words to adjust frame size - (pushl eax) ; push frame size - (addl eax eax) ; double the number of args - (movl eax (mem (fx* -2 wordsize) fpr)) ; pass it as first arg - (movl (int (argc-convention 1)) eax) ; setup argc - (movl (primref-loc 'do-vararg-overflow) cpr) ; load handler - (jmp L_CALL) ; go to overflow handler - ; NEW FRAME - '(int 0) ; if the framesize=0, then the framesize is dynamic - '(current-frame-offset) - '(int 0) ; multiarg rp - (byte 0) - (byte 0) - L_CALL - (indirect-cpr-call) - (popl eax) ; pop framesize and drop it - (popl eax) ; reload argc - (popl cpr) ; reload cp - (subl eax fpr) ; readjust fp - LOOP_HEAD - (movl (int nil) ebx) - CONTINUE_LABEL - (movl ebx (mem disp-cdr apr)) - (movl (mem fpr eax) ebx) - (movl ebx (mem disp-car apr)) - (movl apr ebx) - (addl (int pair-tag) ebx) - (addl (int pair-size) apr) - (addl (int (fxsll 1 fx-shift)) eax) - (cmpl (int (fx- 0 (fxsll fml-count fx-shift))) eax) - (jle CONTINUE_LABEL) - DONE_LABEL - (movl ebx (mem (fx- 0 (fxsll fml-count fx-shift)) fpr)) - ac)) - (define (Entry check? x ac) - (record-case x - [(clambda-case info body) - (record-case info - [(case-info L fml* proper) - (let ([ac - (cons (label L) (Tail body ac))]) - (cond - [(and proper check?) - (list* (cmpl (int (argc-convention (length fml*))) eax) - (jne (label (sl-invalid-args-label))) - ac)] - [proper ac] - [else - (handle-vararg (length fml*) ac)]))])])) - (define make-dispatcher - (lambda (j? L L* x x* ac) - (cond - [(null? L*) (if j? (cons (jmp (label L)) ac) ac)] - [else - (record-case x - [(clambda-case info _) - (record-case info - [(case-info _ fml* proper) - (cond - [proper - (list* (cmpl (int (argc-convention (length fml*))) eax) - (je (label L)) - (make-dispatcher #t - (car L*) (cdr L*) (car x*) (cdr x*) ac))] - [else - (list* (cmpl (int (argc-convention (fxsub1 (length fml*)))) eax) - (jle (label L)) - (make-dispatcher #t - (car L*) (cdr L*) (car x*) (cdr x*) ac))])])])]))) - (define (handle-cases x x* ac) - (let ([L* (map (lambda (_) (gensym)) x*)] - [L (gensym)]) - (make-dispatcher #f L L* x x* - (let f ([x x] [x* x*] [L L] [L* L*]) - (cond - [(null? x*) - (cons (label L) (Entry 'check x ac))] - [else - (cons (label L) - (Entry #f x - (f (car x*) (cdr x*) (car L*) (cdr L*))))]))))) - (define (CodeExpr x) - (record-case x - [(clambda L cases free) - (set! handlers (list '(nop))) - (list* - (length free) - (label L) - (handle-cases (car cases) (cdr cases) handlers))])) - (record-case x - [(codes ls body) - (let ([body - (begin - (set! handlers (list '(nop))) - (Tail body handlers))]) - (cons (list* 0 - (label (gensym)) - body) - (map CodeExpr ls)))])) (module ;assembly-labels (refresh-cached-labels! @@ -5245,33 +2439,8 @@ [p (rewrite-assignments p)] [p (optimize-for-direct-jumps p)] [p (convert-closures p)] - [p (optimize-closures/lift-codes p)] - [p (introduce-primcalls p)] - [p (simplify-operands p)] - [p (insert-stack-overflow-checks p)] - [p (insert-allocation-checks p)] - [p (insert-engine-checks p)] - [p (remove-local-variables p)] - [p (optimize-ap-check p)]) - (let ([ls* (generate-code p)]) - (when (assembler-output) - (parameterize ([gensym-prefix "L"] - [print-gensym #f]) - (for-each - (lambda (ls) - (newline) - (for-each (lambda (x) (printf " ~s\n" x)) ls)) - ls*))) - (let ([code* - (assemble-sources - (lambda (x) - (if (closure? x) - (if (null? (closure-free* x)) - (code-loc-label (closure-code x)) - (error 'compile "BUG: non-thunk escaped: ~s" x)) - #f)) - ls*)]) - (car code*))))) + [p (optimize-closures/lift-codes p)]) + p )) (define (compile-core-expr->code p) (let* ([p (recordize p)] @@ -5308,9 +2477,6 @@ (lambda (expr port) (fasl-write (compile-core-expr->code expr) port))) -(define alt-compile-core-expr-to-port - (lambda (expr port) - (fasl-write (alt-compile-core-expr->code expr) port))) (define (compile-core-expr x) (let ([code (compile-core-expr->code x)]) diff --git a/src/libaltcogen.ss b/src/libaltcogen.ss index cef8633..35e4e36 100644 --- a/src/libaltcogen.ss +++ b/src/libaltcogen.ss @@ -2929,7 +2929,9 @@ (pretty-print (unparse x)))) (define (alt-cogen x) - (verify-new-cogen-input x) + (define (time-it name proc) + (proc)) + ;(verify-new-cogen-input x) (let* ( ;[foo (printf "0")] [x (remove-primcalls x)]