3891 lines
136 KiB
Scheme
3891 lines
136 KiB
Scheme
|
|
(when (eq? "" "")
|
|
(load "chez-compat.ss")
|
|
(set! primitive-ref top-level-value)
|
|
(load "libexpand-6.0.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))
|
|
|
|
(define signal-error-on-undefined-pcb (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
|
|
'(
|
|
; ["libsymboltable-6.0.ss" "libsymboltable.fasl"]
|
|
["libhandlers-6.0.ss" "libhandlers.fasl"]
|
|
["libcontrol-6.0.ss" "libcontrol.fasl"]
|
|
["libcollect-6.0.ss" "libcollect.fasl"]
|
|
["librecord-6.0.ss" "librecord.fasl"]
|
|
["libcxr-6.0.ss" "libcxr.fasl"]
|
|
["libcore-6.0.ss" "libcore.fasl"]
|
|
["libio-6.0.ss" "libio.fasl"]
|
|
["libwriter-6.0.ss" "libwriter.fasl"]
|
|
["libtokenizer-6.0.ss" "libtokenizer.fasl"]
|
|
["libexpand-6.0.ss" "libexpand.fasl"]
|
|
["libinterpret-6.0.ss" "libinterpret.fasl"]
|
|
;["libintelasm-6.0.ss" "libintelasm.fasl"]
|
|
["libcafe-6.0.ss" "libcafe.fasl"]
|
|
; ["libtrace-5.3.ss" "libtrace-5.3.s" "libtrace" ]
|
|
; ["libposix-5.7.ss" "libposix-5.3.s" "libposix" ]
|
|
["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)]))
|
|
|
|
;;; pcb table section
|
|
(define pcb-table
|
|
'(;;; system locations used by the C/Scheme interface
|
|
[$system-stack system "system_stack"]
|
|
[$stack-top system "stack_top"] ; top of stack
|
|
[$stack-size system "stack_size"] ; its size
|
|
[$frame-base system "frame_base"] ; base of the frame
|
|
[$frame-redline system "frame_redline"] ; top + 2 pages
|
|
[$frame-pointer system "frame_pointer"] ;
|
|
[$heap-base system "heap_base"]
|
|
[$heap-size system "heap_size"]
|
|
[$allocation-redline system "allocation_redline"]
|
|
[$allocation-pointer system "allocation_pointer"]
|
|
[$roots system "roots"]
|
|
[$string-base system "string_base"]
|
|
[$string-ap system "string_ap"]
|
|
[$string-eap system "string_eap"]
|
|
[$string-pages system "string_pages"]
|
|
[$allocated-megs system "allocated_megs"]
|
|
[$allocated-bytes system "allocated_bytes"]
|
|
[$reclaimed-megs system "reclaimed_megs"]
|
|
[$reclaimed-bytes system "reclaimed_bytes"]
|
|
;;; scheme_objects comes before all scheme objects
|
|
[$scheme-objects system "scheme_objects"]
|
|
[$next-continuation system "next_continuation"]
|
|
;;; error handling procedures used by the codegen
|
|
[$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
|
|
[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]
|
|
;;;
|
|
[$scheme-objects-end system "scheme_objects_end"]
|
|
))
|
|
|
|
(define (public-primitives)
|
|
(let f ([ls pcb-table])
|
|
(cond
|
|
[(null? ls) '()]
|
|
[(eq? (cadar ls) 'public)
|
|
(cons (caar ls) (f (cdr ls)))]
|
|
[else (f (cdr ls))])))
|
|
|
|
(define (library-primitives)
|
|
(let f ([ls pcb-table])
|
|
(cond
|
|
[(null? ls) '()]
|
|
[(eq? (cadar ls) 'library)
|
|
(cons (caar ls) (f (cdr ls)))]
|
|
[else (f (cdr ls))])))
|
|
|
|
|
|
|
|
|
|
(define (pcb-system-loc? x)
|
|
(cond
|
|
[(assq x pcb-table) =>
|
|
(lambda (x) (eq? (cadr x) 'system))]
|
|
[else (error 'pcb-system-loc? "not in table ~s" x)]))
|
|
|
|
(define *pcb-set-marker* (gensym))
|
|
|
|
(define *pcb-ref-marker* (gensym))
|
|
|
|
(define (mark-pcb-set-found x)
|
|
(putprop x *pcb-set-marker* #t))
|
|
|
|
(define (mark-pcb-ref-found x)
|
|
(putprop x *pcb-ref-marker* #t))
|
|
|
|
(define (pcb-referenced? x)
|
|
(getprop x *pcb-ref-marker*))
|
|
|
|
(define (pcb-assigned? x)
|
|
(getprop x *pcb-set-marker*))
|
|
|
|
(define (pcb-index x)
|
|
(error 'pcb-index "dead on ~s" x)
|
|
(mark-pcb-ref-found x)
|
|
(let f ([i 0] [ls pcb-table])
|
|
(cond
|
|
[(null? ls)
|
|
(error 'pcb-index "not in table ~s" x)]
|
|
[(eq? x (caar ls)) i]
|
|
[else (f (fxadd1 i) (cdr ls))])))
|
|
|
|
(define (pcb-offset x)
|
|
(fx* (pcb-index x) wordsize))
|
|
|
|
(define (primitive? x)
|
|
(cond
|
|
[(assq x pcb-table) #t]
|
|
[(assq x open-coded-primitives) #t]
|
|
[else #f]))
|
|
|
|
(define (open-codeable? x)
|
|
(cond
|
|
[(assq x open-coded-primitives) #t]
|
|
[(assq x pcb-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)]))
|
|
|
|
(define (pcb-cname x)
|
|
(define (cname x i)
|
|
(cond
|
|
[(eq? (cadr x) 'system) (caddr x)]
|
|
[else (format "prim_~a" i)]))
|
|
(let f ([ls pcb-table] [i 0])
|
|
(cond
|
|
[(null? ls) (error 'pcb-cname "invalid name ~s" x)]
|
|
[(eq? (caar ls) x) (cname (car ls) i)]
|
|
[else (f (cdr ls) (fxadd1 i))])))
|
|
|
|
(define (pcb-cnames)
|
|
(define (cname x i)
|
|
(cond
|
|
[(eq? (cadr x) 'system) (caddr x)]
|
|
[else (format "prim_~a" i)]))
|
|
(let f ([ls pcb-table] [i 0])
|
|
(cond
|
|
[(null? ls) '()]
|
|
[else
|
|
(cons (cname (car ls) i) (f (cdr ls) (fxadd1 i)))])))
|
|
|
|
;;; end of pcb 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 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 (lhs* rhs* 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)))]))]
|
|
[(lambda)
|
|
(unless (fx= (length x) 3)
|
|
(error 'recordize "invalid ~s" x))
|
|
(let ([fml* (cadr x)] [body (caddr x)])
|
|
(let ([nfml* (gen-fml* fml*)])
|
|
(make-function
|
|
(properize nfml*)
|
|
(list? fml*)
|
|
(E body (extend-env fml* nfml* env)))))]
|
|
[($pcb-set!)
|
|
(let ([var (quoted-sym (cadr x))] [val (caddr x)])
|
|
(mark-pcb-set-found var)
|
|
(make-primcall '$pcb-set!
|
|
(list (make-constant (pcb-index var))
|
|
(E val env))))]
|
|
[(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))]
|
|
[(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 lhs* rhs* body)
|
|
`(codes ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
|
|
,(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))]
|
|
;;; (define-record new-frame (base-idx size body))
|
|
[(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])]
|
|
[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 rator rand*)
|
|
(record-case rator
|
|
[(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))]
|
|
[(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))]
|
|
[(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))))]
|
|
[(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)))]
|
|
[(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 (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) (append a-free d-free)))]))
|
|
(define (Expr x)
|
|
(record-case x
|
|
[(constant) (values x '())]
|
|
[(var) (values x '())]
|
|
[(primref) (values x '())]
|
|
[(bind lhs* rhs* body)
|
|
(let-values ([(rhs* rhs-codes) (Expr* rhs*)]
|
|
[(body body-codes) (Expr body)])
|
|
(values (make-bind lhs* rhs* body)
|
|
(append rhs-codes body-codes)))]
|
|
[(conditional test conseq altern)
|
|
(let-values ([(test test-codes) (Expr test)]
|
|
[(conseq conseq-codes) (Expr conseq)]
|
|
[(altern altern-codes) (Expr altern)])
|
|
(values (make-conditional test conseq altern)
|
|
(append test-codes conseq-codes altern-codes)))]
|
|
[(seq e0 e1)
|
|
(let-values ([(e0 e0-codes) (Expr e0)]
|
|
[(e1 e1-codes) (Expr e1)])
|
|
(values (make-seq e0 e1) (append e0-codes e1-codes)))]
|
|
[(closure c free)
|
|
(let-values ([(c codes)
|
|
(record-case c
|
|
[(code-rec arg* proper free* body)
|
|
(let-values ([(body body-codes) (Expr body)])
|
|
(let ([g (make-code-loc 'code)])
|
|
(values g
|
|
(cons
|
|
(cons g (make-code-rec arg* proper free* body))
|
|
body-codes))))]
|
|
[else (error #f "invalid code ~s" c)])])
|
|
(values (make-closure c free) codes))]
|
|
[(primcall op rand*)
|
|
(let-values ([(rand* rand*-codes) (Expr* rand*)])
|
|
(values (make-primcall op rand*) rand*-codes))]
|
|
[(forcall op rand*)
|
|
(let-values ([(rand* rand*-codes) (Expr* rand*)])
|
|
(values (make-forcall op rand*) rand*-codes))]
|
|
[(funcall rator rand*)
|
|
(let-values ([(rator rat-codes) (Expr rator)]
|
|
[(rand* rand*-codes) (Expr* rand*)])
|
|
(values
|
|
(make-funcall rator rand*)
|
|
(append rat-codes rand*-codes)))]
|
|
[(appcall rator rand*)
|
|
(let-values ([(rator rat-codes) (Expr rator)]
|
|
[(rand* rand*-codes) (Expr* rand*)])
|
|
(values
|
|
(make-appcall rator rand*)
|
|
(append rat-codes rand*-codes)))]
|
|
[else (error who "invalid expression ~s" (unparse x))]))
|
|
(let-values ([(x codes) (Expr x)])
|
|
(make-codes (map car codes) (map cdr 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 (CodeExpr x)
|
|
(record-case x
|
|
[(code-rec fml* proper free* body)
|
|
(make-code-rec fml* proper free* (Tail body))]))
|
|
(define (CodesExpr x)
|
|
(record-case x
|
|
[(codes lhs* rhs* body)
|
|
(make-codes lhs* (map CodeExpr rhs*) (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 (CodeExpr x)
|
|
(record-case x
|
|
[(code-rec fml* proper free* body)
|
|
(make-code-rec fml* proper free* (Tail body))]))
|
|
(define (CodesExpr x)
|
|
(record-case x
|
|
[(codes lhs* rhs* body)
|
|
(make-codes lhs* (map CodeExpr rhs*) (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 (CodeExpr x)
|
|
(record-case x
|
|
[(code-rec fml* proper free* body)
|
|
(if (Tail body)
|
|
(make-code-rec fml* proper free*
|
|
(insert-check body))
|
|
x)]))
|
|
(define (CodesExpr x)
|
|
(record-case x
|
|
[(codes lhs* rhs* body)
|
|
(make-codes lhs* (map CodeExpr rhs*)
|
|
(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 (CodeExpr x)
|
|
(record-case x
|
|
[(code-rec fml* proper free* body)
|
|
(make-code-rec fml* proper free* (Tail body))]))
|
|
(define (CodesExpr x)
|
|
(record-case x
|
|
[(codes lhs* rhs* body)
|
|
(make-codes lhs* (map CodeExpr rhs*) (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 (CodeExpr x)
|
|
(record-case x
|
|
[(code-rec fml* proper free* body)
|
|
(let-values ([(fml* si r live) (bind-fml* fml* (bind-free* free*))])
|
|
(make-code-rec fml* proper free* (Tail body si r live)))]))
|
|
(define (CodesExpr x)
|
|
(record-case x
|
|
[(codes lhs* rhs* body)
|
|
(make-codes lhs*
|
|
(map CodeExpr rhs*)
|
|
(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)]))
|
|
; (mem (fx* (pcb-index op) wordsize) pcr))
|
|
;;; (define (immediate-rep x)
|
|
;;; (cond
|
|
;;; [(fixnum? x) (fxsll x fx-shift)]
|
|
;;; [(boolean? x) (if x bool-t bool-f)]
|
|
;;; [(null? x) nil]
|
|
;;; [(char? x) (fx+ (fxsll (char->integer x) char-shift) char-tag)]
|
|
;;; [else (error 'immediate-rep "invalid immediate ~s" x)]))
|
|
;;; (define (bool-bit-to-boolean ac)
|
|
;;; (list*
|
|
;;; (movzbl al eax)
|
|
;;; (shll (int bool-shift) eax)
|
|
;;; (orl (int bool-tag) eax)
|
|
;;; ac))
|
|
(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)]
|
|
[($pcb-set! $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 (label SL_continuation_code)) arg*)
|
|
ac)]
|
|
[($make-call-with-values-procedure)
|
|
(NonTail
|
|
(make-closure (make-code-loc (label SL_call_with_values)) arg*)
|
|
ac)]
|
|
[($make-values-procedure)
|
|
(NonTail
|
|
(make-closure (make-code-loc (label 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))]
|
|
;;; [($pcb-set!)
|
|
;;; (let ([loc (car arg*)] [val (cadr arg*)])
|
|
;;; (record-case loc
|
|
;;; [(constant i)
|
|
;;; (unless (fixnum? i) (error who "invalid loc ~s" loc))
|
|
;;; (list* (movl (Simple val) eax)
|
|
;;; (movl eax (mem (fx* i wordsize) pcr))
|
|
;;; ac)]
|
|
;;; [else (error who "invalid loc ~s" loc)]))]
|
|
[($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)]
|
|
[($exit)
|
|
(list*
|
|
(movl (Simple (car arg*)) eax)
|
|
(movl (pcb-ref 'frame-base) fpr)
|
|
(movl (int 0) (pcb-ref 'next-continuation))
|
|
(jmp (label SL_scheme_exit))
|
|
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))]
|
|
[($install-underflow-handler)
|
|
(list*
|
|
(movl (pcb-ref 'frame-base) eax)
|
|
(movl (label-address SL_underflow_handler) ebx)
|
|
(movl ebx (mem 0 eax))
|
|
(movl ebx (pcb-ref 'underflow-handler))
|
|
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-name 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 (handle-procedure-entry proper fml-count ac)
|
|
(cond
|
|
[proper
|
|
(list* (cmpl (int (argc-convention fml-count)) eax)
|
|
(jne (label SL_invalid_args))
|
|
ac)]
|
|
[else (handle-vararg fml-count ac)]))
|
|
(define emit-code
|
|
(lambda (label x)
|
|
(record-case x
|
|
[(code-rec fml* proper free* body)
|
|
(list*
|
|
(fx+ disp-closure-data (fx* wordsize (length free*)))
|
|
label
|
|
(handle-procedure-entry proper (length fml*)
|
|
(Tail body '())))])))
|
|
(define (emit-codes prog)
|
|
(record-case prog
|
|
[(codes lhs* rhs* body)
|
|
(let ([label* (map (lambda (x) (unique-label)) lhs*)]
|
|
[main (unique-label)])
|
|
(for-each set-code-loc-label! lhs* label*)
|
|
(let ([procs (map emit-code label* rhs*)]
|
|
[main-proc (cons 0 (Tail body '()))])
|
|
(cons main-proc procs)))]))
|
|
(define label-name cadr)
|
|
(emit-codes x))
|
|
|
|
(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)))
|
|
|
|
;;; (list 'public-function
|
|
;;; "SL_scheme_exit"
|
|
;;; 0
|
|
;;; (movl apr (mem (pcb-offset '$allocation-pointer) pcr))
|
|
;;; (cmpl (pcb-ref 'frame-base) fpr)
|
|
;;; (jne (label "L_scheme_exit_fp_mismatch"))
|
|
;;; (movl (mem (pcb-offset '$system-stack) pcr) esp)
|
|
;;; (pop ebp)
|
|
;;; (pop edi)
|
|
;;; (pop esi)
|
|
;;; (pop ebx)
|
|
;;; (ret)
|
|
;;; (label "L_scheme_exit_fp_mismatch")
|
|
;;; (movl (int 0) eax)
|
|
;;; (movl (mem 0 eax) eax))
|
|
|
|
|
|
;;;; (let ([L_umv_last_continuation (gensym)]
|
|
;;;; [L_umv_stack_overflow (gensym)]
|
|
;;;; [L_umv_heap_overflow (gensym)]
|
|
;;;; [L_umv_bad_rp (gensym)]
|
|
;;;; [L_umv_bad_fpr (gensym)]
|
|
;;;; [L_umv_copy_frame_done (gensym)]
|
|
;;;; [L_umv_copy_frame_loop (gensym)]
|
|
;;;; [L_umv_copy_values_done (gensym)]
|
|
;;;; [L_umv_copy_values_loop (gensym)]
|
|
;;;; [L_umv_no_stack_overflow (gensym)]
|
|
;;;; [L_umv_single_frame (gensym)]
|
|
;;;; [L_umv_split_continuation (gensym)]
|
|
;;;; [L_umv_framesz_ok (gensym)]
|
|
;;;; )
|
|
;;;; (list 0
|
|
;;;; (label SL_underflow_multiple_values)
|
|
;;;; ;;; So, we are underflowing with multiple values
|
|
;;;; ;;; the index of the last value is in %eax
|
|
;;;; ;;; so, the last value is in 0(%fpr,%eax)
|
|
;;;; ;;; What we need to do is shift the values up by the
|
|
;;;; ;;; size of the next frame, copy the frame over,
|
|
;;;; ;;; adjust the frame pointer, then mv-return to the
|
|
;;;; ;;; next frame.
|
|
;;;; ;;; Caveats:
|
|
;;;; ;;; * may need to split the next-k if it's more than
|
|
;;;; ;;; one frame
|
|
;;;; ;;; * splitting the continuation may heap-overflow
|
|
;;;; ;;; * the required stack size (to hold the values and
|
|
;;;; ;;; the previous frame) may actually cause a stack
|
|
;;;; ;;; overflow!
|
|
;;;; ;;;
|
|
;;;; ; First, do some assertions
|
|
;;;; (cmpl (pcb-ref 'frame-base) fpr)
|
|
;;;; (jne (label L_umv_bad_fpr))
|
|
;;;; (cmpl (label-address SL_underflow_handler) (mem 0 fpr))
|
|
;;;; (jne (label L_umv_bad_rp))
|
|
;;;; (movl (pcb-ref 'next-continuation) ebx)
|
|
;;;; (cmpl (int 0) ebx)
|
|
;;;; (je (label L_umv_last_continuation))
|
|
;;;; ; all is good, now check that we have one frame
|
|
;;;; (movl (mem (fx- disp-continuation-top vector-tag) ebx) ecx) ; top
|
|
;;;; (movl (mem 0 ecx) edx) ; return-point
|
|
;;;; (movl (mem disp-frame-size edx) edx) ; framesize
|
|
;;;; (cmpl (int 0) edx)
|
|
;;;; (jne (label L_umv_framesz_ok))
|
|
;;;; (movl (mem wordsize ecx) edx) ; load framesize from top[1]
|
|
;;;; ; argc=%eax, next_k=%ebx, frametop=%ecx, framesize=%edx
|
|
;;;; (label L_umv_framesz_ok)
|
|
;;;; (cmpl (mem (fx- disp-continuation-size vector-tag) ebx) edx)
|
|
;;;; (je (label L_umv_single_frame))
|
|
;;;;;;;
|
|
;;;; (cmpl (pcb-ref 'allocation-redline) apr)
|
|
;;;; (jge (label L_umv_heap_overflow))
|
|
;;;; (label L_umv_split_continuation)
|
|
;;;; ; ebx=cc, ecx=cont_top, edx=top_frame_size
|
|
;;;; (movl (int continuation-tag) (mem 0 apr))
|
|
;;;; (addl edx ecx)
|
|
;;;; (movl ecx (mem disp-continuation-top apr))
|
|
;;;; (movl (mem (fx- disp-continuation-size vector-tag) ebx) ecx)
|
|
;;;; (subl edx ecx)
|
|
;;;; (movl ecx (mem disp-continuation-size apr))
|
|
;;;; (movl edx (mem (fx- disp-continuation-size vector-tag) ebx))
|
|
;;;; (movl (mem (fx- disp-continuation-next vector-tag) ebx) ecx)
|
|
;;;; (movl ecx (mem disp-continuation-next apr))
|
|
;;;; (movl apr ecx)
|
|
;;;; (addl (int vector-tag) ecx)
|
|
;;;; (movl ecx (mem (fx- disp-continuation-next vector-tag) ebx))
|
|
;;;; (addl (int continuation-size) apr)
|
|
;;;; (movl (mem (fx- disp-continuation-top vector-tag) ebx) ecx)
|
|
;;;;;;;
|
|
;;;; (label L_umv_single_frame)
|
|
;;;; ; argc=%eax, next_k=%ebx, frametop=%ecx, framesize=%edx
|
|
;;;; (negl edx)
|
|
;;;; (addl eax edx) ; %edx is the offset to the last req cell
|
|
;;;; (addl fpr edx) ; %edx is the address of the last req cell
|
|
;;;; (cmpl (pcb-ref 'frame-redline) edx)
|
|
;;;; (jle (label L_umv_stack_overflow))
|
|
;;;; (label L_umv_no_stack_overflow)
|
|
;;;; (movl (mem (fx- disp-continuation-size vector-tag) ebx) edx)
|
|
;;;; (cmpl (int 0) eax)
|
|
;;;; (je (label L_umv_copy_values_done))
|
|
;;;; ; make ecx point to the last arg, edx is the shift amount
|
|
;;;; (negl edx)
|
|
;;;; (movl fpr ecx)
|
|
;;;; (addl eax ecx)
|
|
;;;; (label L_umv_copy_values_loop)
|
|
;;;; (movl (mem 0 ecx) ebx)
|
|
;;;; (movl ebx (mem edx ecx))
|
|
;;;; (addl (int wordsize) ecx)
|
|
;;;; (cmpl ecx fpr)
|
|
;;;; (jne (label L_umv_copy_values_loop))
|
|
;;;; (negl edx)
|
|
;;;; (label L_umv_copy_values_done)
|
|
;;;; ; now all the values were copied to their new locations
|
|
;;;; ; so, now, we copy the next frame
|
|
;;;; (movl (pcb-ref 'next-continuation) ebx)
|
|
;;;; (movl (mem (fx- disp-continuation-top vector-tag) ebx) ecx)
|
|
;;;; ; %ebx=next_k, %ecx=frame_top, %edx=framesize, %eax=argc
|
|
;;;; (label L_umv_copy_frame_loop)
|
|
;;;; (subl (int wordsize) edx)
|
|
;;;; (pushl (mem edx ecx))
|
|
;;;; (cmpl (int 0) edx)
|
|
;;;; (jne (label L_umv_copy_frame_loop))
|
|
;;;; (label L_umv_copy_frame_done)
|
|
;;;; ;;; okay, almost done
|
|
;;;; ;;; set next k appropriately
|
|
;;;; (movl (mem (fx- disp-continuation-next vector-tag) ebx) ebx)
|
|
;;;; (movl ebx (pcb-ref 'next-continuation))
|
|
;;;; (movl (mem 0 fpr) ebx)
|
|
;;;; (jmp (mem disp-multivalue-rp ebx)) ; go
|
|
;;;; ;;;
|
|
;;;; (label L_umv_bad_fpr)
|
|
;;;; (movl (int 0) eax) (movl (mem 0 eax) eax)
|
|
;;;; (label L_umv_bad_rp)
|
|
;;;; (movl (int 0) eax) (movl (mem 0 eax) eax)
|
|
;;;; (label L_umv_heap_overflow)
|
|
;;;; (movl (int 0) eax) (movl (mem 0 eax) eax)
|
|
;;;; (label L_umv_stack_overflow)
|
|
;;;; (movl (int 0) eax) (movl (mem 0 eax) eax)
|
|
;;;; (label L_umv_last_continuation)
|
|
;;;; (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_scheme_exit)
|
|
;;; (jmp (pcb-ref 'return-point)))
|
|
|
|
;;; (let ([L_underflow_overflow_call (gensym)]
|
|
;;; [L_underflow_heap_overflow (gensym)]
|
|
;;; [L_underflow_misaligned (gensym)]
|
|
;;; [L_underflow_no_rp (gensym)]
|
|
;;; [L_underflow_copy_loop (gensym)]
|
|
;;; [L_underflow_single_frame (gensym)]
|
|
;;; [L_underflow_multiple_frames (gensym)]
|
|
;;; [L_underflow_normal_frame (gensym)]
|
|
;;; [L_underflow_special_frame (gensym)]
|
|
;;; [L_underflow_frame_ok (gensym)])
|
|
;;; (list 0
|
|
;;; ;(gensym) ; L_underflow
|
|
;;; (label-address SL_underflow_multiple_values)
|
|
;;; (byte-vector
|
|
;;; (make-vector (fx- 0 (fx+ wordsize disp-multivalue-rp)) 0))
|
|
;;; (label SL_underflow_handler)
|
|
;;; ; since we underflow with a call to (ret), the current fp
|
|
;;; ; is below the valid stack, so we advance it up to point
|
|
;;; ; to the underflow handler that caused the ret
|
|
;;; (subl (int wordsize) fpr)
|
|
;;; ; load next continuation into ebx, and if ebx=0, exit
|
|
;;; ; since the computation is complete
|
|
;;; (movl (pcb-ref 'next-continuation) ebx)
|
|
;;; (cmpl (int 0) ebx)
|
|
;;; (je (label SL_scheme_exit))
|
|
;;; ; sanity check that fpr *is* where it should be
|
|
;;; (cmpl (pcb-ref 'frame-base) fpr)
|
|
;;; (jne (label L_underflow_misaligned))
|
|
;;; (label L_underflow_frame_ok)
|
|
;;; ; sanity check that 0(fpr) does contain underflow hander
|
|
;;; (cmpl (label-address SL_underflow_handler) (mem 0 fpr))
|
|
;;; (jne (label L_underflow_no_rp))
|
|
;;; ; save the value of eax
|
|
;;; (pushl eax)
|
|
;;; ; now ebx=next_cont
|
|
;;; (movl (mem (fx- disp-continuation-top vector-tag) ebx) ecx)
|
|
;;; ; ebx=cc, ecx=cont_top
|
|
;;; (movl (mem (fx- disp-continuation-size vector-tag) ebx) eax)
|
|
;;; ; ebx=cc, ecx=cont_top, eax=cont_size
|
|
;;; (movl (mem 0 ecx) edx) ; return point is in edx
|
|
;;; ; ebx=cc, ecx=cont_top, eax=cont_size, edx=rp
|
|
;;; (movl (mem disp-frame-size edx) edx) ; size
|
|
;;; ; ebx=cc, ecx=cont_top, eax=cont_size, edx=top_frame_size
|
|
;;; (cmpl (int 0) edx)
|
|
;;; (jne (label L_underflow_normal_frame))
|
|
;;; (label L_underflow_special_frame)
|
|
;;;
|
|
;;;
|
|
;;; (movl (primref-loc '$debug) cpr)
|
|
;;; (movl (obj "BUG:SPECIAL") eax)
|
|
;;; (movl eax (mem (fx- 0 wordsize) fpr))
|
|
;;; (movl (int (fx- 0 wordsize)) eax)
|
|
;;; (tail-indirect-cpr-call)
|
|
;;;
|
|
;;;
|
|
;;;
|
|
;;; (movl (int 0) eax)
|
|
;;; (movl (mem 0 eax) eax)
|
|
;;; (label L_underflow_normal_frame)
|
|
;;;
|
|
;;;
|
|
;;;
|
|
;;; ; ebx=cc, ecx=cont_top, eax=cont_size, edx=top_frame_size
|
|
;;; (cmpl eax edx)
|
|
;;; (je (label L_underflow_single_frame))
|
|
;;; (label L_underflow_multiple_frames)
|
|
;;;
|
|
;;; (cmpl (pcb-ref 'allocation-redline) apr)
|
|
;;; (jge (label L_underflow_heap_overflow))
|
|
;;;
|
|
;;; ; ebx=cc, ecx=cont_top, eax=cont_size, edx=top_frame_size
|
|
;;; (movl (int continuation-tag) (mem 0 apr))
|
|
;;; (subl edx eax)
|
|
;;; ; ebx=cc, ecx=cont_top, eax=remaining_size, edx=top_frame_size
|
|
;;; (movl eax (mem disp-continuation-size apr))
|
|
;;; (movl edx (mem (fx- disp-continuation-size vector-tag) ebx))
|
|
;;; (addl edx ecx)
|
|
;;; ; ebx=cc, ecx=next_cont_top, eax=remaining_size, edx=top_frame_size
|
|
;;; (movl ecx (mem disp-continuation-top apr))
|
|
;;; (subl edx ecx)
|
|
;;; ; ebx=cc, ecx=cont_top, eax=next_cont, edx=top_frame_size
|
|
;;; (movl (mem (fx- disp-continuation-next vector-tag) ebx) eax)
|
|
;;; (movl eax (mem disp-continuation-next apr))
|
|
;;; (movl apr eax)
|
|
;;; (addl (int vector-tag) eax)
|
|
;;; (addl (int continuation-size) apr)
|
|
;;; (movl eax (mem (fx- disp-continuation-next vector-tag) ebx))
|
|
;;; ; framesize=edx, top=ecx, cc=ebx
|
|
;;; (label L_underflow_single_frame)
|
|
;;;
|
|
;;; ;;; HERE
|
|
;;;
|
|
;;; ; advance cc
|
|
;;; (movl (mem (fx- disp-continuation-next vector-tag) ebx) eax)
|
|
;;; (movl eax (pcb-ref 'next-continuation))
|
|
;;; (popl eax) ; pop the return value
|
|
;;; (label L_underflow_copy_loop)
|
|
;;; (subl (int wordsize) edx)
|
|
;;; (movl (mem ecx edx) ebx)
|
|
;;; (pushl ebx)
|
|
;;; (cmpl (int 0) edx)
|
|
;;; (jg (label L_underflow_copy_loop))
|
|
;;;
|
|
;;;;;; (movl (primref-loc '$debug) cpr)
|
|
;;;;;; ;;; (movl (obj "SINGLE FRAME LOOP DONE") eax)
|
|
;;;;;; (movl eax (mem (fx- 0 wordsize) fpr))
|
|
;;;;;; (movl (int (fx- 0 wordsize)) eax)
|
|
;;;;;; (tail-indirect-cpr-call)
|
|
;;;
|
|
;;; (ret)
|
|
;;; (label L_underflow_no_rp)
|
|
;;; (movl (int 0) eax)
|
|
;;; (movl (mem 0 eax) eax)
|
|
;;; (label L_underflow_misaligned)
|
|
;;; (movl (pcb-ref 'frame-base) fpr)
|
|
;;; (movl (int 0) eax)
|
|
;;; (movl (int 0) eax)
|
|
;;; (movl (mem 0 eax) eax)
|
|
;;; (movl (primref-loc '$underflow-misaligned-error) cpr)
|
|
;;; (tail-indirect-cpr-call)
|
|
;;; (label L_underflow_heap_overflow)
|
|
;;; ; the return value that was in %eax was pushed previously
|
|
;;; ; so, we push the frame size next
|
|
;;; (pushl (int (fx* 3 wordsize)))
|
|
;;; (movl (primref-loc 'do-overflow) cpr)
|
|
;;; (movl (int (argc-convention 0)) eax)
|
|
;;; (jmp (label L_underflow_overflow_call))
|
|
;;; ; NEW FRAME
|
|
;;; (int 0)
|
|
;;; '(current-frame-offset)
|
|
;;; (int 0)
|
|
;;; (byte 0)
|
|
;;; (byte 0)
|
|
;;; (label L_underflow_overflow_call)
|
|
;;; (indirect-cpr-call)
|
|
;;; (popl eax) ; pop framesize
|
|
;;; (popl eax) ; actual return value and underflow again
|
|
;;; (ret)))
|
|
;;;
|
|
(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)
|
|
|
|
;;; (movl (primref-loc '$debug) cpr)
|
|
;;; (movl (obj "CALLCC MULTI") eax)
|
|
;;; (movl eax (mem (fx- 0 wordsize) fpr))
|
|
;;; (movl (int (fx- 0 wordsize)) eax)
|
|
;;; (tail-indirect-cpr-call)))
|
|
|
|
|
|
(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)]
|
|
[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)]
|
|
[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")
|
|
|
|
#!eof
|
|
|
|
|
|
(define (emit-linear-code obj*)
|
|
(define who 'emit-linear-code)
|
|
(define (arg x)
|
|
(cond
|
|
[(not (pair? x)) (error who "invalid arg ~s" x)]
|
|
[else
|
|
(case (car x)
|
|
[(register) (cadr x)]
|
|
[(label) (cadr x)]
|
|
[(label-address) (format "$~a" (cadr x))]
|
|
[(integer) (format "$~a" (cadr x))]
|
|
[(biginteger) ;;; ARGHHHH
|
|
(format "$(~a<<~a)" (cadr x) fx-shift)]
|
|
[(mem)
|
|
(cond
|
|
[(fixnum? (cadr x))
|
|
(format "~a(~a)" (cadr x) (arg (caddr x)))]
|
|
[else
|
|
(format "(~a,~a)" (arg (cadr x)) (arg (caddr x)))])]
|
|
[(indirect) (format "*~a" (arg (cadr x)))]
|
|
[else (error who "invalid arg ~s" x)])]))
|
|
(define (emit-generic x)
|
|
(case (length x)
|
|
[(1) (emit " ~a" (car x))]
|
|
[(2) (emit " ~a ~a" (car x) (arg (cadr x)))]
|
|
[(3) (emit " ~a ~a, ~a" (car x) (arg (cadr x)) (arg (caddr x)))]
|
|
[else (error 'emit-generic "invalid format ~s" x)]))
|
|
(define (emit-instruction x)
|
|
(case (car x)
|
|
[(pop movl movb push call ret cltd
|
|
cmpl je jne jl jle jg jge jb jbe ja jae
|
|
jmp sete setl setle setg setge movzbl pushl popl
|
|
addl subl orl xorl andl notl sall shrl sarl imull idivl negl)
|
|
(emit-generic x)]
|
|
[(nop) (void)]
|
|
[(label) (emit "~a:" (cadr x))]
|
|
[(comment) (emit "/* ~s */" (cadr x))]
|
|
[(integer)
|
|
(emit ".long ~s" (cadr x))]
|
|
[(byte)
|
|
(emit ".byte ~s" (cadr x))]
|
|
[(byte-vector)
|
|
(let f ([v (cadr x)] [i 0])
|
|
(unless (fx= i (vector-length v))
|
|
(emit ".byte ~s" (vector-ref v i))
|
|
(f v (fxadd1 i))))]
|
|
[(label-address)
|
|
(emit ".long ~a" (cadr x))]
|
|
[(global)
|
|
(emit ".globl ~a" (cadr x))]
|
|
[(current-frame-offset)
|
|
(emit ".long 0 # FRAME OFFSET")]
|
|
[else (error 'emit-instruction "unsupported instruction ~s" (car x))]))
|
|
(define (emit-function-header x)
|
|
(let ([t (car x)] [label (cadr x)] [closure-size (caddr x)])
|
|
(emit ".text")
|
|
(when (eq? t 'public-function)
|
|
(emit ".globl ~a" label))
|
|
(emit ".type ~a @function" label)
|
|
(emit ".align 8")
|
|
(emit ".long ~a" code-tag) ; tag
|
|
(emit ".long 0") ; instr size
|
|
(emit ".long 0") ; reloc size
|
|
(emit ".long ~s" closure-size)
|
|
(emit "~a:" label)))
|
|
(define (emit-function x)
|
|
(emit-function-header x)
|
|
(for-each emit-instruction (cdddr x)))
|
|
(define (emit-data x)
|
|
(let ([t (car x)] [label (cadr x)] [value (caddr x)])
|
|
(emit ".data")
|
|
(emit ".align 4")
|
|
(when (eq? t 'global-data)
|
|
(emit ".globl ~a" label))
|
|
(emit ".type ~a, @object" label)
|
|
(emit ".size ~a, 4" label)
|
|
(emit "~a:" label)
|
|
(emit ".long ~s" value)))
|
|
(define (emit-object x)
|
|
(case (car x)
|
|
[(public-function local-function) (emit-function x)]
|
|
[(data global-data) (emit-data x)]
|
|
[else (error who "invalid object ~s" (car x))]))
|
|
(for-each emit-object obj*))
|
|
|
|
(define (compile-program x)
|
|
(compile-program-with-entry x "scheme"))
|
|
|
|
|
|
|
|
(define (file-content x)
|
|
(let ([p (open-input-file x)])
|
|
(let f ()
|
|
(let ([x (read p)])
|
|
(cond
|
|
[(eof-object? x)
|
|
(close-input-port p)
|
|
'()]
|
|
[else
|
|
(cons x (f))])))))
|
|
|
|
|
|
(define (generate-library x)
|
|
(let ([input-file-name (car x)]
|
|
[output-file-name (cadr x)]
|
|
[entry-name (caddr x)])
|
|
(printf "compiling ~s\n" input-file-name)
|
|
(let ([prog (cons 'begin (file-content input-file-name))])
|
|
(let ([op (open-output-file output-file-name 'replace)])
|
|
(parameterize ([compile-port op]
|
|
[signal-error-on-undefined-pcb #f])
|
|
(compile-program-with-entry prog entry-name))
|
|
(close-output-port op)))))
|
|
|
|
|
|
|
|
|
|
|
|
(define generate-top-level
|
|
(lambda ()
|
|
`(let ([g (gensym "*scheme*")])
|
|
($pcb-set! primitive
|
|
(lambda (x)
|
|
(unless (symbol? x)
|
|
(error 'primitive "~s is not a symbol" x))
|
|
(getprop x g)))
|
|
,@(map (lambda (x)
|
|
`(begin
|
|
($set-symbol-value! ',x ,x)
|
|
(putprop ',x g ,x)))
|
|
(public-primitives))
|
|
,@(map (lambda (x)
|
|
`(begin
|
|
(putprop ',x g ,x)))
|
|
(library-primitives))
|
|
)))
|
|
|
|
|
|
(define (build-autogenerated-prog prog-name prog asm-file libname)
|
|
(printf "compiling ~s\n" prog-name)
|
|
(let ([op (open-output-file asm-file 'replace)])
|
|
(parameterize ([compile-port op])
|
|
(compile-program-with-entry prog libname))
|
|
(close-output-port op)))
|
|
|
|
(define (generate-scheme-h)
|
|
(let ([p (open-output-file "scheme.h" 'replace)])
|
|
(define (def name val)
|
|
(fprintf p "#define ~a ~a\n" name val))
|
|
(define (defp name val)
|
|
(fprintf p "#define ~a ((ptr)~a)\n" name val))
|
|
(fprintf p "/* automatically generated, do not edit */\n")
|
|
(fprintf p "#ifndef SCHEME_H\n")
|
|
(fprintf p "#define SCHEME_H\n")
|
|
(fprintf p "typedef char* ptr;\n")
|
|
(def "fx_shift" fx-shift)
|
|
(def "fx_mask" fx-mask)
|
|
(def "fx_tag" fx-tag)
|
|
(defp "bool_f" bool-f)
|
|
(defp "bool_t" bool-t)
|
|
(def "bool_mask" bool-mask)
|
|
(def "bool_tag" bool-tag)
|
|
(def "bool_shift" bool-shift)
|
|
(defp "empty_list" nil)
|
|
(def "wordsize" wordsize)
|
|
(def "char_shift" char-shift)
|
|
(def "char_tag" char-tag)
|
|
(def "char_mask" char-mask)
|
|
(def "pair_mask" pair-mask)
|
|
(def "pair_tag" pair-tag)
|
|
(def "disp_car" disp-car)
|
|
(def "disp_cdr" disp-cdr)
|
|
(def "pair_size" pair-size)
|
|
(def "symbol_mask" symbol-mask)
|
|
(def "symbol_tag" symbol-tag)
|
|
(def "disp_symbol_string" disp-symbol-string)
|
|
(def "disp_symbol_value" disp-symbol-value)
|
|
(def "symbol_size" symbol-size)
|
|
(def "vector_tag" vector-tag)
|
|
(def "vector_mask" vector-mask)
|
|
(def "disp_vector_length" disp-vector-length)
|
|
(def "disp_vector_data" disp-vector-data)
|
|
(def "string_mask" string-mask)
|
|
(def "string_tag" string-tag)
|
|
(def "disp_string_length" disp-string-length)
|
|
(def "disp_string_data" disp-string-data)
|
|
(def "closure_mask" closure-mask)
|
|
(def "closure_tag" closure-tag)
|
|
(def "disp_closure_data" disp-closure-data)
|
|
(def "disp_closure_code" disp-closure-code)
|
|
(def "record_pmask" record-pmask)
|
|
(def "record_ptag" record-ptag)
|
|
(def "disp_record_data" disp-record-data)
|
|
(def "disp_record_rtd" disp-record-rtd)
|
|
|
|
(def "continuation_tag" continuation-tag)
|
|
(def "disp_continuation_top" disp-continuation-top)
|
|
(def "disp_continuation_size" disp-continuation-size)
|
|
(def "disp_continuation_next" disp-continuation-next)
|
|
(def "continuation_size" continuation-size)
|
|
|
|
(def "code_tag" code-tag)
|
|
(def "disp_code_instrsize" disp-code-instrsize)
|
|
(def "disp_code_relocsize" disp-code-relocsize)
|
|
(def "disp_code_closuresize" disp-code-closuresize)
|
|
(def "disp_code_data" disp-code-data)
|
|
|
|
(def "disp_frame_offset" disp-frame-offset)
|
|
(def "disp_frame_size" disp-frame-size)
|
|
(def "object_alignment" object-alignment)
|
|
(def "align_shift" align-shift)
|
|
|
|
(fprintf p "typedef struct {\n")
|
|
(for-each
|
|
(lambda (x) (fprintf p " ptr ~a;\n" x))
|
|
(pcb-cnames))
|
|
(fprintf p "} pcb_t;\n")
|
|
(fprintf p "ptr scheme_entry(pcb_t* pcb);\n")
|
|
(fprintf p "extern ptr scheme_main(pcb_t* pcb);\n")
|
|
(fprintf p "#endif /* SCHEME_H */\n")
|
|
(close-output-port p)))
|
|
|
|
(define (generate-scheme-c)
|
|
(let ([p (open-output-file "scheme.c" 'replace)])
|
|
(fprintf p "/* automatically generated, do not edit */\n")
|
|
(fprintf p "#include \"scheme.h\"\n")
|
|
(fprintf p "#include <stdio.h>\n")
|
|
(fprintf p "ptr scheme_main(pcb_t* pcb){\n")
|
|
(fprintf p "extern void S_add_roots(pcb_t*,int*);\n")
|
|
(fprintf p "extern void S_check_roots(pcb_t*,int*);\n")
|
|
(fprintf p "extern void SL_values();\n")
|
|
(fprintf p "extern void SL_call_with_values();\n")
|
|
(for-each (lambda (x)
|
|
(let ([name (caddr x)])
|
|
(fprintf p "extern void ~a_entry(pcb_t*);\n" name)
|
|
(fprintf p "extern int ~a_constant_count;\n" name)))
|
|
scheme-library-files)
|
|
(fprintf p "extern void ~a_entry(pcb_t*);\n" "libtoplevel")
|
|
(fprintf p "extern void ~a_entry(pcb_t*);\n" "libcxr")
|
|
(fprintf p "char** ap = (char**) pcb->allocation_pointer;\n")
|
|
(fprintf p "ap[0] = (char*) SL_values;\n")
|
|
(fprintf p "ap[1] = 0;\n")
|
|
(fprintf p "pcb->~a = ((char*)ap) + closure_tag;\n"
|
|
(pcb-cname 'values))
|
|
(fprintf p "ap += 2;\n")
|
|
(fprintf p "ap[0] = (char*) SL_call_with_values;\n")
|
|
(fprintf p "ap[1] = 0;\n")
|
|
(fprintf p "pcb->~a = ((char*)ap) + closure_tag;\n"
|
|
(pcb-cname 'call-with-values))
|
|
(fprintf p "ap += 2;\n")
|
|
(fprintf p "pcb->allocation_pointer = (char*)ap;\n")
|
|
(mark-pcb-set-found 'values)
|
|
(mark-pcb-set-found 'call-with-values)
|
|
(for-each
|
|
(lambda (x)
|
|
(let ([name (caddr x)])
|
|
(fprintf p " S_add_roots(pcb, &~a_constant_count);\n" name)
|
|
(fprintf p " ~a_entry(pcb);\n" name)
|
|
(fprintf p " S_check_roots(pcb, &~a_constant_count);\n" name)))
|
|
scheme-library-files)
|
|
(fprintf p " libcxr_entry(pcb);\n");
|
|
(fprintf p " libtoplevel_entry(pcb);\n");
|
|
(fprintf p " return scheme_entry(pcb);\n");
|
|
(fprintf p "}\n")
|
|
(close-output-port p)))
|
|
|
|
(define (generate-scheme-asm)
|
|
(let ([p (open-output-file "scheme_asm.s" 'replace)])
|
|
(parameterize ([compile-port p])
|
|
(emit "# AUTOMATICALLY GENERATED, DO NOT EDIT")
|
|
(emit-linear-code (asm-helper-code)))
|
|
(close-output-port p)))
|
|
|
|
(define (generate-scheme-runtime-helpers)
|
|
(generate-scheme-h)
|
|
(generate-scheme-c)
|
|
(generate-scheme-asm))
|
|
|
|
|
|
|
|
(define (string-join sep str*)
|
|
(cond
|
|
[(null? str*) ""]
|
|
[(null? (cdr str*)) (car str*)]
|
|
[else (string-append (car str*) sep (string-join sep (cdr str*)))]))
|
|
|
|
(printf "Generating C Helpers\n")
|
|
(generate-scheme-runtime-helpers)
|
|
(printf "Generating libraries\n")
|
|
(for-each generate-library scheme-library-files)
|
|
|
|
(build-autogenerated-prog
|
|
'top-level (generate-top-level) "libtoplevel.s" "libtoplevel")
|
|
(build-autogenerated-prog
|
|
'cxr (generate-cxr-definitions) "libcxr.s" "libcxr")
|
|
|
|
;;; ensure that we did not emit a reference to an unset pcb cell.
|
|
(printf "Checking PCB\n")
|
|
|
|
(let ([undefined '()])
|
|
(for-each
|
|
(lambda (x)
|
|
(when (and (pcb-referenced? (car x))
|
|
(not (pcb-assigned? (car x)))
|
|
(not (pcb-system-loc? (car x))))
|
|
(set! undefined (cons (car x) undefined))))
|
|
pcb-table)
|
|
(unless (null? undefined)
|
|
((if (signal-error-on-undefined-pcb)
|
|
error
|
|
warning)
|
|
'compile "undefined primitives found ~s" undefined)))
|
|
|
|
|
|
(runtime-file
|
|
(string-join " "
|
|
(list* "scheme.c" "scheme_asm.s" "runtime-5.4.c" "collect-5.7.c"
|
|
"libtoplevel.s" "libcxr.s"
|
|
"-luuid"
|
|
(map cadr scheme-library-files))))
|
|
|
|
(with-output-to-file "Makefile"
|
|
(lambda ()
|
|
(printf "stst: stst.s ~a\n" (runtime-file))
|
|
(printf "\tgcc -Wall -o stst stst.s ~a\n" (runtime-file)))
|
|
'replace)
|
|
|
|
(printf "Testing ...\n")
|
|
|
|
;(test-all)
|
|
;(parameterize ([inline-primitives #f]) (test-all))
|
|
;(parameterize ([inline-primitives #t]) (test-all))
|
|
;(parameterize ([input-filter
|
|
; (lambda (x)
|
|
; `(begin
|
|
; (write ,x)
|
|
; (newline)
|
|
; (exit)
|
|
; ))])
|
|
; (test-all))
|
|
|
|
; (parameterize ([inline-primitives #t]
|
|
; [input-filter
|
|
; (lambda (x)
|
|
; `(let ([expr ',x])
|
|
; (let ([p (open-output-file "stst.tmp" 'replace)])
|
|
; (write expr p)
|
|
; (close-output-port p))
|
|
; (let ([p (open-input-file "stst.tmp")])
|
|
; (let ([t (read p)])
|
|
; (unless (equal? t expr)
|
|
; (error 'test
|
|
; "not equal: got ~s, should be ~s"
|
|
; t expr)))
|
|
; (close-input-port p))
|
|
; (write ,x) ; as usual
|
|
; (newline)
|
|
; (exit)))])
|
|
; (test-all))
|
|
|
|
;(parameterize ([inline-primitives #t]
|
|
; [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))))))))
|
|
|
|
(build-program
|
|
`(begin
|
|
(display ,(format "Petite Ikarus Scheme (Build ~a)\n" (get-date)))
|
|
(display "Copyright (c) 2006 Abdulaziz Ghuloum\n\n")
|
|
(new-cafe)))
|
|
|
|
(system "cp stst petite-ikarus-fresh")
|
|
|