conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
ikarus/src/compiler-6.1.ss

3133 lines
109 KiB
Scheme
Raw Blame History

;;; 6.1: added case-lambda, dropped lambda
;;; 6.0: basic compiler
;;;
(when (eq? "" "")
(load "chez-compat.ss")
(set! primitive-ref top-level-value)
(load "libexpand-6.1.ss")
;(load "libinterpret-6.0.ss")
(load "record-case.ss")
;(#%current-eval eval)
)
(define primitive-set! set-top-level-value!)
(load "libassembler-compat-6.0.ss") ; defines make-code etc.
(load "libintelasm-6.0.ss") ; uses make-code, etc.
(load "libfasl-6.0.ss") ; uses code? etc.
(load "tests-driver.ss")
(print-gensym #f)
(gensym-prefix "L_")
(define assembler-output (make-parameter #t))
(load "set-operations.ss")
;(load "tests-5.6-req.scm")
;(load "tests-5.3-req.scm")
;(load "tests-5.2-req.scm")
;(load "tests-5.1-req.scm")
;(load "tests-4.3-req.scm")
;(load "tests-4.2-req.scm")
;(load "tests-4.1-req.scm")
;(load "tests-3.4-req.scm")
;(load "tests-3.3-req.scm")
;(load "tests-3.2-req.scm")
;(load "tests-3.1-req.scm")
;(load "tests-2.9-req.scm")
;(load "tests-2.8-req.scm")
;(load "tests-2.6-req.scm")
;(load "tests-2.4-req.scm")
;(load "tests-2.3-req.scm")
;(load "tests-2.2-req.scm")
;(load "tests-2.1-req.scm")
;(load "tests-1.9-req.scm")
;(load "tests-1.8-req.scm")
;(load "tests-1.7-req.scm")
;(load "tests-1.6-req.scm")
;(load "tests-1.5-req.scm")
;(load "tests-1.4-req.scm")
;(load "tests-1.3-req.scm")
;(load "tests-1.2-req.scm")
;(load "tests-1.1-req.scm")
(define scheme-library-files
'(["libhandlers-6.0.ss" "libhandlers.fasl"]
["libcontrol-6.1.ss" "libcontrol.fasl"]
["libcollect-6.1.ss" "libcollect.fasl"]
["librecord-6.1.ss" "librecord.fasl"]
["libcxr-6.0.ss" "libcxr.fasl"]
["libcore-6.1.ss" "libcore.fasl"]
["libio-6.1.ss" "libio.fasl"]
["libwriter-6.1.ss" "libwriter.fasl"]
["libtokenizer-6.1.ss" "libtokenizer.fasl"]
["libexpand-6.1.ss" "libexpand.fasl"]
["libinterpret-6.1.ss" "libinterpret.fasl"]
;["libintelasm-6.0.ss" "libintelasm.fasl"]
["libcafe-6.1.ss" "libcafe.fasl"]
; ["libtrace-5.3.ss" "libtrace-5.3.s" "libtrace" ]
["libposix-6.0.ss" "libposix.fasl"]
["libtoplevel-6.0.ss" "libtoplevel.fasl"]
))
(define primitive?
(lambda (x)
(or (assq x open-coded-primitives)
(memq x public-primitives))))
(define open-coded-primitives
;;; these primitives, when found in operator position with the correct
;;; number of arguments, will be open-coded by the generator. If an
;;; incorrect number of args is detected, or if they appear in non-operator
;;; position, then they cannot be open-coded, and the pcb-primitives table
;;; is consulted for a reference of the pcb slot containing the primitive.
;;; If it's not found there, an error is signalled.
;;;
;;; prim-name args
'([$constant-ref 1 value]
[$constant-set! 2 effect]
[$pcb-ref 1 value]
[$pcb-set! 2 effect]
;;; type predicates
[fixnum? 1 pred]
[immediate? 1 pred]
[boolean? 1 pred]
[char? 1 pred]
[pair? 1 pred]
[symbol? 1 pred]
[vector? 1 pred]
[string? 1 pred]
[procedure? 1 pred]
[null? 1 pred]
[eof-object? 1 pred]
[$unbound-object? 1 pred]
[$forward-ptr? 1 pred]
[not 1 pred]
[eq? 2 pred]
;;; fixnum primitives
[$fxadd1 1 value]
[$fxsub1 1 value]
[$fx+ 2 value]
[$fx- 2 value]
[$fx* 2 value]
[$fxsll 2 value]
[$fxsra 2 value]
[$fxlogand 2 value]
[$fxlogor 2 value]
[$fxlogxor 2 value]
[$fxlognot 1 value]
[$fxquotient 2 value]
[$fxmodulo 2 value]
;;; fixnum predicates
[$fxzero? 1 pred]
[$fx= 2 pred]
[$fx< 2 pred]
[$fx<= 2 pred]
[$fx> 2 pred]
[$fx>= 2 pred]
;;; character predicates
[$char= 2 pred]
[$char< 2 pred]
[$char<= 2 pred]
[$char> 2 pred]
[$char>= 2 pred]
;;; character conversion
[$fixnum->char 1 value]
[$char->fixnum 1 value]
;;; lists/pairs
[cons 2 value]
[$car 1 value]
[$cdr 1 value]
[$set-car! 2 effect]
[$set-cdr! 2 effect]
;;; vectors
[$make-vector 1 value]
[vector any value]
[$vector-length 1 value]
[$vector-ref 2 value]
[$vector-set! 3 effect]
;;; strings
[$make-string 1 value]
[$string any value]
[$string-length 1 value]
[$string-ref 2 value]
[$string-set! 3 effect]
;;; symbols
[$make-symbol 1 value]
[$symbol-value 1 value]
[$symbol-string 1 value]
[$symbol-unique-string 1 value]
[$set-symbol-value! 2 effect]
[$set-symbol-string! 2 effect]
[$set-symbol-unique-string! 2 effect]
[$symbol-plist 1 value]
[$set-symbol-plist! 2 effect]
[primitive-ref 1 value]
[primitive-set! 2 effect]
;;; misc
[eof-object 0 value]
[void 0 value]
[$exit 1 effect]
[$fp-at-base 0 pred]
[$current-frame 0 value]
[$seal-frame-and-call 1 tail]
[$frame->continuation 1 value]
;;;
;;; records
;;;
[$make-record 2 value]
[$record? 1 pred]
[$record-rtd 1 value]
[$record-ref 2 value]
[$record-set! 3 effect]
;;;
;;; hash tables
;;;
[make-hash-table 0 value]
[hash-table? 1 pred]
;;;
;;; asm
;;;
;[code? 1 pred]
;[$code-instr-size 1 value]
;[$code-reloc-size 1 value]
;[$code-closure-size 1 value]
;[$code->closure 1 value]
;[$set-code-byte! 3 effect]
;[$set-code-word! 3 effect]
;[$set-code-object! 4 effect]
;[$set-code-object+offset! 5 effect]
;[$set-code-object+offset/rel! 5 effect]
;;;
[$make-call-with-values-procedure 0 value]
[$make-values-procedure 0 value]
[$install-underflow-handler 0 effect]
))
(define (primitive-context x)
(cond
[(assq x open-coded-primitives) => caddr]
[else (error 'primitive-context "unknown prim ~s" x)]))
;;; primitives table section
(define primitives-table
'(;;; system locations used by the C/Scheme interface
[$apply-nonprocedure-error-handler library]
[$incorrect-args-error-handler library]
[$multiple-values-error library]
[$intern library]
[do-overflow library]
[do-vararg-overflow library]
[do-stack-overflow library]
;;; type predicates
[fixnum? public]
[immediate? public]
[boolean? public]
[char? public]
[null? public]
[pair? public]
[symbol? public]
[vector? public]
[string? public]
[procedure? public]
[eof-object? public]
[not public]
[eq? public]
[equal? public]
;;; fixnum primitives
[fxadd1 public]
[fxsub1 public]
[fx+ public]
[fx- public]
[fx* public]
[fxsll public]
[fxsra public]
[fxlogor public]
[fxlogand public]
[fxlogxor public]
[fxlognot public]
[fxquotient public]
[fxremainder public]
[fxmodulo public]
;;; fixnum predicates
[fxzero? public]
[fx= public]
[fx< public]
[fx<= public]
[fx> public]
[fx>= public]
;;; characters
[char=? public]
[char<? public]
[char<=? public]
[char>? public]
[char>=? public]
[integer->char public]
[char->integer public]
;;; lists
[cons public]
[car public]
[cdr public]
[caar public]
[cadr public]
[cdar public]
[cddr public]
[caaar public]
[caadr public]
[cadar public]
[caddr public]
[cdaar public]
[cdadr public]
[cddar public]
[cdddr public]
[caaaar public]
[caaadr public]
[caadar public]
[caaddr public]
[cadaar public]
[cadadr public]
[caddar public]
[cadddr public]
[cdaaar public]
[cdaadr public]
[cdadar public]
[cdaddr public]
[cddaar public]
[cddadr public]
[cdddar public]
[cddddr public]
[set-car! public]
[set-cdr! public]
[list public]
[list* ADDME]
[list? public]
[list-ref public]
[length public]
[make-list public]
[reverse public]
[append public]
[list-ref public]
[memq public]
[assq public]
[map public]
[for-each public]
[andmap public]
[ormap public]
;;; vectors
[make-vector public]
[vector public]
[vector-length public]
[vector-ref public]
[vector-set! public]
[list->vector public]
[vector->list public]
;;; strings
[make-string public]
[string public]
[string-length public]
[string-ref public]
[string-set! public]
[list->string public]
[string->list public]
[string-append public]
[substring public]
[string=? public]
[fixnum->string public]
;;; symbols
[gensym public]
[gensym? public]
[symbol->string public]
[gensym->unique-string public]
[gensym-prefix public]
[gensym-count public]
[print-gensym public]
[string->symbol public]
[top-level-value public]
[top-level-bound? public]
[set-top-level-value! public]
[getprop public]
[putprop public]
[remprop public]
[property-list public]
[oblist public]
[uuid public]
;;; eof
[eof-object public]
[void public]
;;; control/debugging
[print-error public]
[error public]
[current-error-handler public]
[exit public]
[apply public]
[make-parameter public]
;;; output
[output-port? public]
[console-output-port public]
[current-output-port public]
[standard-output-port public]
[standard-error-port public]
[open-output-file public]
[open-output-string public]
[with-output-to-file public]
[call-with-output-file public]
[with-input-from-file public]
[call-with-input-file public]
[get-output-string public]
[close-output-port public]
[flush-output-port public]
[write-char public]
[output-port-name public]
[newline public]
;;; input
[input-port? public]
[standard-input-port public]
[console-input-port public]
[current-input-port public]
[open-input-file public]
[close-input-port public]
[reset-input-port! public]
[read-char public]
[peek-char public]
[unread-char public]
[input-port-name public]
;;; writing/printing
[write public]
[display public]
[printf public]
[fprintf public]
[format public]
[read-token public]
[read public]
;;; evaluation
[primitive? public]
[expand public]
[core-expand public]
[current-expand public]
[interpret public]
[eval public]
[current-eval public]
[load public]
[new-cafe public]
[collect public]
[call/cc public]
[call/cf library]
[dynamic-wind public]
[values public]
[call-with-values public]
[make-traced-procedure library]
[trace-symbol! library]
[untrace-symbol! library]
;;; record
[$base-rtd library]
[record? public]
[record-rtd public]
[record-name public]
[record-printer public]
[record-length public]
[record-ref public]
[record-set! public]
;;; record rtds
[make-record-type public]
[record-constructor public]
[record-predicate public]
[record-field-accessor public]
[record-field-mutator public]
;;; asm
[make-code public]
[code? public]
[make-code-executable! public]
[code-instr-size public]
[code-reloc-size public]
[code-closure-size public]
[set-code-byte! public]
[set-code-word! public]
[set-code-object! public]
[set-code-foreign-object! public]
[set-code-object+offset! public]
[set-code-object+offset/rel! public]
[set-code-object/reloc/relative! public]
[code->closure public]
[list*->code* library]
;;;
;;; POSIX
;;;
[fork public]
[posix-fork public]
[system public]
[$debug public]
[$underflow-misaligned-error public]
))
(define (primitive? x)
(cond
[(assq x primitives-table) #t]
[(assq x open-coded-primitives) #t]
[else #f]))
(define (open-codeable? x)
(cond
[(assq x open-coded-primitives) #t]
[(assq x primitives-table) #f]
[else (error 'open-codeable "invalid primitive ~s" x)]))
(define (open-coded-primitive-args x)
(cond
[(assq x open-coded-primitives) => cadr]
[else (error 'open-coded-primitive-args "invalid ~s" x)]))
;;; end of primitives table section
(define-record constant (value))
(define-record code-loc (label))
(define-record foreign-label (label))
(define-record var (name))
(define-record cp-var (idx))
(define-record frame-var (idx))
(define-record new-frame (base-idx size body))
(define-record save-cp (loc))
(define-record eval-cp (check body))
(define-record return (value))
(define-record call-cp
(call-convention rp-convention base-idx arg-count live-mask))
(define-record primcall (op arg*))
(define-record primref (name))
(define-record conditional (test conseq altern))
(define-record bind (lhs* rhs* body))
(define-record seq (e0 e1))
(define-record function (arg* proper body))
(define-record clambda-case (arg* proper body))
(define-record clambda (cases))
(define-record clambda-code (label cases free))
(define-record closure (code free*))
(define-record funcall (op rand*))
(define-record appcall (op rand*))
(define-record forcall (op rand*))
(define-record code-rec (arg* proper free* body))
(define-record codes (list body))
(define-record assign (lhs rhs))
(define unique-var
(let ([counter 0])
(lambda (x)
(let ([g (gensym (format "~a:~a" x counter))])
(set! counter (fxadd1 counter))
(make-var g)))))
(define (make-bind^ lhs* rhs* body)
(if (null? lhs*)
body
(make-bind lhs* rhs* body)))
(define (recordize x)
(define (gen-fml* fml*)
(cond
[(pair? fml*)
(cons (unique-var (car fml*))
(gen-fml* (cdr fml*)))]
[(symbol? fml*)
(unique-var fml*)]
[else '()]))
(define (properize fml*)
(cond
[(pair? fml*)
(cons (car fml*) (properize (cdr fml*)))]
[(null? fml*) '()]
[else (list fml*)]))
(define (extend-env fml* nfml* env)
(cons (cons fml* nfml*) env))
(define (quoted-sym x)
(if (and (list? x)
(fx= (length x) 2)
(eq? 'quote (car x))
(symbol? (cadr x)))
(cadr x)
(error 'quoted-sym "not a quoted symbol ~s" x)))
(define (quoted-string x)
(if (and (list? x)
(fx= (length x) 2)
(eq? 'quote (car x))
(string? (cadr x)))
(cadr x)
(error 'quoted-string "not a quoted string ~s" x)))
(define (lookup^ x lhs* rhs*)
(cond
[(pair? lhs*)
(if (eq? x (car lhs*))
(car rhs*)
(lookup^ x (cdr lhs*) (cdr rhs*)))]
[(eq? x lhs*) rhs*]
[else #f]))
(define (lookup x env)
(cond
[(pair? env)
(or (lookup^ x (caar env) (cdar env))
(lookup x (cdr env)))]
[else #f]))
(define (E x env)
(cond
[(pair? x)
(case (car x)
[(quote) (make-constant (cadr x))]
[(if)
(make-conditional
(E (cadr x) env)
(E (caddr x) env)
(E (cadddr x) env))]
[(set!)
(let ([lhs (cadr x)] [rhs (caddr x)])
(make-assign
(or (lookup lhs env)
(error 'recordize "invalid assignment ~s" x))
(E rhs env)))]
[(begin)
(let f ([a (cadr x)] [d (cddr x)])
(cond
[(null? d) (E a env)]
[else
(make-seq
(E a env)
(f (car d) (cdr d)))]))]
[(case-lambda)
(let ([cls*
(map
(lambda (cls)
(let ([fml* (car cls)] [body (cadr cls)])
(let ([nfml* (gen-fml* fml*)])
(let ([body (E body (extend-env fml* nfml* env))])
(make-clambda-case
(properize nfml*)
(list? fml*)
body)))))
(cdr x))])
(make-clambda cls*))]
[(foreign-call)
(let ([name (quoted-string (cadr x))] [arg* (cddr x)])
(make-forcall name
(map (lambda (x) (E x env)) arg*)))]
[(|#primitive|)
(let ([var (cadr x)])
(if (primitive? var)
(make-primref var)
(error 'recordize "invalid primitive ~s" var)))]
[(top-level-value)
(let ([var (quoted-sym (cadr x))])
(if (primitive? var)
(make-primref var)
(error 'recordize "invalid top-level var ~s" var)))]
[(memv)
(make-funcall
(make-primref 'memq)
(map (lambda (x) (E x env)) (cdr x)))]
[($apply)
(let ([proc (cadr x)] [arg* (cddr x)])
(make-appcall
(E proc env)
(map (lambda (x) (E x env)) arg*)))]
[(void)
(make-constant (void))]
[else
(make-funcall
(E (car x) env)
(map (lambda (x) (E x env)) (cdr x)))])]
[(symbol? x)
(or (lookup x env)
(error 'recordize "invalid reference in ~s" x))]
[else (error 'recordize "invalid expression ~s" x)]))
(E x '()))
(define (unparse x)
(define (E-args proper x)
(if proper
(map E x)
(let f ([a (car x)] [d (cdr x)])
(cond
[(null? d) (E a)]
[else (cons (E a) (f (car d) (cdr d)))]))))
(define (E x)
(record-case x
[(constant c) `(quote ,c)]
[(code-loc x) `(code-loc ,x)]
[(var x) (string->symbol (format "v:~a" x))]
[(primref x) x]
[(conditional test conseq altern)
`(if ,(E test) ,(E conseq) ,(E altern))]
[(primcall op arg*) `(,op . ,(map E arg*))]
[(bind lhs* rhs* body)
`(let ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
,(E body))]
[(seq e0 e1) `(begin ,(E e0) ,(E e1))]
[(function args proper body)
`(lambda ,(E-args proper args) ,(E body))]
[(clambda-case args proper body)
`(clambda-case ,(E-args proper args) ,(E body))]
[(clambda cls*)
`(case-lambda . ,(map E cls*))]
[(clambda-code label clauses free)
`(code ,label . ,(map E clauses))]
[(closure code free*)
`(closure ,(E code) ,(map E free*))]
[(code-rec arg* proper free* body)
`(code-rec [arg: ,(E-args proper arg*)]
[free: ,(map E free*)]
,(E body))]
[(codes list body)
`(codes ,(map E list)
,(E body))]
[(funcall rator rand*) `(funcall ,(E rator) . ,(map E rand*))]
[(appcall rator rand*) `(appcall ,(E rator) . ,(map E rand*))]
[(forcall rator rand*) `(foreign-call ,rator . ,(map E rand*))]
[(assign lhs rhs) `(set! ,(E lhs) ,(E rhs))]
[(return x) `(return ,(E x))]
[(new-frame base-idx size body)
`(new-frame [base: ,base-idx]
[size: ,size]
,(E body))]
[(frame-var idx)
(string->symbol (format "fv.~a" idx))]
[(cp-var idx)
(string->symbol (format "cp.~a" idx))]
[(save-cp expr)
`(save-cp ,(E expr))]
[(eval-cp check body)
`(eval-cp ,check ,(E body))]
[(call-cp call-convention rp-convention base-idx arg-count live-mask)
`(call-cp [conv: ,call-convention]
[rpconv: ,rp-convention]
[base-idx: ,base-idx]
[arg-count: ,arg-count]
[live-mask: ,live-mask])]
[(foreign-label x) `(foreign-label ,x)]
[else (error 'unparse "invalid record ~s" x)]))
(E x))
(define (optimize-direct-calls x)
(define who 'optimize-direct-calls)
(define (make-conses ls)
(cond
[(null? ls) (make-constant '())]
[else
(make-primcall 'cons
(list (car ls) (make-conses (cdr ls))))]))
(define (properize lhs* rhs*)
(cond
[(null? lhs*) (error who "improper improper")]
[(null? (cdr lhs*))
(list (make-conses rhs*))]
[else (cons (car rhs*) (properize (cdr lhs*) (cdr rhs*)))]))
(define (inline-case cls rand*)
(record-case cls
[(clambda-case fml* proper body)
(if proper
(and (fx= (length fml*) (length rand*))
(make-bind fml* rand* body))
(and (fx<= (length fml*) (length rand*))
(make-bind fml* (properize fml* rand*) body)))]))
(define (try-inline cls* rand* default)
(cond
[(null? cls*) default]
[(inline-case (car cls*) rand*)]
[else (try-inline (cdr cls*) rand* default)]))
(define (inline rator rand*)
(record-case rator
[(clambda cls*)
(try-inline cls* rand*
(make-funcall rator rand*))]
; [(function fml* proper body)
; (cond
; [proper
; (if (fx= (length fml*) (length rand*))
; (make-bind fml* rand* body)
; (begin
; (warning 'compile "possible application error in ~s"
; (unparse (make-funcall rator rand*)))
; (make-funcall rator rand*)))]
; [else
; (if (fx<= (length fml*) (length rand*))
; (make-bind fml* (properize fml* rand*) body)
; (begin
; (warning 'compile "possible application error in ~s"
; (unparse (make-funcall rator rand*)))
; (make-funcall rator rand*)))])]
[else (make-funcall rator rand*)]))
(define (Expr x)
(record-case x
[(constant) x]
[(var) x]
[(primref) x]
[(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))]
[(function fml* proper body)
(make-function fml* proper (Expr body))]
[(clambda cls*)
(make-clambda
(map (lambda (x)
(record-case x
[(clambda-case fml* proper body)
(make-clambda-case fml* proper (Expr body))]))
cls*))]
[(primcall rator rand*)
(make-primcall rator (map Expr rand*))]
[(funcall rator rand*)
(inline (Expr rator) (map Expr rand*))]
[(appcall rator rand*)
(make-appcall (Expr rator) (map Expr rand*))]
[(forcall rator rand*)
(make-forcall rator (map Expr rand*))]
[(assign lhs rhs)
(make-assign lhs (Expr rhs))]
[else (error who "invalid expression ~s" (unparse x))]))
(Expr x))
(define (uncover-assigned x)
(define who 'uncover-assigned)
(define (Expr* x*)
(cond
[(null? x*) '()]
[else (union (Expr (car x*)) (Expr* (cdr x*)))]))
(define (Expr x)
(record-case x
[(constant) '()]
[(var) '()]
[(primref) '()]
[(bind lhs* rhs* body)
(union (Expr body) (Expr* rhs*))]
[(conditional test conseq altern)
(union (Expr test) (union (Expr conseq) (Expr altern)))]
[(seq e0 e1) (union (Expr e0) (Expr e1))]
[(clambda cls*)
(Expr* (map clambda-case-body cls*))]
[(function fml* proper body) (Expr body)]
[(primcall rator rand*) (Expr* rand*)]
[(funcall rator rand*)
(union (Expr rator) (Expr* rand*))]
[(appcall rator rand*)
(union (Expr rator) (Expr* rand*))]
[(forcall rator rand*) (Expr* rand*)]
[(assign lhs rhs)
(union (singleton lhs) (Expr rhs))]
[else (error who "invalid expression ~s" (unparse x))]))
(Expr x))
(define (rewrite-assignments assigned x)
(define who 'rewrite-assignments)
(define (fix lhs*)
(cond
[(null? lhs*) (values '() '() '())]
[else
(let ([x (car lhs*)])
(let-values ([(lhs* a-lhs* a-rhs*) (fix (cdr lhs*))])
(cond
[(memq x assigned)
(let ([t (make-var 'assignment-tmp)])
(values (cons t lhs*) (cons x a-lhs*) (cons t a-rhs*)))]
[else
(values (cons x lhs*) a-lhs* a-rhs*)])))]))
(define (bind-assigned lhs* rhs* body)
(cond
[(null? lhs*) body]
[else
(make-bind lhs*
(map (lambda (rhs) (make-primcall 'vector (list rhs))) rhs*)
body)]))
(define (Expr x)
(record-case x
[(constant) x]
[(var)
(cond
[(memq x assigned)
(make-primcall '$vector-ref (list x (make-constant 0)))]
[else x])]
[(primref) x]
[(bind lhs* rhs* body)
(let-values ([(lhs* a-lhs* a-rhs*) (fix lhs*)])
(make-bind lhs* (map Expr rhs*)
(bind-assigned a-lhs* a-rhs* (Expr body))))]
[(conditional test conseq altern)
(make-conditional (Expr test) (Expr conseq) (Expr altern))]
[(seq e0 e1) (make-seq (Expr e0) (Expr e1))]
[(function fml* proper body)
(let-values ([(fml* a-lhs* a-rhs*) (fix fml*)])
(make-function fml* proper
(bind-assigned a-lhs* a-rhs* (Expr body))))]
[(clambda cls*)
(make-clambda
(map (lambda (cls)
(record-case cls
[(clambda-case fml* proper body)
(let-values ([(fml* a-lhs* a-rhs*) (fix fml*)])
(make-clambda-case fml* proper
(bind-assigned a-lhs* a-rhs* (Expr body))))]))
cls*))]
[(primcall op rand*)
(make-primcall op (map Expr rand*))]
[(forcall op rand*)
(make-forcall op (map Expr rand*))]
[(funcall rator rand*)
(make-funcall (Expr rator) (map Expr rand*))]
[(appcall rator rand*)
(make-appcall (Expr rator) (map Expr rand*))]
[(assign lhs rhs)
(unless (memq lhs assigned)
(error 'rewrite-assignments "not assigned ~s in ~s" lhs x))
(make-primcall '$vector-set! (list lhs (make-constant 0) (Expr rhs)))]
[else (error who "invalid expression ~s" (unparse x))]))
(Expr x))
(define (remove-assignments x)
(let ([assigned (uncover-assigned x)])
(rewrite-assignments assigned x)))
(define (convert-closures prog)
(define who 'convert-closures)
(define (Expr* x*)
(cond
[(null? x*) (values '() '())]
[else
(let-values ([(a a-free) (Expr (car x*))]
[(d d-free) (Expr* (cdr x*))])
(values (cons a d) (union a-free d-free)))]))
(define (Expr ex)
(record-case ex
[(constant) (values ex '())]
[(var) (values ex (singleton ex))]
[(primref) (values ex '())]
[(bind lhs* rhs* body)
(let-values ([(rhs* rhs-free) (Expr* rhs*)]
[(body body-free) (Expr body)])
(values (make-bind lhs* rhs* body)
(union rhs-free (difference body-free lhs*))))]
[(conditional test conseq altern)
(let-values ([(test test-free) (Expr test)]
[(conseq conseq-free) (Expr conseq)]
[(altern altern-free) (Expr altern)])
(values (make-conditional test conseq altern)
(union test-free (union conseq-free altern-free))))]
[(seq e0 e1)
(let-values ([(e0 e0-free) (Expr e0)]
[(e1 e1-free) (Expr e1)])
(values (make-seq e0 e1) (union e0-free e1-free)))]
[(function fml* proper body)
(let-values ([(body body-free) (Expr body)])
(let ([free (difference body-free fml*)])
(values (make-closure (make-code-rec fml* proper free body) free)
free)))]
[(clambda cls*)
(let-values ([(cls* free)
(let f ([cls* cls*])
(cond
[(null? cls*) (values '() '())]
[else
(record-case (car cls*)
[(clambda-case fml* proper body)
(let-values ([(body body-free) (Expr body)]
[(cls* cls*-free) (f (cdr cls*))])
(values
(cons (make-clambda-case fml* proper body)
cls*)
(union (difference body-free fml*)
cls*-free)))])]))])
(values (make-closure (make-clambda-code (gensym) cls* free) free)
free))]
[(primcall op rand*)
(let-values ([(rand* rand*-free) (Expr* rand*)])
(values (make-primcall op rand*) rand*-free))]
[(forcall op rand*)
(let-values ([(rand* rand*-free) (Expr* rand*)])
(values (make-forcall op rand*) rand*-free))]
[(funcall rator rand*)
(let-values ([(rator rat-free) (Expr rator)]
[(rand* rand*-free) (Expr* rand*)])
(values (make-funcall rator rand*)
(union rat-free rand*-free)))]
[(appcall rator rand*)
(let-values ([(rator rat-free) (Expr rator)]
[(rand* rand*-free) (Expr* rand*)])
(values (make-appcall rator rand*)
(union rat-free rand*-free)))]
[else (error who "invalid expression ~s" (unparse ex))]))
(let-values ([(prog free) (Expr prog)])
(unless (null? free)
(error 'convert-closures "free vars ~s encountered in ~a"
free (unparse prog)))
prog))
(define (lift-codes x)
(define who 'lift-codes)
(define all-codes '())
(define (do-code x)
(record-case x
[(clambda-code label cls* free)
(let ([cls* (map
(lambda (x)
(record-case x
[(clambda-case fml* proper body)
(make-clambda-case fml* proper (E body))]))
cls*)])
(let ([g (make-code-loc label)])
(set! all-codes
(cons (make-clambda-code 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))]
[(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*))]
[(appcall rator rand*) (make-appcall (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 '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? immediate? boolean? char? vector? string? procedure?
null? pair? not cons eq? vector symbol? error eof-object eof-object?
void $unbound-object? code? hash-table? $forward-ptr?)
'#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 byte?) 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!
$string-ref-16+0 $string-ref-16+1 $string-ref-8+0 $string-ref-8+2)
(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
$symbol-value $set-symbol-value! $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
$code-instr-size $code-reloc-size $code-closure-size
$set-code-byte! $set-code-word!
$set-code-object! $set-code-object+offset! $set-code-object+offset/rel!
$make-record $record? $record-rtd $record-ref $record-set!
primitive-set! primitive-ref)
#t]
[else (error 'valid-arg-types? "unhandled op ~s" op)]))
(and (valid-arg-count? op rand*)
(or (null? rand*)
(valid-arg-types? op rand*))))
;;; 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 (introduce-primcalls x)
(define who 'introduce-primcalls)
(define (simple? x)
(or (constant? x) (var? x) (primref? x)))
(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))]
[(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
(make-funcall (Expr rator) (map Expr rand*))])]
[(appcall op arg*)
(make-appcall (Expr op) (map Expr arg*))]
[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))]
[(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*))])]
[(appcall op arg*)
(make-appcall (Expr op) (map Expr arg*))]
[else (error who "invalid expression ~s" (unparse x))]))
(define (CaseExpr x)
(record-case x
[(clambda-case fml* proper body)
(make-clambda-case fml* proper (Tail body))]))
(define (CodeExpr x)
(record-case x
[(clambda-code L cases free)
(make-clambda-code 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)))
(define (simplify arg lhs* rhs* k)
(if (simple? arg)
(k arg lhs* rhs*)
(let ([v (unique-var 'tmp)])
(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 (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))]
[(conditional test conseq altern)
(make-conditional (Expr test) (Expr conseq) (Expr altern))]
[(seq e0 e1) (make-seq (Expr e0) (Expr e1))]
[(primcall op arg*)
(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*))]
[(appcall op arg*)
(make-appcall (Expr op) (map Expr arg*))]
[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))]
[(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*))]
[(appcall op arg*)
(make-appcall (Expr op) (map Expr arg*))]
[else (error who "invalid expression ~s" (unparse x))]))
(define (CaseExpr x)
(record-case x
[(clambda-case fml* proper body)
(make-clambda-case fml* proper (Tail body))]))
(define (CodeExpr x)
(record-case x
[(clambda-code L clauses free)
(make-clambda-code 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-conditional
(make-primcall '$fp-overflow '())
(make-funcall (make-primref 'do-stack-overflow) '())
(make-primcall 'void '()))
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))]
[(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]
[(appcall rator arg*) #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))]
[(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*))]
[(appcall rator arg*) (or (Expr rator) (ormap Expr arg*))]
[else (error who "invalid tail expression ~s" (unparse x))]))
(define (CaseExpr x)
(record-case x
[(clambda-case fml* proper body)
(if (Tail body)
(make-clambda-case fml* proper (insert-check body))
x)]))
(define (CodeExpr x)
(record-case x
[(clambda-code L cases free)
(make-clambda-code 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-conditional
(make-primcall '$ap-check-bytes
(list (make-constant n) var))
(make-funcall (make-primref 'do-overflow)
(list
(make-primcall '$fx+
(list (make-constant n) var))))
(make-primcall 'void '()))
body))
(define (check-words n var body)
(make-seq
(make-conditional
(make-primcall '$ap-check-words
(list (make-constant n) var))
(make-funcall (make-primref 'do-overflow-words)
(list
(make-primcall '$fx+
(list (make-constant n) var))))
(make-primcall 'void '()))
body))
(define (check-const n body)
(make-seq
(make-conditional
(make-primcall '$ap-check-const
(list (make-constant n)))
(make-funcall (make-primref 'do-overflow)
(list (make-constant n)))
(make-primcall 'void '()))
body))
(define (Expr x)
(record-case x
[(constant) x]
[(var) x]
[(primref) x]
[(closure code free*)
(check-const (fx+ disp-closure-data (fx* (length free*) wordsize)) x)]
[(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-size x)]
[(make-hash-table) (check-const hash-table-size x)]
[($frame->continuation $code->closure)
(check-const (fx+ disp-closure-data (fx* (length arg*) wordsize)) x)]
[($make-string)
(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)])]
[($string)
(check-const (fx+ (length arg*) (fx+ disp-string-data 1)) x)]
[($make-vector)
(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)])]
[(vector)
(check-const (fx+ (fx* (length arg*) wordsize) disp-vector-data) x)]
[else x]))]
[(forcall op arg*)
(make-forcall op (map Expr arg*))]
[(funcall rator rand*)
(make-funcall (Expr rator) (map Expr rand*))]
[(appcall op arg*)
(make-appcall (Expr op) (map Expr arg*))]
[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))]
[(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*))]
[(appcall op arg*)
(make-appcall (Expr op) (map Expr arg*))]
[else (error who "invalid expression ~s" (unparse x))]))
(define (CaseExpr x)
(record-case x
[(clambda-case fml* proper body)
(make-clambda-case fml* proper (Tail body))]))
(define (CodeExpr x)
(record-case x
[(clambda-code L cases free)
(make-clambda-code L (map CaseExpr cases) free)]))
(define (CodesExpr x)
(record-case x
[(codes list body)
(make-codes (map CodeExpr list) (Tail body))]))
(CodesExpr x))
(define (remove-local-variables x)
(define who 'remove-local-variables)
(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->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 (do-new-frame op rand* si r call-convention rp-convention orig-live)
(make-new-frame (fxadd1 si) (fx+ (length rand*) 2)
(let f ([r* rand*] [nsi (fx+ si 2)] [live orig-live])
(cond
[(null? r*)
(make-seq
(make-seq
(make-save-cp (make-frame-var si))
(case call-convention
[(normal apply)
(make-eval-cp #t (Expr op nsi r (cons si live)))]
[(foreign)
(make-eval-cp #f (make-foreign-label op))]
[else (error who "invalid convention ~s" convention)]))
(make-call-cp call-convention
rp-convention
(fxadd1 si) ; frame size
(length rand*) ; argc
(env->mask (cons si orig-live) ; cp and everything before it
(fxadd1 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 (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)]
[(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*)
(case op
; [(values) (make-primcall op (simple* arg* r))]
[else (make-return (make-primcall op (simple* arg* r)))])]
[(funcall op rand*)
(do-new-frame op rand* si r 'normal 'tail live)]
[(appcall op rand*)
(do-new-frame op rand* si r 'apply 'tail live)]
[else (error who "invalid expression ~s" (unparse x))]))
(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)]
[(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 (simple* arg* r))]
[(forcall op rand*)
(do-new-frame op rand* si r 'foreign 'effect live)]
[(funcall op rand*)
(do-new-frame op rand* si r 'normal 'effect live)]
[(appcall op rand*)
(do-new-frame op rand* si r 'apply 'effect 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)]
[(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 (simple* arg* r))]
[(forcall op rand*)
(do-new-frame op rand* si r 'foreign 'value live)]
[(funcall op rand*)
(do-new-frame op rand* si r 'normal 'value live)]
[(appcall op rand*)
(do-new-frame op rand* si r 'apply 'value live)]
[else (error who "invalid expression ~s" (unparse x))]))
(define (bind-fml* fml* r)
(let f ([si 1] [fml* fml*])
(cond
[(null? fml*) (values '() si r '())]
[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)
(lambda (x)
(record-case x
[(clambda-case fml* proper body)
(let-values ([(fml* si r live) (bind-fml* fml* r)])
(make-clambda-case fml* proper (Tail body si r live)))]))))
(define (CodeExpr x)
(record-case x
[(clambda-code L cases free)
(let ([r (bind-free* free)])
(make-clambda-code L (map (CaseExpr r) cases) free))]))
(define (CodesExpr x)
(record-case x
[(codes list body)
(make-codes (map CodeExpr list)
(Tail body 1 '() '()))]))
(CodesExpr x))
(begin
(define fx-shift 2)
(define fx-mask #x03)
(define fx-tag 0)
(define bool-f #x2F)
(define bool-t #x3F)
(define bool-mask #xEF)
(define bool-tag bool-f)
(define bool-shift 4)
(define nil #x4F)
(define eof #x5F) ; double check
(define unbound #x6F) ; double check
(define void-object #x7F) ; double check
(define wordsize 4)
(define char-shift 8)
(define char-tag #x0F)
(define char-mask #xFF)
(define pair-mask 7)
(define pair-tag 1)
(define disp-car 0)
(define disp-cdr 4)
(define pair-size 8)
(define symbol-mask 7)
(define symbol-tag 2)
(define disp-symbol-string 0)
(define disp-symbol-unique-string 4)
(define disp-symbol-value 8)
(define disp-symbol-plist 12)
(define disp-symbol-system-value 16)
(define disp-symbol-system-plist 20)
(define symbol-size 24)
(define vector-tag 5)
(define vector-mask 7)
(define disp-vector-length 0)
(define disp-vector-data 4)
(define string-mask 7)
(define string-tag 6)
(define disp-string-length 0)
(define disp-string-data 4)
(define closure-mask 7)
(define closure-tag 3)
(define disp-closure-data 4)
(define disp-closure-code 0)
(define continuation-size 16)
(define continuation-tag #x1F)
(define disp-continuation-top 4)
(define disp-continuation-size 8)
(define disp-continuation-next 12)
(define code-tag #x2F)
(define disp-code-instrsize 4)
(define disp-code-relocsize 8)
(define disp-code-closuresize 12)
(define disp-code-data 16)
(define record-ptag vector-tag)
(define record-pmask vector-mask)
(define disp-record-rtd 0)
(define disp-record-data 4)
(define hash-table-tag #x3F)
(define disp-htable-count 4)
(define disp-htable-size 8)
(define disp-htable-mem 12)
(define hash-table-size 16)
(define disp-frame-size -17)
(define disp-frame-offset -13)
(define disp-multivalue-rp -9)
(define object-alignment 8)
(define align-shift 3)
(define pagesize 4096))
(begin
(define (mem off val)
(cond
[(fixnum? off) (list 'disp (int off) val)]
[(register? off) (list 'disp off val)]
[else (error 'mem "invalid disp ~s" off)]))
(define (int x) (list 'int x))
(define (obj x) (list 'obj x))
(define (byte x) (list 'byte x))
(define (byte-vector x) (list 'byte-vector x))
(define (movzbl src targ) (list 'movzbl src targ))
(define (sall src targ) (list 'sall src targ))
(define (sarl src targ) (list 'sarl src targ))
(define (shrl src targ) (list 'shrl src targ))
(define (notl src) (list 'notl src))
(define (pushl src) (list 'pushl src))
(define (popl src) (list 'popl src))
(define (orl src targ) (list 'orl src targ))
(define (xorl src targ) (list 'xorl src targ))
(define (andl src targ) (list 'andl src targ))
(define (movl src targ) (list 'movl src targ))
(define (movb src targ) (list 'movb src targ))
(define (addl src targ) (list 'addl src targ))
(define (imull src targ) (list 'imull src targ))
(define (idivl src) (list 'idivl src))
(define (subl src targ) (list 'subl src targ))
(define (push src) (list 'push src))
(define (pop targ) (list 'pop targ))
(define (sete targ) (list 'sete targ))
(define (call targ) (list 'call targ))
(define (tail-indirect-cpr-call)
(jmp (mem (fx- disp-closure-code closure-tag) cpr)))
(define (indirect-cpr-call)
(call (mem (fx- disp-closure-code closure-tag) cpr)))
(define (negl targ) (list 'negl targ))
(define (label x) (list 'label x))
(define (label-address x) (list 'label-address x))
(define (ret) '(ret))
(define (cltd) '(cltd))
(define (cmpl arg1 arg2) (list 'cmpl arg1 arg2))
(define (je label) (list 'je label))
(define (jne label) (list 'jne label))
(define (jle label) (list 'jle label))
(define (jge label) (list 'jge label))
(define (jg label) (list 'jg label))
(define (jl label) (list 'jl label))
(define (jb label) (list 'jb label))
(define (ja label) (list 'ja label))
(define (jmp label) (list 'jmp label))
(define edi '%edx) ; closure pointer
(define esi '%esi) ; pcb
(define ebp '%ebp) ; allocation pointer
(define esp '%esp) ; stack base pointer
(define al '%al)
(define ah '%ah)
(define bh '%bh)
(define cl '%cl)
(define eax '%eax)
(define ebx '%ebx)
(define ecx '%ecx)
(define edx '%edx)
(define apr '%ebp)
(define fpr '%esp)
(define cpr '%edi)
(define pcr '%esi)
(define register? symbol?)
(define (argc-convention n)
(fx- 0 (fxsll n fx-shift))))
(define pcb-ref
(lambda (x)
(case x
[(allocation-pointer) (mem 0 pcr)]
[(allocation-redline) (mem 4 pcr)]
[(frame-pointer) (mem 8 pcr)]
[(frame-base) (mem 12 pcr)]
[(frame-redline) (mem 16 pcr)]
[(next-continuation) (mem 20 pcr)]
[(system-stack) (mem 24 pcr)]
[else (error 'pcb-ref "invalid arg ~s" x)])))
(define (primref-loc op)
(unless (symbol? op) (error 'primref-loc "not a symbol ~s" op))
(mem (fx- disp-symbol-system-value symbol-tag)
(obj op)))
(define (generate-code x)
(define who 'generate-code)
(define (rp-label x)
(case x
[(value) (label-address SL_multiple_values_error_rp)]
[(effect) (label-address SL_multiple_values_ignore_rp)]
[else (error who "invalid rp-convention ~s" x)]))
(define (align n)
(fxsll (fxsra (fx+ n (fxsub1 object-alignment)) align-shift) align-shift))
(define unique-label
(lambda ()
(label (gensym))))
(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)
(cadr (assq x '([je jne] [jl jge] [jle jg] [jg jle] [jge jl]))))
(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)
(cond
[(and Lt Lf)
(list* (movl (Simple (car rand*)) eax)
(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 (Simple (car rand*)) eax)
(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 (Simple (car rand*)) eax)
(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)
(cond
[mask
(list*
(movl (Simple (car rand*)) eax)
(andl (int mask) eax)
(cmpl (int tag) eax)
(cond-branch 'je Lt Lf ac))]
[else
(let ([v (Simple (car rand*))])
(cond
[(memq (car v) '(mem register))
(list*
(cmpl (int tag) (Simple (car rand*)))
(cond-branch 'je Lt Lf ac))]
[else
(list*
(movl (Simple (car rand*)) eax)
(cmpl (int tag) eax)
(cond-branch 'je Lt Lf 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)]
[(symbol?) (type-pred symbol-mask symbol-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) (type-pred #f bool-f rand* Lt Lf ac)]
[(eof-object?) (type-pred #f eof 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)]
[(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)]
[(code?)
(indirect-type-pred vector-mask vector-tag #f code-tag
rand* Lt Lf ac)]
[(hash-table?)
(indirect-type-pred vector-mask vector-tag #f hash-table-tag
rand* Lt Lf ac)]
[(immediate?)
(cond
[(and Lt Lf)
(list* (movl (Simple (car rand*)) eax)
(movl eax ebx)
(andl (int fx-mask) ebx)
(cmpl (int 0) 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)
(cmpl (int 0) 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)
(cmpl (int 0) 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))]
[($fp-overflow)
(list* (cmpl (pcb-ref 'frame-redline) fpr)
(cond-branch 'jle Lt Lf ac))]
[($vector-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-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)]
[($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)]
[($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)
(idivl ebx)
(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)]
[($string-length)
(indirect-ref arg* (fx- disp-string-length string-tag) ac)]
[($symbol-string)
(indirect-ref arg* (fx- disp-symbol-string symbol-tag) ac)]
[($symbol-unique-string)
(indirect-ref arg* (fx- disp-symbol-unique-string symbol-tag) ac)]
[($symbol-value)
(indirect-ref arg* (fx- disp-symbol-value symbol-tag) ac)]
[(primitive-ref)
(indirect-ref arg* (fx- disp-symbol-system-value symbol-tag) ac)]
[($symbol-plist)
(indirect-ref arg* (fx- disp-symbol-plist symbol-tag) ac)]
[($record-rtd)
(indirect-ref arg* (fx- disp-record-rtd record-ptag) ac)]
[($constant-ref)
(list* (movl (Simple (car arg*)) eax) 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)]
[($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)]
[($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-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 apr eax)
(movl ebx (mem disp-cdr apr))
(addl (int pair-tag) eax)
(addl (int (align pair-size)) apr)
ac)]
[($make-symbol)
(list* (movl (Simple (car arg*)) eax)
(movl eax (mem disp-symbol-string apr))
(movl (int 0) (mem disp-symbol-unique-string apr))
(movl (int unbound) (mem disp-symbol-value apr))
(movl (int nil) (mem disp-symbol-plist apr))
(movl (int unbound) (mem disp-symbol-system-value apr))
(movl (int nil) (mem disp-symbol-system-plist apr))
(movl apr eax)
(addl (int symbol-tag) eax)
(addl (int (align symbol-size)) apr)
ac)]
[(make-hash-table)
(list* (movl (int hash-table-tag) (mem 0 apr))
(movl (int 0) (mem disp-htable-count apr))
(movl (int 0) (mem disp-htable-size apr))
(movl (int 0) (mem disp-htable-mem apr))
(movl apr eax)
(addl (int vector-tag) eax)
(addl (int hash-table-size) 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)))]))]
;[($pcb-ref)
; (let ([loc (car arg*)])
; (record-case loc
; [(constant i)
; (unless (fixnum? i) (error who "invalid loc ~s" loc))
; (list* (movl (mem (fx* i wordsize) pcr) eax) ac)]
; [else (error who "invalid loc ~s" loc)]))]
[($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)]
[($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
(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-instr-size)
(indirect-ref arg* (fx- disp-code-instrsize vector-tag)
(cons (sall (int fx-shift) eax) ac))]
[($code-reloc-size)
(indirect-ref arg* (fx- disp-code-relocsize vector-tag) ac)]
[($code-closure-size)
(indirect-ref arg* (fx- disp-code-closuresize vector-tag) ac)]
[($set-car! $set-cdr! $vector-set! $string-set! $exit
$set-symbol-value! $set-symbol-plist!
$set-code-byte! $set-code-word! primitive-set!
$set-code-object! $set-code-object+offset! $set-code-object+offset/rel!
$record-set!)
(do-effect-prim op arg*
(cons (movl (int void-object) eax) ac))]
[(fixnum? immediate? $fxzero? boolean? char? pair? vector? string? symbol?
procedure? null? not eof-object? $fx= $fx< $fx<= $fx> $fx>= eq?
$char= $char< $char<= $char> $char>= $unbound-object? code? hash-table?
$record?)
(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) arg*)
ac)]
[($make-call-with-values-procedure)
(NonTail
(make-closure (make-code-loc SL_call_with_values) arg*)
ac)]
[($make-values-procedure)
(NonTail
(make-closure (make-code-loc SL_values) arg*)
ac)]
[else
(error 'value-prim "unhandled ~s" op)]))
(define (do-effect-prim op arg* ac)
(case op
[($vector-set!)
(list* (movl (Simple (car arg*)) ebx)
(addl (Simple (cadr arg*)) ebx)
(movl (Simple (caddr arg*)) eax)
(movl eax (mem (fx- disp-vector-data vector-tag) ebx))
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)]
; [($set-constant!)
; (NonTail (cadr arg*)
; (list* (movl eax (Simple (car arg*))) ac))]
[($set-car!)
(list* (movl (Simple (car arg*)) eax)
(movl (Simple (cadr arg*)) ebx)
(movl ebx (mem (fx- disp-car pair-tag) eax))
ac)]
[($set-cdr!)
(list* (movl (Simple (car arg*)) eax)
(movl (Simple (cadr arg*)) ebx)
(movl ebx (mem (fx- disp-cdr pair-tag) eax))
ac)]
[($set-symbol-value!)
(list* (movl (Simple (car arg*)) eax)
(movl (Simple (cadr arg*)) ebx)
(movl ebx (mem (fx- disp-symbol-value symbol-tag) eax))
ac)]
[(primitive-set!)
(list* (movl (Simple (car arg*)) eax)
(movl (Simple (cadr arg*)) ebx)
(movl ebx (mem (fx- disp-symbol-system-value symbol-tag) eax))
ac)]
[($set-symbol-plist!)
(list* (movl (Simple (car arg*)) eax)
(movl (Simple (cadr arg*)) ebx)
(movl ebx (mem (fx- disp-symbol-plist symbol-tag) eax))
ac)]
[($set-symbol-unique-string!)
(list* (movl (Simple (car arg*)) eax)
(movl (Simple (cadr arg*)) ebx)
(movl ebx (mem (fx- disp-symbol-unique-string symbol-tag) eax))
ac)]
[($set-symbol-string!)
(list* (movl (Simple (car arg*)) eax)
(movl (Simple (cadr arg*)) ebx)
(movl ebx (mem (fx- disp-symbol-string symbol-tag) eax))
ac)]
[($record-set!)
(list* (movl (Simple (car arg*)) ebx)
(addl (Simple (cadr arg*)) ebx)
(movl (Simple (caddr arg*)) eax)
(movl eax (mem (fx- disp-record-data record-ptag) ebx))
ac)]
[($set-code-byte!)
(list* (movl (Simple (cadr arg*)) eax)
(sarl (int fx-shift) eax)
(addl (Simple (car arg*)) eax)
(movl (Simple (caddr arg*)) ebx)
(sarl (int fx-shift) ebx)
(movb bl (mem (fx- disp-code-data vector-tag) eax))
ac)]
[($set-code-word!)
(list* (movl (Simple (cadr arg*)) eax)
(sarl (int fx-shift) eax)
(addl (Simple (car arg*)) eax)
(movl (Simple (caddr arg*)) ebx)
(movl ebx (mem (fx- disp-code-data vector-tag) eax))
ac)]
[($set-code-object!)
(let ([code (car arg*)] [object (cadr arg*)]
[code-offset (caddr arg*)] [reloc-idx (cadddr arg*)])
(list*
(movl (Simple code) eax)
(movl (Simple object) ebx)
(movl (Simple code-offset) edx)
(movl edx ecx)
(sarl (int fx-shift) edx)
(addl eax edx)
(movl ebx (mem (fx- disp-code-data vector-tag) edx))
(addl (mem (fx- disp-code-instrsize vector-tag) eax) eax)
(addl (Simple reloc-idx) eax)
(movl ecx (mem (fx- disp-code-data vector-tag) eax))
ac))]
[($set-code-object+offset!)
(let ([code (car arg*)] [object (cadr arg*)]
[code-offset (caddr arg*)] [object-offset (cadddr arg*)]
[reloc-idx (car (cddddr arg*))])
(list*
(movl (Simple code) eax)
(movl (Simple object-offset) ebx) ; ebx = fxdisp
(sarl (int fx-shift) ebx) ; ebx = disp in bytes
(movl ebx ecx) ; ecx = disp in bytes
(addl (Simple object) ecx) ; ecx = object + disp
(movl (Simple code-offset) edx) ; edx = fx codeoffset
(sarl (int fx-shift) edx) ; edx = codeoffset in bytes
(addl eax edx)
(movl ecx (mem (fx- disp-code-data vector-tag) edx))
(subl eax edx)
(addl (mem (fx- disp-code-instrsize vector-tag) eax) eax)
(addl (Simple reloc-idx) eax)
(sall (int fx-shift) edx)
(orl (int 1) edx)
(movl edx (mem (fx- disp-code-data vector-tag) eax))
(movl ebx (mem (fx- (fx+ disp-code-data wordsize) vector-tag) eax))
ac))]
[($set-code-object+offset/rel!)
(let ([code (car arg*)] [object (cadr arg*)]
[code-offset (caddr arg*)] [object-offset (cadddr arg*)]
[reloc-idx (car (cddddr arg*))])
(list*
(movl (Simple code) eax)
(movl (Simple object-offset) ebx)
(sarl (int fx-shift) ebx)
(movl (Simple code-offset) ecx)
(orl (int 2) ecx)
(movl (mem (fx- disp-code-instrsize vector-tag) eax) edx)
(addl (Simple reloc-idx) edx)
(addl eax edx)
(movl ecx (mem (fx- disp-code-data vector-tag) edx))
(movl ebx (mem (fx- (fx+ wordsize disp-code-data) vector-tag) edx))
(sarl (int fx-shift) ecx) ; code offset in bytes
(addl eax ecx)
(addl (int (fx- (fx+ wordsize disp-code-data) vector-tag)) ecx)
; ecx points to next word in stream
(addl (Simple object) ebx) ; ebx is object+objectoffset
(subl ecx ebx) ; ebx is relative offset
(movl ebx (mem (fx- 0 wordsize) ecx))
ac))]
[(cons void $fxadd1 $fxsub1)
(let f ([arg* arg*])
(cond
[(null? arg*) ac]
[else
(Effect (car arg*) (f (cdr arg*)))]))]
[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 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)]
[else (error 'Simple "what ~s" x)]))
(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*)
(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))]
[(primcall op rand*)
(do-value-prim op rand* ac)]
[(new-frame base-idx size body)
(NonTail body ac)]
[(call-cp call-convention rp-convention offset size mask)
(let ([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)
`(byte 0) ; padding for indirect calls only
`(byte 0) ; direct calls are ok
L_CALL
(indirect-cpr-call)
(movl (mem 0 fpr) cpr)
(subl (int (frame-adjustment offset)) fpr)
ac)]
[(apply) are-we-ever-here?
(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_CALL
(call (label SL_apply))
(movl (mem 0 fpr) cpr)
(subl (int (frame-adjustment offset)) fpr)
ac)]
[(foreign)
(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) ; should be 0, since C has 1 rv
L_CALL
(call (label SL_foreign_call))
(movl (mem 0 fpr) cpr)
(subl (int (frame-adjustment offset)) fpr)
ac)]
[else (error who "invalid convention ~s for call-cp" convention)]))]
[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))]
[(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 ([Lf (unique-label)] [Ljoin (unique-label)])
(Pred test #f Lf
(Effect conseq
(list* (jmp Ljoin) Lf (Effect altern (cons Ljoin ac))))))]
[(seq e0 e1)
(Effect e0 (Effect e1 ac))]
[(assign loc val)
(record-case loc
[(frame-var i)
(NonTail val
(cons (movl eax (idx->frame-loc i)) ac))]
[else (error who "invalid assign loc ~s" loc)])]
[(eval-cp check body)
(NonTail body
(cond
[check
(list*
(movl eax cpr)
(andl (int closure-mask) eax)
(cmpl (int closure-tag) eax)
(jne (label SL_nonprocedure))
ac)]
[else
(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))]
[(new-frame idx size body)
(Tail body ac)]
[(call-cp call-convention rp-convention idx argc mask)
(unless (eq? rp-convention 'tail)
(error who "nontail rp (~s) in tail context" rp-convention))
(let f ([i 0])
(cond
[(fx= i 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))
ac)]
[else (error who "invalid conv ~s in tail call-cpr" convention)])]
[else
(list* (movl (mem (fx* (fx+ idx (fxadd1 i))
(fx- 0 wordsize)) fpr)
eax)
(movl eax (mem (fx* (fx+ i 1) (fx- 0 wordsize)) fpr))
(f (fxadd1 i)))]))]
[else (error 'Tail "invalid expression ~s" x)]))
(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))
(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 fml* proper body)
(let ([ac (Tail body ac)])
(cond
[(and proper check?)
(list* (cmpl (int (argc-convention (length fml*))) eax)
(jne (label SL_invalid_args))
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 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*)
(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 '()))]
[else
(cons (label L)
(Entry #f x
(f (car x*) (cdr x*) (car L*) (cdr L*))))])))))
(define (CodeExpr x)
(record-case x
[(clambda-code L cases free)
(list*
(fx+ disp-closure-data (fx* wordsize (length free)))
(label L)
(handle-cases (car cases) (cdr cases)))]))
(record-case x
[(codes list body)
(cons (cons 0 (Tail body '()))
(map CodeExpr list))]))
(define SL_nonprocedure (gensym "SL_nonprocedure"))
(define SL_invalid_args (gensym "SL_invalid_args"))
(define SL_foreign_call (gensym "SL_foreign_call"))
(define SL_continuation_code (gensym "SL_continuation_code"))
(define SL_multiple_values_error_rp (gensym "SL_multiple_values_error_rp"))
(define SL_multiple_values_ignore_rp (gensym "SL_multiple_ignore_error_rp"))
(define SL_underflow_multiple_values (gensym "SL_underflow_multiple_values"))
(define SL_underflow_handler (gensym "SL_underflow_handler"))
(define SL_scheme_exit (gensym "SL_scheme_exit"))
(define SL_apply (gensym "SL_apply"))
(define SL_values (gensym "SL_values"))
(define SL_call_with_values (gensym "SL_call_with_values"))
(list*->code*
(list
(let ([L_cwv_done (gensym)]
[L_cwv_loop (gensym)]
[L_cwv_multi_rp (gensym)]
[L_cwv_call (gensym)]
)
(list disp-closure-data
(label SL_call_with_values)
(cmpl (int (argc-convention 2)) eax)
(jne (label SL_invalid_args))
(movl (mem (fx- 0 wordsize) fpr) ebx) ; producer
(movl ebx cpr)
(andl (int closure-mask) ebx)
(cmpl (int closure-tag) ebx)
(jne (label SL_nonprocedure))
(movl (int (argc-convention 0)) eax)
(subl (int (fx* wordsize 2)) fpr)
(jmp (label L_cwv_call))
; MV NEW FRAME
(byte-vector '#(#b110))
(int (fx* wordsize 3))
'(current-frame-offset)
(label-address L_cwv_multi_rp)
(byte 0)
(byte 0)
(label L_cwv_call)
(indirect-cpr-call)
;;; one value returned
(addl (int (fx* wordsize 2)) fpr)
(movl (mem (fx* -2 wordsize) fpr) ebx) ; consumer
(movl ebx cpr)
(movl eax (mem (fx- 0 wordsize) fpr))
(movl (int (argc-convention 1)) eax)
(andl (int closure-mask) ebx)
(cmpl (int closure-tag) ebx)
(jne (label SL_nonprocedure))
(tail-indirect-cpr-call)
;;; multiple values returned
(label L_cwv_multi_rp)
; because values does not pop the return point
; we have to adjust fp one more word here
(addl (int (fx* wordsize 3)) fpr)
(movl (mem (fx* -2 wordsize) fpr) cpr) ; consumer
(cmpl (int (argc-convention 0)) eax)
(je (label L_cwv_done))
(movl (int (fx* -4 wordsize)) ebx)
(addl fpr ebx) ; ebx points to first value
(movl ebx ecx)
(addl eax ecx) ; ecx points to the last value
(label L_cwv_loop)
(movl (mem 0 ebx) edx)
(movl edx (mem (fx* 3 wordsize) ebx))
(subl (int wordsize) ebx)
(cmpl ecx ebx)
(jge (label L_cwv_loop))
(label L_cwv_done)
(movl cpr ebx)
(andl (int closure-mask) ebx)
(cmpl (int closure-tag) ebx)
(jne (label SL_nonprocedure))
(tail-indirect-cpr-call)))
(let ([L_values_one_value (gensym)]
[L_values_many_values (gensym)])
(list disp-closure-data
(label SL_values)
(cmpl (int (argc-convention 1)) eax)
(je (label L_values_one_value))
(label L_values_many_values)
(movl (mem 0 fpr) ebx) ; return point
(jmp (mem disp-multivalue-rp ebx)) ; go
(label L_values_one_value)
(movl (mem (fx- 0 wordsize) fpr) eax)
(ret)))
(let ([L_apply_done (gensym)]
[L_apply_loop (gensym)])
(list 0
(label SL_apply)
(movl (mem fpr eax) ebx)
(cmpl (int nil) ebx)
(je (label L_apply_done))
(label L_apply_loop)
(movl (mem (fx- disp-car pair-tag) ebx) ecx)
(movl (mem (fx- disp-cdr pair-tag) ebx) ebx)
(movl ecx (mem fpr eax))
(subl (int wordsize) eax)
(cmpl (int nil) ebx)
(jne (label L_apply_loop))
(label L_apply_done)
(addl (int wordsize) eax)
(tail-indirect-cpr-call)))
(list 0
(label SL_nonprocedure)
(movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg
(movl (primref-loc '$apply-nonprocedure-error-handler) cpr)
(movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call))
(list 0
(label SL_multiple_values_error_rp)
(movl (primref-loc '$multiple-values-error) cpr)
(tail-indirect-cpr-call))
(list 0
(label SL_multiple_values_ignore_rp)
(ret))
(list 0
(label SL_invalid_args)
;;;
(movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg
(negl eax)
(movl eax (mem (fx- 0 (fx* 2 wordsize)) fpr))
(movl (primref-loc '$incorrect-args-error-handler) cpr)
(movl (int (argc-convention 2)) eax)
(tail-indirect-cpr-call))
(let ([Lset (gensym)] [Lloop (gensym)])
(list 0
(label SL_foreign_call)
(movl fpr (pcb-ref 'frame-pointer))
(movl apr (pcb-ref 'allocation-pointer))
(movl fpr ebx)
(movl (pcb-ref 'system-stack) esp)
(pushl pcr)
(cmpl (int 0) eax)
(je (label Lset))
(label Lloop)
(movl (mem ebx eax) ecx)
(pushl ecx)
(addl (int 4) eax)
(cmpl (int 0) eax)
(jne (label Lloop))
(label Lset)
; FOREIGN NEW FRAME
(call cpr)
(movl (pcb-ref 'frame-pointer) fpr)
(movl (pcb-ref 'allocation-pointer) apr)
(ret)))
(let ([L_cont_zero_args (gensym)]
[L_cont_mult_args (gensym)]
[L_cont_one_arg (gensym)]
[L_cont_mult_move_args (gensym)]
[L_cont_mult_copy_loop (gensym)])
(list
(fx+ disp-closure-data wordsize)
(label SL_continuation_code)
(movl (mem (fx- disp-closure-data closure-tag) cpr) ebx) ; captured-k
(movl ebx (pcb-ref 'next-continuation)) ; set
(movl (pcb-ref 'frame-base) ebx)
(cmpl (int (argc-convention 1)) eax)
(jg (label L_cont_zero_args))
(jl (label L_cont_mult_args))
(label L_cont_one_arg)
(movl (mem (fx- 0 wordsize) fpr) eax)
(movl ebx fpr)
(subl (int wordsize) fpr)
(ret)
(label L_cont_zero_args)
(subl (int wordsize) ebx)
(movl ebx fpr)
(movl (mem 0 ebx) ebx) ; return point
(jmp (mem disp-multivalue-rp ebx)) ; go
(label L_cont_mult_args)
(subl (int wordsize) ebx)
(cmpl ebx fpr)
(jne (label L_cont_mult_move_args))
(movl (mem 0 ebx) ebx)
(jmp (mem disp-multivalue-rp ebx))
(label L_cont_mult_move_args)
; move args from fpr to ebx
(movl (int 0) ecx)
(label L_cont_mult_copy_loop)
(subl (int wordsize) ecx)
(movl (mem fpr ecx) edx)
(movl edx (mem ebx ecx))
(cmpl ecx eax)
(jne (label L_cont_mult_copy_loop))
(movl ebx fpr)
(movl (mem 0 ebx) ebx)
(jmp (mem disp-multivalue-rp ebx))
))
))
(define (compile-program original-program)
(let* (;;;
[p (expand original-program)]
[p (recordize p)]
;[f (pretty-print (unparse p))]
[p (optimize-direct-calls p)]
[p (remove-assignments p)]
[p (convert-closures p)]
[p (lift-codes p)]
;[p (lift-complex-constants p)]
[p (introduce-primcalls p)]
[p (simplify-operands p)]
;[f (pretty-print (unparse p))]
[p (insert-stack-overflow-checks p)]
[p (insert-allocation-checks p)]
[p (remove-local-variables p)]
;[f (pretty-print (unparse p))]
[ls* (generate-code p)]
[f (when (assembler-output)
(for-each
(lambda (ls)
(for-each (lambda (x) (printf " ~s\n" x)) ls))
ls*))]
[code* (list*->code* ls*)])
(fasl-write (car code*) (compile-port))))
(define compile-expr
(lambda (expr output-file)
(let ([op (open-output-file output-file 'replace)])
(parameterize ([compile-port op])
(compile-program expr))
(close-output-port op))))
(define compile-file
(lambda (input-file output-file)
(let ([ip (open-input-file input-file)]
[op (open-output-file output-file 'replace)])
(parameterize ([compile-port op])
(let f ()
(let ([x (read ip)])
(unless (eof-object? x)
(compile-program x)
(f)))))
(close-input-port ip)
(close-output-port op))))
(parameterize ([assembler-output #f])
(for-each
(lambda (x)
(printf "compiling ~a ...\n" x)
(compile-file (car x) (cadr x)))
scheme-library-files))
(system "rm -f ikarus.fasl")
(for-each
(lambda (x)
(system (format "cat ~a >> ikarus.fasl" (cadr x))))
scheme-library-files)
(define replace-safe-prims-with-unsafe
(lambda (x)
(define prims
'([fx+ $fx+] [fx- $fx-] [fx* $fx*] [fxadd1 $fxadd1] [fxsub1 $fxsub1]
[fxlogand $fxlogand] [fxlogor $fxlogor] [fxlognot $fxlognot]
[fx= $fx=] [fx< $fx<] [fx<= $fx<=] [fx> $fx>] [fx>= $fx>=]
[fxzero? $fxzero?]
[fixnum->char $fixnum->char] [char->fixnum $char->fixnum]
[char= $char=]
[char< $char<] [char> $char>] [char<= $char<=] [char>= $char>=]
[car $car] [cdr $cdr] [set-car! $set-car!] [set-cdr! $set-cdr!]
[vector-length $vector-length] [vector-ref $vector-ref]
[vector-set! $vector-set!] [make-vector $make-vector]
[string-length $string-length] [string-ref $string-ref]
[string-set! $string-set!] [make-string $make-string]
))
(define (E x)
(cond
[(pair? x) (cons (E (car x)) (E (cdr x)))]
[(symbol? x)
(cond
[(assq x prims) => cadr]
[else x])]
[else x]))
(E x)))
(parameterize ([input-filter
(lambda (x)
`(begin (write (eval ',x)) (newline) (exit 0)))])
(test-all))
(define (get-date)
(system "date +\"%F\" > build-date.tmp")
(let ([ip (open-input-file "build-date.tmp")])
(list->string
(let f ()
(let ([x (read-char ip)])
(if (char= x #\newline)
'()
(cons x (f))))))))
(compile-expr
`(begin
(display ,(format "Petite Ikarus Scheme (Build ~a)\n" (get-date)))
(display "Copyright (c) 2006 Abdulaziz Ghuloum\n\n")
(new-cafe))
"petite-ikarus.fasl")
Reference in New Issue View Git Blame Copy Permalink