diff --git a/.bzrignore b/.bzrignore index b724a69..3c42d39 100644 --- a/.bzrignore +++ b/.bzrignore @@ -1,3 +1,2 @@ -*.s *.tmp *.out diff --git a/src/assembler-tests.ss b/src/assembler-tests.ss deleted file mode 100644 index 157c0c2..0000000 --- a/src/assembler-tests.ss +++ /dev/null @@ -1,756 +0,0 @@ - -(load "chez-compat.ss") - -(load "libintelasm-5.8.ss") -(load "libfasl-6.0.ss") - -(define-record code (code-size reloc-size closure-size code-vec reloc-vec)) -(define make-code - (let ([make-code make-code]) - (lambda (code-size reloc-size closure-size) - (printf "reloc=~s\n" reloc-size) - (let ([code-size (fxsll (fxsra (fx+ code-size 3) 2) 2)]) - (make-code - (fxsra code-size 2) - (fxsra reloc-size 2) - closure-size - (make-vector code-size (cons 'byte 0)) - (make-vector (fxsra reloc-size 2))))))) - -(define set-code-byte! - (lambda (code idx byte) - (vector-set! (code-code-vec code) idx (cons 'byte byte)))) - - -(define set-code-word! - (lambda (code idx x) - (cond - [(fixnum? x) - (set-code-byte! code (fx+ idx 0) (fxsll (fxlogand x #x3F) 2)) - (set-code-byte! code (fx+ idx 1) (fxlogand (fxsra x 6) #xFF)) - (set-code-byte! code (fx+ idx 2) (fxlogand (fxsra x 14) #xFF)) - (set-code-byte! code (fx+ idx 3) (fxlogand (fxsra x 22) #xFF))] - [else (error 'set-code-word! "unhandled ~s" x)]))) - -(define set-code-object! - (lambda (code obj code-idx reloc-idx) - (let ([v (code-reloc-vec code)]) - (vector-set! v reloc-idx (list 'object code-idx obj))))) - -(define set-code-object+offset/rel! - (lambda (code obj code-idx obj-idx reloc-idx) - (let ([v (code-reloc-vec code)]) - (vector-set! v reloc-idx - (list 'object+off/rel code-idx obj obj-idx)) - (vector-set! v (fxadd1 reloc-idx) '(skip))))) - -(define set-code-object+offset! - (lambda (code obj code-idx obj-idx reloc-idx) - (let ([v (code-reloc-vec code)]) - (vector-set! v reloc-idx - (list 'object+off code-idx obj obj-idx)) - (vector-set! v (fxadd1 reloc-idx) '(skip))))) - -(define make-code-executable! - (lambda (x) (void))) - - - -(define eval-code - (lambda (code) - (with-output-to-file "stst.fasl" - (lambda () - (fasl-write code)) - 'replace) - (let ([rv (system "runtime/ikarus stst.fasl > stst.tmp")]) - (unless (zero? rv) - (error 'eval-code "Failed to run: ~s" rv))) - (with-input-from-file "stst.tmp" read))) - - - - -(let () - (define verbose #t) - (define passed-tests 0) - - (define all-tests 0) - - (define test-code - (lambda (code-ls val) - (set! all-tests (fxadd1 all-tests)) - (when verbose (printf "Evaluating\n~s\n" code-ls)) - (let* ([code (car (list*->code* (list code-ls)))] - [v (eval-code code)]) - (when verbose (printf "evaluated\n")) - (cond - [(equal? v val) - (set! passed-tests (fxadd1 passed-tests)) - (when verbose (printf "OK\n"))] - [else - (error 'test-code - "expected ~s, got ~s" val v)])))) - - (printf "testing ... \n") - - (test-code - '([movl (int 0) %eax] - [ret]) - 0) - - - (let ([L1 (gensym)]) - (test-code - `([movl (obj 10) %eax] - [jmp (label ,L1)] - [byte 0] - [byte 1] - [byte 2] - [byte 3] - [byte 4] - [byte 5] - [byte 6] - [byte 7] - [byte 8] - [byte 9] - [label ,L1] - [ret]) - 10)) - - (test-code - '([movl (obj+ (1 2 3) 3) %eax] - [movl (disp (int 0) %eax) %eax] - [ret]) - '(2 3)) - - - - - (test-code - '([movl (int 40) %eax] - [ret]) - 10) - - (test-code - '([movl (obj 40) %eax] - [ret]) - 40) - - (test-code - '([movl (obj 40) %ebx] - [movl %ebx %eax] - [ret]) - 40) - - (test-code - '([movl (obj (1 2 3)) %eax] - [ret]) - '(1 2 3)) - - (test-code - '([movl (obj (1 2 3)) %ebx] - [movl (disp (int -1) %ebx) %eax] - [ret]) - '1) - - (test-code - '([movl (obj (1 2 3)) %ebx] - [movl (disp (int 3) %ebx) %eax] - [ret]) - '(2 3)) - - (test-code - '([movl (obj (1 2 3)) %ebx] - [movl (int 120) %eax] - [movl %eax (disp (int 3) %ebx)] - [movl %ebx %eax] - [ret]) - '(1 . 30)) - - (test-code - '([movl (obj (1 2 3)) %eax] - [movl (int 120) (disp (int -1) %eax)] - [ret]) - '(30 2 3)) - - (test-code - '([movl (obj (1 2 3)) %eax] - [movl (int 120000) (disp (int -1) %eax)] - [ret]) - '(30000 2 3)) - - (test-code - '([movl (int 40) %eax] - [addl (int 80) %eax] - [ret]) - 30) - - (test-code - '([movl (int 40) %eax] - [addl (obj 20) %eax] - [ret]) - 30) - - (test-code - '([movl (int 40) %eax] - [movl (obj 20) %ebx] - [addl %ebx %eax] - [ret]) - 30) - - (test-code - '([movl (obj (1 2 3)) %eax] - [movl (obj 10) %ebx] - [addl (disp (int -1) %eax) %ebx] - [movl %ebx %eax] - [ret]) - '11) - - (test-code - '([movl (obj (1 2 3)) %eax] - [addl (int 1000) %eax] - [movl (obj 10) %ebx] - [addl (disp (int -1001) %eax) %ebx] - [movl %ebx %eax] - [ret]) - '11) - - (test-code - '([movl (obj 10) %eax] - [sall (int 1) %eax] - [ret]) - 20) - - - - (test-code - '([movl (obj 10) %eax] - [sall (int 3) %eax] - [ret]) - 80) - - (test-code - '([movl (obj 10) %eax] - [movl (int 3) %ecx] - [sall %cl %eax] - [ret]) - 80) - - (test-code - '([movl (obj #xF0) %eax] - [sarl (int 1) %eax] - [ret]) - #x78) - - (test-code - '([movl (obj #xF0) %eax] - [sarl (int 4) %eax] - [ret]) - #x0F) - - (test-code - '([movl (obj #xF0) %eax] - [movl (int 4) %ecx] - [sarl %cl %eax] - [ret]) - #x0F) - - - (test-code - '([movl (obj #xFFFF) %eax] - [andl (obj #xF0F0) %eax] - [ret]) - #xF0F0) - - (test-code - '([movl (obj #xFFFF) %eax] - [movl (obj #x7654) %ebx] - [andl %ebx %eax] - [ret]) - #x7654) - - (test-code - '([movl (obj #xFFFF) %eax] - [andl (int #x3F) %eax] - [ret]) - #xF) - - (test-code - '([movl (obj #xFFFF) %eax] - [movl (obj (#xF707F)) %ebx] - [andl (disp (int -1) %ebx) %eax] - [ret]) - #x707F) - - (test-code - '([movl (obj #xFFFF) %eax] - [movl (obj (#xF707F)) %ebx] - [addl (int 1000) %ebx] - [andl (disp (int -1001) %ebx) %eax] - [ret]) - #x707F) - - (test-code - '([movl (int 3) %eax] - [notl %eax] - [ret]) - -1) - - (test-code - '([movl (obj 1942) %eax] - [negl %eax] - [ret]) - -1942) - - (test-code - '([movl (obj 10) %eax] - [jmp (int 10)] - [byte 0] - [byte 1] - [byte 2] - [byte 3] - [byte 4] - [byte 5] - [byte 6] - [byte 7] - [byte 8] - [byte 9] - [ret]) - 10) - - (test-code - '([movl (obj 10) %eax] - [jmp (int 10)] - [byte 0] - [byte 1] - [byte 2] - [byte 3] - [byte 4] - [byte 5] - [ret] - [byte 7] - [byte 8] - [byte 9] - [jmp (int -9)]) - 10) - - - - (let ([L1 (gensym)]) - (test-code - `([movl (obj 10) %eax] - [jmp (label ,L1)] - [byte 0] - [byte 1] - [byte 2] - [byte 3] - [byte 4] - [byte 5] - [byte 6] - [byte 7] - [byte 8] - [byte 9] - [label ,L1] - [ret]) - 10)) - - (let ([L2 (gensym)] - [L3 (gensym)]) - (test-code - `([movl (obj 10) %eax] - [jmp (label ,L2)] - [byte 0] - [byte 1] - [byte 2] - [byte 3] - [byte 4] - [byte 5] - [label ,L3] - [ret] - [byte 7] - [byte 8] - [byte 9] - [label ,L2] - [jmp (label ,L3)]) - 10)) - - - - - (test-code - '([movl (obj 10) (disp (int -4) %esp)] - [movl (obj list) %eax] - [ret]) - 'list) - -;; (test-code -;; '([movl (obj list) %eax] -;; [movl (disp (int 6) %eax) %eax] ; symbol value -;; [ret]) -;; list) - -;; (test-code -;; '([movl (obj 10) (disp (int -4) %esp)] -;; [movl (obj list) %eax] -;; [movl (disp (int 6) %eax) %edi] ; symbol value -;; [movl (obj -1) %eax] ; argc -;; [jmp (disp (int -3) %edi)]) -;; '(10)) - -;; (test-code -;; '([movl (obj 10) (disp (int -4) %esp)] -;; [movl (obj 20) %eax] -;; [movl %eax (disp (int -8) %esp)] -;; [movl (disp (int -8) %esp) %ebx] -;; [movl %ebx (disp (int -12) %esp)] -;; [movl (obj list) %eax] -;; [movl (disp (int 6) %eax) %edi] ; symbol value -;; [movl (obj -3) %eax] ; argc -;; [jmp (disp (int -3) %edi)]) -;; '(10 20 20)) - - (test-code - '([movl (obj 10) %eax] - [imull (int 3) %eax] - [ret]) - 30) - - (test-code - '([movl (obj 10) %eax] - [imull (obj 10) %eax] - [ret]) - 400) - - (test-code - '([movl (obj 10) %eax] - [movl (obj 20) %ebx] - [imull %ebx %eax] - [ret]) - 800) - - (test-code - '([movl (obj 10) %eax] - [movl (obj 20) (disp (int -4) %esp)] - [imull (disp (int -4) %esp) %eax] - [ret]) - 800) - - (test-code - '([movl (obj 10) %eax] - [cltd] - [ret]) - 10) - - (test-code - '([movl (obj 10) %eax] - [movl (obj 100) %edx] - [cltd] - [movl %edx %eax] - [ret]) - 0) - - (test-code - '([movl (obj -10) %eax] - [movl (obj 100) %edx] - [cltd] - [movl %edx %eax] - [sall (int 2) %eax] - [ret]) - -1) - - (let ([L1 (gensym)]) - (test-code - `([movl (int 10) %eax] - [cmpl (int 8) %eax] - [jne (label ,L1)] - [movl (obj 0) %eax] - [ret] - [label ,L1] - [movl (obj 1) %eax] - [ret]) - 1)) - - (let ([L1 (gensym)]) - (test-code - `([movl (int 40) %eax] - [cmpl (obj 10) %eax] - [je (label ,L1)] - [movl (obj 0) %eax] - [ret] - [label ,L1] - [movl (obj 1) %eax] - [ret]) - 1)) - - (let ([L1 (gensym)]) - (test-code - `([movl (int 40) %eax] - [movl (int 30) %ebx] - [cmpl %ebx %eax] - [jge (label ,L1)] - [movl (obj 0) %eax] - [ret] - [label ,L1] - [movl (obj 1) %eax] - [ret]) - 1)) - - (let ([L1 (gensym)]) - (test-code - `([movl (int 40) (disp (int -4) %esp)] - [cmpl (int 70) (disp (int -4) %esp)] - [jle (label ,L1)] - [movl (obj 0) %eax] - [ret] - [label ,L1] - [movl (obj 1) %eax] - [ret]) - 1)) - - (test-code - '([movl (int 40) (disp (int -4) %esp)] - [addl (int 10) %esp] - [movl (disp (int -14) %esp) %eax] - [addl (int -10) %esp] - [ret]) - 10) - - (test-code - '([movl (int 40) (disp (int -4) %esp)] - [addl (int 1000) %esp] - [movl (disp (int -1004) %esp) %eax] - [addl (int -1000) %esp] - [ret]) - 10) - - (let ([L1 (gensym)]) - (test-code - `([movl (int 40) (disp (int -4) %esp)] - [addl (int 1000) %esp] - [cmpl (int 70) (disp (int -1004) %esp)] - [jle (label ,L1)] - [addl (int -1000) %esp] - [movl (obj 0) %eax] - [ret] - [label ,L1] - [addl (int -1000) %esp] - [movl (obj 1) %eax] - [ret]) - 1)) - - (let ([L1 (gensym)]) - (test-code - `([movl (int 4000) (disp (int -4) %esp)] - [addl (int 1000) %esp] - [cmpl (int 7000) (disp (int -1004) %esp)] - [jle (label ,L1)] - [addl (int -1000) %esp] - [movl (obj 0) %eax] - [ret] - [label ,L1] - [addl (int -1000) %esp] - [movl (obj 1) %eax] - [ret]) - 1)) - - (let ([L1 (gensym)]) - (test-code - `([movl (int 40) (disp (int -4) %esp)] - [movl (int 70) %ebx] - [cmpl (disp (int -4) %esp) %ebx] - [jge (label ,L1)] - [movl (obj 0) %eax] - [ret] - [label ,L1] - [movl (obj 1) %eax] - [ret]) - 1)) - - - (let ([L_fact (gensym)] [L1 (gensym)]) - (test-code - `([movl (int 5) %eax] - [call (label ,L_fact)] - [sall (int 2) %eax] - [ret] - [label ,L_fact] - [cmpl (int 0) %eax] - [jne (label ,L1)] - [movl (int 1) %eax] - [ret] - [label ,L1] - [movl %eax (disp (int -4) %esp)] - [addl (int -4) %esp] - [addl (int -1) %eax] - [call (label ,L_fact)] - [addl (int 4) %esp] - [imull (disp (int -4) %esp) %eax] - [ret]) - 120)) - - (test-code - '([movl (int 16) %eax] - [cltd] - [movl (int 4) %ebx] - [idivl %ebx] - [ret]) - 1) - - (test-code - '([movl (int 16) %eax] - [cltd] - [movl (obj (1)) %ebx] - [idivl (disp (int -1) %ebx)] - [ret]) - 1) - - (test-code - '([movl (int 16) %eax] - [cltd] - [movl (int 4) (disp (int -4) %esp)] - [idivl (disp (int -4) %esp)] - [ret]) - 1) - - - (test-code - '([movl (int #x30) %ebx] - [orl (int #x4) %ebx] - [movl %ebx %eax] - [ret]) - (fxsra #x34 2)) - - (test-code - '([movl (int #x30) %eax] - [orl (int #x4) %eax] - [ret]) - (fxsra #x34 2)) - - (test-code - '([movl (int #x30) %eax] - [orl (obj #x1) %eax] - [ret]) - (fxsra #x34 2)) - - (test-code - '([movl (int #x30) %ebx] - [orl (obj #x1) %ebx] - [movl %ebx %eax] - [ret]) - (fxsra #x34 2)) - - (test-code - '([movl (obj (#xC)) %ebx] - [movl (int #x4) %eax] - [orl (disp (int -1) %ebx) %eax] - [ret]) - (fxsra #x34 2)) - - - (test-code - '([movl (int #x30) (disp (int -4) %esp)] - [movl (int #x4) %eax] - [orl (disp (int -4) %esp) %eax] - [ret]) - (fxsra #x34 2)) - - (test-code - '([pushl (int 8)] - [movl (disp (int 0) %esp) %eax] - [addl (int 4) %esp] - [ret]) - 2) - - (test-code - '([pushl (int 8000)] - [movl (disp (int 0) %esp) %eax] - [addl (int 4) %esp] - [ret]) - 2000) - - (test-code - '([movl (int 8000) %ebx] - [pushl %ebx] - [movl (disp (int 0) %esp) %eax] - [addl (int 4) %esp] - [ret]) - 2000) - - (test-code - '([movl (obj (1 2 3)) %eax] - [pushl (disp (int 3) %eax)] - [addl (int 4) %esp] - [movl (disp (int -4) %esp) %eax] - [ret]) - '(2 3)) - - (test-code - '([movl (obj (1 2 3)) %eax] - [addl (int -1000) %eax] - [pushl (disp (int 1003) %eax)] - [addl (int 4) %esp] - [movl (disp (int -4) %esp) %eax] - [ret]) - '(2 3)) - - (test-code - '([pushl (obj 100)] - [popl %eax] - [ret]) - 100) - - (test-code - '([pushl (obj 100)] - [popl (disp (int -32) %esp)] - [movl (disp (int -32) %esp) %eax] - [ret]) - 100) - - (test-code - '([movl (int 4) %eax] - [cmpl (int 5) %eax] - [sete %al] - [andl (int 1) %eax] - [sall (int 2) %eax] - [ret]) - 0) - - (test-code - '([movl (int 4) %eax] - [cmpl (int 5) %eax] - [setle %al] - [andl (int 1) %eax] - [sall (int 2) %eax] - [ret]) - 1) - - (test-code - '([movl (obj+ (1 2 3) 3) %eax] - [movl (disp (int 0) %eax) %eax] - [ret]) - '(2 3)) - - (let ([L_entry (gensym)] [L_no (gensym)]) - (test-code - `([movl (obj 10) %eax] - [ret] - [label ,L_entry] - [cmpl (int 1) %eax] - [jne (label ,L_no)] - [movl (obj foo) %eax] - [ret] - [label ,L_no] - [movl (obj bar) %eax] - [ret]) - 10) - (test-code - `([movl (int 1) %eax] - [jmp (label ,L_entry)]) - 'foo) - (test-code - `([movl (int 0) %eax] - [jmp (label ,L_entry)]) - 'bar)) - - (printf "Passed ~s/~s tests in assembler\n" passed-tests all-tests) -) diff --git a/src/build-date.tmp b/src/build-date.tmp index a33701c..77c2433 100644 --- a/src/build-date.tmp +++ b/src/build-date.tmp @@ -1 +1 @@ -2006-08-22 +2006-08-25 diff --git a/src/chez-compat.ss b/src/chez-compat.ss deleted file mode 100644 index 9ef66bf..0000000 --- a/src/chez-compat.ss +++ /dev/null @@ -1,57 +0,0 @@ -(define-syntax $pcb-set! - (syntax-rules () - [(_ name val) - (set-top-level-value! 'name val)])) - -(define primitive-set! set-top-level-value!) - -(define (immediate? x) - (or (fixnum? x) - (null? x) - (char? x) - (boolean? x) - (eof-object? x) - (eq? x (void)))) - -(define fxadd1 - (lambda (x) - (import scheme) - (unless (fixnum? x) (error 'fxadd1 "~s is not a fixnum" x)) - (let ([v (+ x 1)]) - (unless (fixnum? v) (error 'fxadd1 "overflow")) - v))) - -(define fxsub1 - (lambda (x) - (import scheme) - (unless (fixnum? x) (error 'fxsub1 "~s is not a fixnum" x)) - (let ([v (- x 1)]) - (unless (fixnum? v) (error 'fxsub1 "overflow")) - v))) - -(define char= char=?) - -(set! $base-rtd #%$base-rtd) -(define-syntax |#primitive| - (syntax-rules () - [(_ n prim) prim] - [(_ prim) prim])) - -(define (date-string) - (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)))))))) - -(define ($record rtd . args) - (apply (record-constructor rtd) args)) -(define ($record/rtd? x rtd) - (and (record? x) (eq? (record-type-descriptor x) rtd))) -(define ($record-ref x i) - ((record-field-accessor (record-type-descriptor x) i) x)) -(define ($record-set! x i v) - ((record-field-mutator (record-type-descriptor x) i) x v)) diff --git a/src/compiler-6.0.ss b/src/compiler-6.0.ss deleted file mode 100644 index c3892a5..0000000 --- a/src/compiler-6.0.ss +++ /dev/null @@ -1,3890 +0,0 @@ - -(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 \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") - diff --git a/src/compiler-6.1.ss b/src/compiler-6.1.ss deleted file mode 100644 index e3d5847..0000000 --- a/src/compiler-6.1.ss +++ /dev/null @@ -1,3132 +0,0 @@ - -;;; 6.1: added case-lambda, dropped lambda -;;; 6.0: basic compiler -;;; -(when (eq? "" "") - (load "chez-compat.ss") - (set! primitive-ref top-level-value) - (load "libexpand-6.1.ss") - ;(load "libinterpret-6.0.ss") - (load "record-case.ss") - ;(#%current-eval eval) - ) - -(define primitive-set! set-top-level-value!) - -(load "libassembler-compat-6.0.ss") ; defines make-code etc. -(load "libintelasm-6.0.ss") ; uses make-code, etc. -(load "libfasl-6.0.ss") ; uses code? etc. - - - -(load "tests-driver.ss") -(print-gensym #f) -(gensym-prefix "L_") - - -(define assembler-output (make-parameter #t)) - -(load "set-operations.ss") -;(load "tests-5.6-req.scm") -;(load "tests-5.3-req.scm") -;(load "tests-5.2-req.scm") -;(load "tests-5.1-req.scm") -;(load "tests-4.3-req.scm") -;(load "tests-4.2-req.scm") - -;(load "tests-4.1-req.scm") -;(load "tests-3.4-req.scm") - -;(load "tests-3.3-req.scm") -;(load "tests-3.2-req.scm") -;(load "tests-3.1-req.scm") -;(load "tests-2.9-req.scm") -;(load "tests-2.8-req.scm") -;(load "tests-2.6-req.scm") -;(load "tests-2.4-req.scm") -;(load "tests-2.3-req.scm") -;(load "tests-2.2-req.scm") -;(load "tests-2.1-req.scm") -;(load "tests-1.9-req.scm") -;(load "tests-1.8-req.scm") -;(load "tests-1.7-req.scm") -;(load "tests-1.6-req.scm") -;(load "tests-1.5-req.scm") -;(load "tests-1.4-req.scm") -;(load "tests-1.3-req.scm") -;(load "tests-1.2-req.scm") -;(load "tests-1.1-req.scm") - - -(define scheme-library-files - '(["libhandlers-6.0.ss" "libhandlers.fasl"] - ["libcontrol-6.1.ss" "libcontrol.fasl"] - ["libcollect-6.1.ss" "libcollect.fasl"] - ["librecord-6.1.ss" "librecord.fasl"] - ["libcxr-6.0.ss" "libcxr.fasl"] - ["libcore-6.1.ss" "libcore.fasl"] - ["libio-6.1.ss" "libio.fasl"] - ["libwriter-6.1.ss" "libwriter.fasl"] - ["libtokenizer-6.1.ss" "libtokenizer.fasl"] - ["libexpand-6.1.ss" "libexpand.fasl"] - ["libinterpret-6.1.ss" "libinterpret.fasl"] - ;["libintelasm-6.0.ss" "libintelasm.fasl"] - ["libcafe-6.1.ss" "libcafe.fasl"] -; ["libtrace-5.3.ss" "libtrace-5.3.s" "libtrace" ] - ["libposix-6.0.ss" "libposix.fasl"] - ["libtoplevel-6.0.ss" "libtoplevel.fasl"] - )) - -(define primitive? - (lambda (x) - (or (assq x open-coded-primitives) - (memq x public-primitives)))) - -(define open-coded-primitives -;;; these primitives, when found in operator position with the correct -;;; number of arguments, will be open-coded by the generator. If an -;;; incorrect number of args is detected, or if they appear in non-operator -;;; position, then they cannot be open-coded, and the pcb-primitives table -;;; is consulted for a reference of the pcb slot containing the primitive. -;;; If it's not found there, an error is signalled. -;;; -;;; prim-name args - '([$constant-ref 1 value] - [$constant-set! 2 effect] - [$pcb-ref 1 value] - [$pcb-set! 2 effect] - ;;; type predicates - [fixnum? 1 pred] - [immediate? 1 pred] - [boolean? 1 pred] - [char? 1 pred] - [pair? 1 pred] - [symbol? 1 pred] - [vector? 1 pred] - [string? 1 pred] - [procedure? 1 pred] - [null? 1 pred] - [eof-object? 1 pred] - [$unbound-object? 1 pred] - [$forward-ptr? 1 pred] - [not 1 pred] - [eq? 2 pred] - ;;; fixnum primitives - [$fxadd1 1 value] - [$fxsub1 1 value] - [$fx+ 2 value] - [$fx- 2 value] - [$fx* 2 value] - [$fxsll 2 value] - [$fxsra 2 value] - [$fxlogand 2 value] - [$fxlogor 2 value] - [$fxlogxor 2 value] - [$fxlognot 1 value] - [$fxquotient 2 value] - [$fxmodulo 2 value] - ;;; fixnum predicates - [$fxzero? 1 pred] - [$fx= 2 pred] - [$fx< 2 pred] - [$fx<= 2 pred] - [$fx> 2 pred] - [$fx>= 2 pred] - ;;; character predicates - [$char= 2 pred] - [$char< 2 pred] - [$char<= 2 pred] - [$char> 2 pred] - [$char>= 2 pred] - ;;; character conversion - [$fixnum->char 1 value] - [$char->fixnum 1 value] - ;;; lists/pairs - [cons 2 value] - [$car 1 value] - [$cdr 1 value] - [$set-car! 2 effect] - [$set-cdr! 2 effect] - ;;; vectors - [$make-vector 1 value] - [vector any value] - [$vector-length 1 value] - [$vector-ref 2 value] - [$vector-set! 3 effect] - ;;; strings - [$make-string 1 value] - [$string any value] - [$string-length 1 value] - [$string-ref 2 value] - [$string-set! 3 effect] - ;;; symbols - [$make-symbol 1 value] - [$symbol-value 1 value] - [$symbol-string 1 value] - [$symbol-unique-string 1 value] - [$set-symbol-value! 2 effect] - [$set-symbol-string! 2 effect] - [$set-symbol-unique-string! 2 effect] - [$symbol-plist 1 value] - [$set-symbol-plist! 2 effect] - [primitive-ref 1 value] - [primitive-set! 2 effect] - ;;; misc - [eof-object 0 value] - [void 0 value] - [$exit 1 effect] - [$fp-at-base 0 pred] - [$current-frame 0 value] - [$seal-frame-and-call 1 tail] - [$frame->continuation 1 value] - ;;; - ;;; records - ;;; - [$make-record 2 value] - [$record? 1 pred] - [$record-rtd 1 value] - [$record-ref 2 value] - [$record-set! 3 effect] - ;;; - ;;; hash tables - ;;; - [make-hash-table 0 value] - [hash-table? 1 pred] - ;;; - ;;; asm - ;;; - ;[code? 1 pred] - ;[$code-instr-size 1 value] - ;[$code-reloc-size 1 value] - ;[$code-closure-size 1 value] - ;[$code->closure 1 value] - ;[$set-code-byte! 3 effect] - ;[$set-code-word! 3 effect] - ;[$set-code-object! 4 effect] - ;[$set-code-object+offset! 5 effect] - ;[$set-code-object+offset/rel! 5 effect] - ;;; - [$make-call-with-values-procedure 0 value] - [$make-values-procedure 0 value] - [$install-underflow-handler 0 effect] - )) - -(define (primitive-context x) - (cond - [(assq x open-coded-primitives) => caddr] - [else (error 'primitive-context "unknown prim ~s" x)])) - - -;;; primitives table section -(define primitives-table - '(;;; system locations used by the C/Scheme interface - [$apply-nonprocedure-error-handler library] - [$incorrect-args-error-handler library] - [$multiple-values-error library] - [$intern library] - [do-overflow library] - [do-vararg-overflow library] - [do-stack-overflow library] - ;;; type predicates - [fixnum? public] - [immediate? public] - [boolean? public] - [char? public] - [null? public] - [pair? public] - [symbol? public] - [vector? public] - [string? public] - [procedure? public] - [eof-object? public] - [not public] - [eq? public] - [equal? public] - ;;; fixnum primitives - [fxadd1 public] - [fxsub1 public] - [fx+ public] - [fx- public] - [fx* public] - [fxsll public] - [fxsra public] - [fxlogor public] - [fxlogand public] - [fxlogxor public] - [fxlognot public] - [fxquotient public] - [fxremainder public] - [fxmodulo public] - ;;; fixnum predicates - [fxzero? public] - [fx= public] - [fx< public] - [fx<= public] - [fx> public] - [fx>= public] - ;;; characters - [char=? public] - [char? public] - [char>=? public] - [integer->char public] - [char->integer public] - ;;; lists - [cons public] - [car public] - [cdr public] - [caar public] - [cadr public] - [cdar public] - [cddr public] - [caaar public] - [caadr public] - [cadar public] - [caddr public] - [cdaar public] - [cdadr public] - [cddar public] - [cdddr public] - [caaaar public] - [caaadr public] - [caadar public] - [caaddr public] - [cadaar public] - [cadadr public] - [caddar public] - [cadddr public] - [cdaaar public] - [cdaadr public] - [cdadar public] - [cdaddr public] - [cddaar public] - [cddadr public] - [cdddar public] - [cddddr public] - [set-car! public] - [set-cdr! public] - [list public] - [list* ADDME] - [list? public] - [list-ref public] - [length public] - [make-list public] - [reverse public] - [append public] - [list-ref public] - [memq public] - [assq public] - [map public] - [for-each public] - [andmap public] - [ormap public] - ;;; vectors - [make-vector public] - [vector public] - [vector-length public] - [vector-ref public] - [vector-set! public] - [list->vector public] - [vector->list public] - ;;; strings - [make-string public] - [string public] - [string-length public] - [string-ref public] - [string-set! public] - [list->string public] - [string->list public] - [string-append public] - [substring public] - [string=? public] - [fixnum->string public] - ;;; symbols - [gensym public] - [gensym? public] - [symbol->string public] - [gensym->unique-string public] - [gensym-prefix public] - [gensym-count public] - [print-gensym public] - [string->symbol public] - [top-level-value public] - [top-level-bound? public] - [set-top-level-value! public] - [getprop public] - [putprop public] - [remprop public] - [property-list public] - [oblist public] - [uuid public] - ;;; eof - [eof-object public] - [void public] - ;;; control/debugging - [print-error public] - [error public] - [current-error-handler public] - [exit public] - [apply public] - [make-parameter public] - ;;; output - [output-port? public] - [console-output-port public] - [current-output-port public] - [standard-output-port public] - [standard-error-port public] - [open-output-file public] - [open-output-string public] - [with-output-to-file public] - [call-with-output-file public] - [with-input-from-file public] - [call-with-input-file public] - [get-output-string public] - [close-output-port public] - [flush-output-port public] - [write-char public] - [output-port-name public] - [newline public] - ;;; input - [input-port? public] - [standard-input-port public] - [console-input-port public] - [current-input-port public] - [open-input-file public] - [close-input-port public] - [reset-input-port! public] - [read-char public] - [peek-char public] - [unread-char public] - [input-port-name public] - ;;; writing/printing - [write public] - [display public] - [printf public] - [fprintf public] - [format public] - [read-token public] - [read public] - ;;; evaluation - [primitive? public] - [expand public] - [core-expand public] - [current-expand public] - [interpret public] - [eval public] - [current-eval public] - [load public] - [new-cafe public] - [collect public] - [call/cc public] - [call/cf library] - [dynamic-wind public] - [values public] - [call-with-values public] - [make-traced-procedure library] - [trace-symbol! library] - [untrace-symbol! library] - ;;; record - [$base-rtd library] - [record? public] - [record-rtd public] - [record-name public] - [record-printer public] - [record-length public] - [record-ref public] - [record-set! public] - ;;; record rtds - [make-record-type public] - [record-constructor public] - [record-predicate public] - [record-field-accessor public] - [record-field-mutator public] - ;;; asm - [make-code public] - [code? public] - [make-code-executable! public] - [code-instr-size public] - [code-reloc-size public] - [code-closure-size public] - [set-code-byte! public] - [set-code-word! public] - [set-code-object! public] - [set-code-foreign-object! public] - [set-code-object+offset! public] - [set-code-object+offset/rel! public] - [set-code-object/reloc/relative! public] - [code->closure public] - [list*->code* library] - ;;; - ;;; POSIX - ;;; - [fork public] - [posix-fork public] - [system public] - [$debug public] - [$underflow-misaligned-error public] - )) - -(define (primitive? x) - (cond - [(assq x primitives-table) #t] - [(assq x open-coded-primitives) #t] - [else #f])) - -(define (open-codeable? x) - (cond - [(assq x open-coded-primitives) #t] - [(assq x primitives-table) #f] - [else (error 'open-codeable "invalid primitive ~s" x)])) - -(define (open-coded-primitive-args x) - (cond - [(assq x open-coded-primitives) => cadr] - [else (error 'open-coded-primitive-args "invalid ~s" x)])) - -;;; end of primitives table section - - -(define-record constant (value)) -(define-record code-loc (label)) -(define-record foreign-label (label)) -(define-record var (name)) -(define-record cp-var (idx)) -(define-record frame-var (idx)) -(define-record new-frame (base-idx size body)) -(define-record save-cp (loc)) -(define-record eval-cp (check body)) -(define-record return (value)) -(define-record call-cp - (call-convention rp-convention base-idx arg-count live-mask)) -(define-record primcall (op arg*)) -(define-record primref (name)) -(define-record conditional (test conseq altern)) -(define-record bind (lhs* rhs* body)) -(define-record seq (e0 e1)) -(define-record function (arg* proper body)) -(define-record clambda-case (arg* proper body)) -(define-record clambda (cases)) -(define-record clambda-code (label cases free)) - -(define-record closure (code free*)) -(define-record funcall (op rand*)) -(define-record appcall (op rand*)) -(define-record forcall (op rand*)) -(define-record code-rec (arg* proper free* body)) - -(define-record codes (list body)) -(define-record assign (lhs rhs)) - -(define unique-var - (let ([counter 0]) - (lambda (x) - (let ([g (gensym (format "~a:~a" x counter))]) - (set! counter (fxadd1 counter)) - (make-var g))))) - -(define (make-bind^ lhs* rhs* body) - (if (null? lhs*) - body - (make-bind lhs* rhs* body))) - -(define (recordize x) - (define (gen-fml* fml*) - (cond - [(pair? fml*) - (cons (unique-var (car fml*)) - (gen-fml* (cdr fml*)))] - [(symbol? fml*) - (unique-var fml*)] - [else '()])) - (define (properize fml*) - (cond - [(pair? fml*) - (cons (car fml*) (properize (cdr fml*)))] - [(null? fml*) '()] - [else (list fml*)])) - (define (extend-env fml* nfml* env) - (cons (cons fml* nfml*) env)) - (define (quoted-sym x) - (if (and (list? x) - (fx= (length x) 2) - (eq? 'quote (car x)) - (symbol? (cadr x))) - (cadr x) - (error 'quoted-sym "not a quoted symbol ~s" x))) - (define (quoted-string x) - (if (and (list? x) - (fx= (length x) 2) - (eq? 'quote (car x)) - (string? (cadr x))) - (cadr x) - (error 'quoted-string "not a quoted string ~s" x))) - (define (lookup^ x lhs* rhs*) - (cond - [(pair? lhs*) - (if (eq? x (car lhs*)) - (car rhs*) - (lookup^ x (cdr lhs*) (cdr rhs*)))] - [(eq? x lhs*) rhs*] - [else #f])) - (define (lookup x env) - (cond - [(pair? env) - (or (lookup^ x (caar env) (cdar env)) - (lookup x (cdr env)))] - [else #f])) - (define (E x env) - (cond - [(pair? x) - (case (car x) - [(quote) (make-constant (cadr x))] - [(if) - (make-conditional - (E (cadr x) env) - (E (caddr x) env) - (E (cadddr x) env))] - [(set!) - (let ([lhs (cadr x)] [rhs (caddr x)]) - (make-assign - (or (lookup lhs env) - (error 'recordize "invalid assignment ~s" x)) - (E rhs env)))] - [(begin) - (let f ([a (cadr x)] [d (cddr x)]) - (cond - [(null? d) (E a env)] - [else - (make-seq - (E a env) - (f (car d) (cdr d)))]))] - [(case-lambda) - (let ([cls* - (map - (lambda (cls) - (let ([fml* (car cls)] [body (cadr cls)]) - (let ([nfml* (gen-fml* fml*)]) - (let ([body (E body (extend-env fml* nfml* env))]) - (make-clambda-case - (properize nfml*) - (list? fml*) - body))))) - (cdr x))]) - (make-clambda cls*))] - [(foreign-call) - (let ([name (quoted-string (cadr x))] [arg* (cddr x)]) - (make-forcall name - (map (lambda (x) (E x env)) arg*)))] - [(|#primitive|) - (let ([var (cadr x)]) - (if (primitive? var) - (make-primref var) - (error 'recordize "invalid primitive ~s" var)))] - [(top-level-value) - (let ([var (quoted-sym (cadr x))]) - (if (primitive? var) - (make-primref var) - (error 'recordize "invalid top-level var ~s" var)))] - [(memv) - (make-funcall - (make-primref 'memq) - (map (lambda (x) (E x env)) (cdr x)))] - [($apply) - (let ([proc (cadr x)] [arg* (cddr x)]) - (make-appcall - (E proc env) - (map (lambda (x) (E x env)) arg*)))] - [(void) - (make-constant (void))] - [else - (make-funcall - (E (car x) env) - (map (lambda (x) (E x env)) (cdr x)))])] - [(symbol? x) - (or (lookup x env) - (error 'recordize "invalid reference in ~s" x))] - [else (error 'recordize "invalid expression ~s" x)])) - (E x '())) - - -(define (unparse x) - (define (E-args proper x) - (if proper - (map E x) - (let f ([a (car x)] [d (cdr x)]) - (cond - [(null? d) (E a)] - [else (cons (E a) (f (car d) (cdr d)))])))) - (define (E x) - (record-case x - [(constant c) `(quote ,c)] - [(code-loc x) `(code-loc ,x)] - [(var x) (string->symbol (format "v:~a" x))] - [(primref x) x] - [(conditional test conseq altern) - `(if ,(E test) ,(E conseq) ,(E altern))] - [(primcall op arg*) `(,op . ,(map E arg*))] - [(bind lhs* rhs* body) - `(let ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*) - ,(E body))] - [(seq e0 e1) `(begin ,(E e0) ,(E e1))] - [(function args proper body) - `(lambda ,(E-args proper args) ,(E body))] - [(clambda-case args proper body) - `(clambda-case ,(E-args proper args) ,(E body))] - [(clambda cls*) - `(case-lambda . ,(map E cls*))] - [(clambda-code label clauses free) - `(code ,label . ,(map E clauses))] - [(closure code free*) - `(closure ,(E code) ,(map E free*))] - [(code-rec arg* proper free* body) - `(code-rec [arg: ,(E-args proper arg*)] - [free: ,(map E free*)] - ,(E body))] - [(codes list body) - `(codes ,(map E list) - ,(E body))] - [(funcall rator rand*) `(funcall ,(E rator) . ,(map E rand*))] - [(appcall rator rand*) `(appcall ,(E rator) . ,(map E rand*))] - [(forcall rator rand*) `(foreign-call ,rator . ,(map E rand*))] - [(assign lhs rhs) `(set! ,(E lhs) ,(E rhs))] - [(return x) `(return ,(E x))] - [(new-frame base-idx size body) - `(new-frame [base: ,base-idx] - [size: ,size] - ,(E body))] - [(frame-var idx) - (string->symbol (format "fv.~a" idx))] - [(cp-var idx) - (string->symbol (format "cp.~a" idx))] - [(save-cp expr) - `(save-cp ,(E expr))] - [(eval-cp check body) - `(eval-cp ,check ,(E body))] - [(call-cp call-convention rp-convention base-idx arg-count live-mask) - `(call-cp [conv: ,call-convention] - [rpconv: ,rp-convention] - [base-idx: ,base-idx] - [arg-count: ,arg-count] - [live-mask: ,live-mask])] - [(foreign-label x) `(foreign-label ,x)] - [else (error 'unparse "invalid record ~s" x)])) - (E x)) - -(define (optimize-direct-calls x) - (define who 'optimize-direct-calls) - (define (make-conses ls) - (cond - [(null? ls) (make-constant '())] - [else - (make-primcall 'cons - (list (car ls) (make-conses (cdr ls))))])) - (define (properize lhs* rhs*) - (cond - [(null? lhs*) (error who "improper improper")] - [(null? (cdr lhs*)) - (list (make-conses rhs*))] - [else (cons (car rhs*) (properize (cdr lhs*) (cdr rhs*)))])) - (define (inline-case cls rand*) - (record-case cls - [(clambda-case fml* proper body) - (if proper - (and (fx= (length fml*) (length rand*)) - (make-bind fml* rand* body)) - (and (fx<= (length fml*) (length rand*)) - (make-bind fml* (properize fml* rand*) body)))])) - (define (try-inline cls* rand* default) - (cond - [(null? cls*) default] - [(inline-case (car cls*) rand*)] - [else (try-inline (cdr cls*) rand* default)])) - (define (inline rator rand*) - (record-case rator - [(clambda cls*) - (try-inline cls* rand* - (make-funcall rator rand*))] -; [(function fml* proper body) -; (cond -; [proper -; (if (fx= (length fml*) (length rand*)) -; (make-bind fml* rand* body) -; (begin -; (warning 'compile "possible application error in ~s" -; (unparse (make-funcall rator rand*))) -; (make-funcall rator rand*)))] -; [else -; (if (fx<= (length fml*) (length rand*)) -; (make-bind fml* (properize fml* rand*) body) -; (begin -; (warning 'compile "possible application error in ~s" -; (unparse (make-funcall rator rand*))) -; (make-funcall rator rand*)))])] - [else (make-funcall rator rand*)])) - (define (Expr x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (make-conditional - (Expr test) - (Expr conseq) - (Expr altern))] - [(seq e0 e1) - (make-seq (Expr e0) (Expr e1))] - [(function fml* proper body) - (make-function fml* proper (Expr body))] - [(clambda cls*) - (make-clambda - (map (lambda (x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (Expr body))])) - cls*))] - [(primcall rator rand*) - (make-primcall rator (map Expr rand*))] - [(funcall rator rand*) - (inline (Expr rator) (map Expr rand*))] - [(appcall rator rand*) - (make-appcall (Expr rator) (map Expr rand*))] - [(forcall rator rand*) - (make-forcall rator (map Expr rand*))] - [(assign lhs rhs) - (make-assign lhs (Expr rhs))] - [else (error who "invalid expression ~s" (unparse x))])) - (Expr x)) - - - -(define (uncover-assigned x) - (define who 'uncover-assigned) - (define (Expr* x*) - (cond - [(null? x*) '()] - [else (union (Expr (car x*)) (Expr* (cdr x*)))])) - (define (Expr x) - (record-case x - [(constant) '()] - [(var) '()] - [(primref) '()] - [(bind lhs* rhs* body) - (union (Expr body) (Expr* rhs*))] - [(conditional test conseq altern) - (union (Expr test) (union (Expr conseq) (Expr altern)))] - [(seq e0 e1) (union (Expr e0) (Expr e1))] - [(clambda cls*) - (Expr* (map clambda-case-body cls*))] - [(function fml* proper body) (Expr body)] - [(primcall rator rand*) (Expr* rand*)] - [(funcall rator rand*) - (union (Expr rator) (Expr* rand*))] - [(appcall rator rand*) - (union (Expr rator) (Expr* rand*))] - [(forcall rator rand*) (Expr* rand*)] - [(assign lhs rhs) - (union (singleton lhs) (Expr rhs))] - [else (error who "invalid expression ~s" (unparse x))])) - (Expr x)) - -(define (rewrite-assignments assigned x) - (define who 'rewrite-assignments) - (define (fix lhs*) - (cond - [(null? lhs*) (values '() '() '())] - [else - (let ([x (car lhs*)]) - (let-values ([(lhs* a-lhs* a-rhs*) (fix (cdr lhs*))]) - (cond - [(memq x assigned) - (let ([t (make-var 'assignment-tmp)]) - (values (cons t lhs*) (cons x a-lhs*) (cons t a-rhs*)))] - [else - (values (cons x lhs*) a-lhs* a-rhs*)])))])) - (define (bind-assigned lhs* rhs* body) - (cond - [(null? lhs*) body] - [else - (make-bind lhs* - (map (lambda (rhs) (make-primcall 'vector (list rhs))) rhs*) - body)])) - (define (Expr x) - (record-case x - [(constant) x] - [(var) - (cond - [(memq x assigned) - (make-primcall '$vector-ref (list x (make-constant 0)))] - [else x])] - [(primref) x] - [(bind lhs* rhs* body) - (let-values ([(lhs* a-lhs* a-rhs*) (fix lhs*)]) - (make-bind lhs* (map Expr rhs*) - (bind-assigned a-lhs* a-rhs* (Expr body))))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (make-seq (Expr e0) (Expr e1))] - [(function fml* proper body) - (let-values ([(fml* a-lhs* a-rhs*) (fix fml*)]) - (make-function fml* proper - (bind-assigned a-lhs* a-rhs* (Expr body))))] - [(clambda cls*) - (make-clambda - (map (lambda (cls) - (record-case cls - [(clambda-case fml* proper body) - (let-values ([(fml* a-lhs* a-rhs*) (fix fml*)]) - (make-clambda-case fml* proper - (bind-assigned a-lhs* a-rhs* (Expr body))))])) - cls*))] - [(primcall op rand*) - (make-primcall op (map Expr rand*))] - [(forcall op rand*) - (make-forcall op (map Expr rand*))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(appcall rator rand*) - (make-appcall (Expr rator) (map Expr rand*))] - [(assign lhs rhs) - (unless (memq lhs assigned) - (error 'rewrite-assignments "not assigned ~s in ~s" lhs x)) - (make-primcall '$vector-set! (list lhs (make-constant 0) (Expr rhs)))] - [else (error who "invalid expression ~s" (unparse x))])) - (Expr x)) - - -(define (remove-assignments x) - (let ([assigned (uncover-assigned x)]) - (rewrite-assignments assigned x))) - - -(define (convert-closures prog) - (define who 'convert-closures) - (define (Expr* x*) - (cond - [(null? x*) (values '() '())] - [else - (let-values ([(a a-free) (Expr (car x*))] - [(d d-free) (Expr* (cdr x*))]) - (values (cons a d) (union a-free d-free)))])) - (define (Expr ex) - (record-case ex - [(constant) (values ex '())] - [(var) (values ex (singleton ex))] - [(primref) (values ex '())] - [(bind lhs* rhs* body) - (let-values ([(rhs* rhs-free) (Expr* rhs*)] - [(body body-free) (Expr body)]) - (values (make-bind lhs* rhs* body) - (union rhs-free (difference body-free lhs*))))] - [(conditional test conseq altern) - (let-values ([(test test-free) (Expr test)] - [(conseq conseq-free) (Expr conseq)] - [(altern altern-free) (Expr altern)]) - (values (make-conditional test conseq altern) - (union test-free (union conseq-free altern-free))))] - [(seq e0 e1) - (let-values ([(e0 e0-free) (Expr e0)] - [(e1 e1-free) (Expr e1)]) - (values (make-seq e0 e1) (union e0-free e1-free)))] - [(function fml* proper body) - (let-values ([(body body-free) (Expr body)]) - (let ([free (difference body-free fml*)]) - (values (make-closure (make-code-rec fml* proper free body) free) - free)))] - [(clambda cls*) - (let-values ([(cls* free) - (let f ([cls* cls*]) - (cond - [(null? cls*) (values '() '())] - [else - (record-case (car cls*) - [(clambda-case fml* proper body) - (let-values ([(body body-free) (Expr body)] - [(cls* cls*-free) (f (cdr cls*))]) - (values - (cons (make-clambda-case fml* proper body) - cls*) - (union (difference body-free fml*) - cls*-free)))])]))]) - (values (make-closure (make-clambda-code (gensym) cls* free) free) - free))] - [(primcall op rand*) - (let-values ([(rand* rand*-free) (Expr* rand*)]) - (values (make-primcall op rand*) rand*-free))] - [(forcall op rand*) - (let-values ([(rand* rand*-free) (Expr* rand*)]) - (values (make-forcall op rand*) rand*-free))] - [(funcall rator rand*) - (let-values ([(rator rat-free) (Expr rator)] - [(rand* rand*-free) (Expr* rand*)]) - (values (make-funcall rator rand*) - (union rat-free rand*-free)))] - [(appcall rator rand*) - (let-values ([(rator rat-free) (Expr rator)] - [(rand* rand*-free) (Expr* rand*)]) - (values (make-appcall rator rand*) - (union rat-free rand*-free)))] - [else (error who "invalid expression ~s" (unparse ex))])) - (let-values ([(prog free) (Expr prog)]) - (unless (null? free) - (error 'convert-closures "free vars ~s encountered in ~a" - free (unparse prog))) - prog)) - - -(define (lift-codes x) - (define who 'lift-codes) - (define all-codes '()) - (define (do-code x) - (record-case x - [(clambda-code label cls* free) - (let ([cls* (map - (lambda (x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (E body))])) - cls*)]) - (let ([g (make-code-loc label)]) - (set! all-codes - (cons (make-clambda-code label cls* free) all-codes)) - g))])) - (define (E x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(bind lhs* rhs* body) - (make-bind lhs* (map E rhs*) (E body))] - [(conditional test conseq altern) - (make-conditional (E test) (E conseq) (E altern))] - [(seq e0 e1) (make-seq (E e0) (E e1))] - [(closure c free) (make-closure (do-code c) free)] - [(primcall op rand*) (make-primcall op (map E rand*))] - [(forcall op rand*) (make-forcall op (map E rand*))] - [(funcall rator rand*) (make-funcall (E rator) (map E rand*))] - [(appcall rator rand*) (make-appcall (E rator) (map E rand*))] - [else (error who "invalid expression ~s" (unparse x))])) - (let ([x (E x)]) - (make-codes all-codes x))) - - - - -(define (syntactically-valid? op rand*) - (define (valid-arg-count? op rand*) - (let ([n (open-coded-primitive-args op)] [m (length rand*)]) - (cond - [(eq? n 'any) #t] - [(eq? n 'no-code) - (error 'syntactically-valid - "should not primcall non codable prim ~s" op)] - [(fixnum? n) - (cond - [(fx= n m) #t] - [else - (error 'compile - "Possible incorrect number of args in ~s" - (cons op (map unparse rand*))) - #f])] - [else (error 'do-primcall "BUG: what ~s" n)]))) - (define (check op pred?) - (lambda (arg) - (record-case arg - [(constant c) - (cond - [(pred? c) #t] - [else - (error 'compile "Possible argument error to primitive ~s" op) - #f])] - [(primref) - (cond - [(pred? (lambda (x) x)) #t] - [else - (error 'compile "Possible argument error to primitive ~s" op) - #f])] - [else #t]))) - (define (nonnegative-fixnum? n) - (and (fixnum? n) (fx>= n 0))) - (define (byte? n) - (and (fixnum? n) (fx<= 0 n) (fx<= n 127))) - (define (valid-arg-types? op rand*) - (case op - [(fixnum? immediate? boolean? char? vector? string? procedure? - null? pair? not cons eq? vector symbol? error eof-object eof-object? - void $unbound-object? code? hash-table? $forward-ptr?) - '#t] - [($fxadd1 $fxsub1 $fxzero? $fxlognot $fxlogor $fxlogand $fx+ $fx- $fx* - $fx= $fx< $fx<= $fx> $fx>= $fxquotient $fxmodulo $fxsll $fxsra $fxlogxor $exit) - (andmap (check op fixnum?) rand*)] - [($fixnum->char) - (andmap (check op byte?) rand*)] - [($char->fixnum $char= $char< $char<= $char> $char>= $string) - (andmap (check op char?) rand*)] - [($make-vector $make-string) - (andmap (check op nonnegative-fixnum?) rand*)] - [($car $cdr) - (andmap (check op pair?) rand*)] - [($vector-length) - (andmap (check op vector?) rand*)] - [($string-length) - (andmap (check op string?) rand*)] - [($set-car! $set-cdr!) - ((check op pair?) (car rand*))] - [($vector-ref $vector-set!) - (and ((check op vector?) (car rand*)) - ((check op nonnegative-fixnum?) (cadr rand*)))] - [($string-ref $string-set! - $string-ref-16+0 $string-ref-16+1 $string-ref-8+0 $string-ref-8+2) - (and ((check op string?) (car rand*)) - ((check op nonnegative-fixnum?) (cadr rand*)))] - [($symbol-string $symbol-unique-string) - (andmap (check op symbol?) rand*)] - [($constant-ref $set-constant! $intern $pcb-set! $pcb-ref $make-symbol - $symbol-value $set-symbol-value! $symbol-plist $set-symbol-plist! - $set-symbol-system-value! $set-symbol-system-value! - $set-symbol-unique-string! - $set-symbol-string! - $seal-frame-and-call $frame->continuation $code->closure - $code-instr-size $code-reloc-size $code-closure-size - $set-code-byte! $set-code-word! - $set-code-object! $set-code-object+offset! $set-code-object+offset/rel! - $make-record $record? $record-rtd $record-ref $record-set! - primitive-set! primitive-ref) - #t] - [else (error 'valid-arg-types? "unhandled op ~s" op)])) - (and (valid-arg-count? op rand*) - (or (null? rand*) - (valid-arg-types? op rand*)))) - - -;;; the output of simplify-operands differs from the input in that the -;;; operands to primcalls are all simple (variables, primrefs, or constants). -;;; funcalls to open-codable primrefs whos arguments are "ok" are converted to -;;; primcalls. - -(define (introduce-primcalls x) - (define who 'introduce-primcalls) - (define (simple? x) - (or (constant? x) (var? x) (primref? x))) - (define (Expr x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(closure) x] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (make-seq (Expr e0) (Expr e1))] - [(primcall op arg*) - (case op - ;[(values) - ; (if (fx= (length arg*) 1) - ; (Expr (car arg*)) - ; (begin - ; (warning 'compile "possible incorrect number of values") - ; (make-funcall (make-primref 'values) (map Expr arg*))))] - [else - (make-primcall op (map Expr arg*))])] - [(forcall op arg*) - (make-forcall op (map Expr arg*))] - [(funcall rator rand*) - (cond - [(and (primref? rator) - (open-codeable? (primref-name rator)) - (syntactically-valid? (primref-name rator) rand*)) - (Expr (make-primcall (primref-name rator) rand*))] - [else - (make-funcall (Expr rator) (map Expr rand*))])] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (Tail x) - (record-case x - [(constant) (make-return x)] - [(var) (make-return x)] - [(primref) (make-return x)] - [(closure) (make-return x)] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Tail body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Tail conseq) (Tail altern))] - [(seq e0 e1) (make-seq (Expr e0) (Tail e1))] - [(primcall op arg*) - (case op - ;[(values) - ; (if (fx= (length arg*) 1) - ; (make-return (Expr (car arg*))) - ; (make-return* (map Expr arg*)))] - [else - (make-return (make-primcall op (map Expr arg*)))])] - [(forcall op arg*) - (make-return (make-forcall op (map Expr arg*)))] - [(funcall rator rand*) - (cond - [(and (primref? rator) - (open-codeable? (primref-name rator)) - (syntactically-valid? (primref-name rator) rand*)) - (Tail (make-primcall (primref-name rator) rand*))] - [else - (make-funcall (Expr rator) (map Expr rand*))])] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (CaseExpr x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (Tail body))])) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (make-clambda-code L (map CaseExpr cases) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) (Tail body))])) - (CodesExpr x)) - - -(define (simplify-operands x) - (define who 'simplify-operands) - (define (simple? x) - (or (constant? x) (var? x) (primref? x))) - (define (simplify arg lhs* rhs* k) - (if (simple? arg) - (k arg lhs* rhs*) - (let ([v (unique-var 'tmp)]) - (k v (cons v lhs*) (cons (Expr arg) rhs*))))) - (define (simplify* arg* lhs* rhs* k) - (cond - [(null? arg*) (k '() lhs* rhs*)] - [else - (simplify (car arg*) lhs* rhs* - (lambda (a lhs* rhs*) - (simplify* (cdr arg*) lhs* rhs* - (lambda (d lhs* rhs*) - (k (cons a d) lhs* rhs*)))))])) - (define (Expr x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(closure) x] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (make-seq (Expr e0) (Expr e1))] - [(primcall op arg*) - (simplify* arg* '() '() - (lambda (arg* lhs* rhs*) - (make-bind^ lhs* rhs* - (make-primcall op arg*))))] - [(forcall op arg*) - (make-forcall op (map Expr arg*))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (Tail x) - (record-case x - [(return v) (make-return (Expr v))] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Tail body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Tail conseq) (Tail altern))] - [(seq e0 e1) (make-seq (Expr e0) (Tail e1))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (CaseExpr x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (Tail body))])) - (define (CodeExpr x) - (record-case x - [(clambda-code L clauses free) - (make-clambda-code L (map CaseExpr clauses) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) (Tail body))])) - (CodesExpr x)) - - -(define (insert-stack-overflow-checks x) - (define who 'insert-stack-overflow-checks) - (define (insert-check body) - (make-seq - (make-conditional - (make-primcall '$fp-overflow '()) - (make-funcall (make-primref 'do-stack-overflow) '()) - (make-primcall 'void '())) - body)) - (define (Expr x) - (record-case x - [(constant) #f] - [(var) #f] - [(primref) #f] - [(closure code free*) #f] - [(bind lhs* rhs* body) - (or (ormap Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (or (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (or (Expr e0) (Expr e1))] - [(primcall op arg*) (ormap Expr arg*)] - [(forcall op arg*) (ormap Expr arg*)] - [(funcall rator arg*) #t] - [(appcall rator arg*) #t] - [else (error who "invalid expression ~s" (unparse x))])) - (define (Tail x) - (record-case x - [(return v) (Expr v)] - [(bind lhs* rhs* body) - (or (ormap Expr rhs*) (Tail body))] - [(conditional test conseq altern) - (or (Expr test) (Tail conseq) (Tail altern))] - [(seq e0 e1) (or (Expr e0) (Tail e1))] - [(funcall rator arg*) (or (Expr rator) (ormap Expr arg*))] - [(appcall rator arg*) (or (Expr rator) (ormap Expr arg*))] - [else (error who "invalid tail expression ~s" (unparse x))])) - (define (CaseExpr x) - (record-case x - [(clambda-case fml* proper body) - (if (Tail body) - (make-clambda-case fml* proper (insert-check body)) - x)])) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (make-clambda-code L (map CaseExpr cases) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) - (if (Tail body) - (insert-check body) - body))])) - (CodesExpr x)) - - -(define (insert-allocation-checks x) - (define who 'insert-allocation-checks) - (define (check-bytes n var body) - (make-seq - (make-conditional - (make-primcall '$ap-check-bytes - (list (make-constant n) var)) - (make-funcall (make-primref 'do-overflow) - (list - (make-primcall '$fx+ - (list (make-constant n) var)))) - (make-primcall 'void '())) - body)) - (define (check-words n var body) - (make-seq - (make-conditional - (make-primcall '$ap-check-words - (list (make-constant n) var)) - (make-funcall (make-primref 'do-overflow-words) - (list - (make-primcall '$fx+ - (list (make-constant n) var)))) - (make-primcall 'void '())) - body)) - (define (check-const n body) - (make-seq - (make-conditional - (make-primcall '$ap-check-const - (list (make-constant n))) - (make-funcall (make-primref 'do-overflow) - (list (make-constant n))) - (make-primcall 'void '())) - body)) - (define (Expr x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(closure code free*) - (check-const (fx+ disp-closure-data (fx* (length free*) wordsize)) x)] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (make-seq (Expr e0) (Expr e1))] - [(primcall op arg*) - (let ([x (make-primcall op (map Expr arg*))]) - (case op - [(cons) (check-const pair-size x)] - [($make-symbol) (check-const symbol-size x)] - [(make-hash-table) (check-const hash-table-size x)] - [($frame->continuation $code->closure) - (check-const (fx+ disp-closure-data (fx* (length arg*) wordsize)) x)] - [($make-string) - (record-case (car arg*) - [(constant i) - (check-const (fx+ i (fx+ disp-string-data 1)) x)] - [else - (check-bytes (fxadd1 disp-string-data) (car arg*) x)])] - [($string) - (check-const (fx+ (length arg*) (fx+ disp-string-data 1)) x)] - [($make-vector) - (record-case (car arg*) - [(constant i) - (check-const (fx+ (fx* i wordsize) disp-vector-data) x)] - [else - (check-words (fxadd1 disp-vector-data) (car arg*) x)])] - [($make-record) - (record-case (cadr arg*) - [(constant i) - (check-const (fx+ (fx* i wordsize) disp-record-data) x)] - [else - (check-words (fxadd1 disp-record-data) (cadr arg*) x)])] - [(vector) - (check-const (fx+ (fx* (length arg*) wordsize) disp-vector-data) x)] - [else x]))] - [(forcall op arg*) - (make-forcall op (map Expr arg*))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (Tail x) - (record-case x - [(return v) (make-return (Expr v))] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Tail body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Tail conseq) (Tail altern))] - [(seq e0 e1) (make-seq (Expr e0) (Tail e1))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (CaseExpr x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (Tail body))])) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (make-clambda-code L (map CaseExpr cases) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) (Tail body))])) - (CodesExpr x)) - - -(define (remove-local-variables x) - (define who 'remove-local-variables) - (define (simple* x* r) - (map (lambda (x) - (cond - [(assq x r) => cdr] - [else - (when (var? x) (error who "unbound var ~s" x)) - x])) - x*)) - (define (env->mask r sz) - (let ([s (make-vector (fxsra (fx+ sz 7) 3) 0)]) - (for-each - (lambda (idx) - (let ([q (fxsra idx 3)] - [r (fxlogand idx 7)]) - (vector-set! s q - (fxlogor (vector-ref s q) (fxsll 1 r))))) - r) - s)) - (define (do-new-frame op rand* si r call-convention rp-convention orig-live) - (make-new-frame (fxadd1 si) (fx+ (length rand*) 2) - (let f ([r* rand*] [nsi (fx+ si 2)] [live orig-live]) - (cond - [(null? r*) - (make-seq - (make-seq - (make-save-cp (make-frame-var si)) - (case call-convention - [(normal apply) - (make-eval-cp #t (Expr op nsi r (cons si live)))] - [(foreign) - (make-eval-cp #f (make-foreign-label op))] - [else (error who "invalid convention ~s" convention)])) - (make-call-cp call-convention - rp-convention - (fxadd1 si) ; frame size - (length rand*) ; argc - (env->mask (cons si orig-live) ; cp and everything before it - (fxadd1 si))))] ; mask-size ~~ frame size - [else - (make-seq - (make-assign (make-frame-var nsi) - (Expr (car r*) nsi r live)) - (f (cdr r*) (fxadd1 nsi) (cons nsi live)))])))) - (define (nop) (make-primcall 'void '())) - (define (do-bind lhs* rhs* body si r live k) - (let f ([lhs* lhs*] [rhs* rhs*] [si si] [nr r] [live live]) - (cond - [(null? lhs*) (k body si nr live)] - [else - (let ([v (make-frame-var si)]) - (make-seq - (make-assign v (Expr (car rhs*) si r live)) - (f (cdr lhs*) (cdr rhs*) (fxadd1 si) - (cons (cons (car lhs*) v) nr) - (cons si live))))]))) - (define (Tail x si r live) - (record-case x - [(return v) (make-return (Expr v si r live))] - [(bind lhs* rhs* body) - (do-bind lhs* rhs* body si r live Tail)] - [(conditional test conseq altern) - (make-conditional - (Expr test si r live) - (Tail conseq si r live) - (Tail altern si r live))] - [(seq e0 e1) (make-seq (Effect e0 si r live) (Tail e1 si r live))] - [(primcall op arg*) - (case op -; [(values) (make-primcall op (simple* arg* r))] - [else (make-return (make-primcall op (simple* arg* r)))])] - [(funcall op rand*) - (do-new-frame op rand* si r 'normal 'tail live)] - [(appcall op rand*) - (do-new-frame op rand* si r 'apply 'tail live)] - [else (error who "invalid expression ~s" (unparse x))])) - (define (Effect x si r live) - (record-case x - [(constant) (nop)] - [(var) (nop)] - [(primref) (nop)] - [(closure code free*) (nop)] - [(bind lhs* rhs* body) - (do-bind lhs* rhs* body si r live Effect)] - [(conditional test conseq altern) - (make-conditional - (Expr test si r live) - (Effect conseq si r live) - (Effect altern si r live))] - [(seq e0 e1) (make-seq (Effect e0 si r live) (Effect e1 si r live))] - [(primcall op arg*) - (make-primcall op (simple* arg* r))] - [(forcall op rand*) - (do-new-frame op rand* si r 'foreign 'effect live)] - [(funcall op rand*) - (do-new-frame op rand* si r 'normal 'effect live)] - [(appcall op rand*) - (do-new-frame op rand* si r 'apply 'effect live)] - [else (error who "invalid effect expression ~s" (unparse x))])) - (define (Expr x si r live) - (record-case x - [(constant) x] - [(var) - (cond - [(assq x r) => cdr] - [else (error who "unbound var ~s" x)])] - [(primref) x] - [(closure code free*) - (make-closure code (simple* free* r))] - [(bind lhs* rhs* body) - (do-bind lhs* rhs* body si r live Expr)] - [(conditional test conseq altern) - (make-conditional - (Expr test si r live) - (Expr conseq si r live) - (Expr altern si r live))] - [(seq e0 e1) (make-seq (Effect e0 si r live) (Expr e1 si r live))] - [(primcall op arg*) - (make-primcall op (simple* arg* r))] - [(forcall op rand*) - (do-new-frame op rand* si r 'foreign 'value live)] - [(funcall op rand*) - (do-new-frame op rand* si r 'normal 'value live)] - [(appcall op rand*) - (do-new-frame op rand* si r 'apply 'value live)] - [else (error who "invalid expression ~s" (unparse x))])) - (define (bind-fml* fml* r) - (let f ([si 1] [fml* fml*]) - (cond - [(null? fml*) (values '() si r '())] - [else - (let-values ([(nfml* nsi r live) (f (fxadd1 si) (cdr fml*))]) - (let ([v (make-frame-var si)]) - (values (cons v nfml*) - nsi - (cons (cons (car fml*) v) r) - (cons si live))))]))) - (define (bind-free* free*) - (let f ([free* free*] [idx 0] [r '()]) - (cond - [(null? free*) r] - [else - (f (cdr free*) (fxadd1 idx) - (cons (cons (car free*) (make-cp-var idx)) r))]))) - (define CaseExpr - (lambda (r) - (lambda (x) - (record-case x - [(clambda-case fml* proper body) - (let-values ([(fml* si r live) (bind-fml* fml* r)]) - (make-clambda-case fml* proper (Tail body si r live)))])))) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (let ([r (bind-free* free)]) - (make-clambda-code L (map (CaseExpr r) cases) free))])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) - (Tail body 1 '() '()))])) - (CodesExpr x)) - - -(begin - (define fx-shift 2) - (define fx-mask #x03) - (define fx-tag 0) - (define bool-f #x2F) - (define bool-t #x3F) - (define bool-mask #xEF) - (define bool-tag bool-f) - (define bool-shift 4) - (define nil #x4F) - (define eof #x5F) ; double check - (define unbound #x6F) ; double check - (define void-object #x7F) ; double check - (define wordsize 4) - (define char-shift 8) - (define char-tag #x0F) - (define char-mask #xFF) - (define pair-mask 7) - (define pair-tag 1) - (define disp-car 0) - (define disp-cdr 4) - (define pair-size 8) - - (define symbol-mask 7) - (define symbol-tag 2) - (define disp-symbol-string 0) - (define disp-symbol-unique-string 4) - (define disp-symbol-value 8) - (define disp-symbol-plist 12) - (define disp-symbol-system-value 16) - (define disp-symbol-system-plist 20) - (define symbol-size 24) - (define vector-tag 5) - (define vector-mask 7) - (define disp-vector-length 0) - (define disp-vector-data 4) - (define string-mask 7) - (define string-tag 6) - (define disp-string-length 0) - (define disp-string-data 4) - (define closure-mask 7) - (define closure-tag 3) - (define disp-closure-data 4) - (define disp-closure-code 0) - (define continuation-size 16) - (define continuation-tag #x1F) - (define disp-continuation-top 4) - (define disp-continuation-size 8) - (define disp-continuation-next 12) - (define code-tag #x2F) - (define disp-code-instrsize 4) - (define disp-code-relocsize 8) - (define disp-code-closuresize 12) - (define disp-code-data 16) - (define record-ptag vector-tag) - (define record-pmask vector-mask) - (define disp-record-rtd 0) - (define disp-record-data 4) - (define hash-table-tag #x3F) - (define disp-htable-count 4) - (define disp-htable-size 8) - (define disp-htable-mem 12) - (define hash-table-size 16) - (define disp-frame-size -17) - (define disp-frame-offset -13) - (define disp-multivalue-rp -9) - (define object-alignment 8) - (define align-shift 3) - (define pagesize 4096)) - -(begin - (define (mem off val) - (cond - [(fixnum? off) (list 'disp (int off) val)] - [(register? off) (list 'disp off val)] - [else (error 'mem "invalid disp ~s" off)])) - (define (int x) (list 'int x)) - (define (obj x) (list 'obj x)) - (define (byte x) (list 'byte x)) - (define (byte-vector x) (list 'byte-vector x)) - (define (movzbl src targ) (list 'movzbl src targ)) - (define (sall src targ) (list 'sall src targ)) - (define (sarl src targ) (list 'sarl src targ)) - (define (shrl src targ) (list 'shrl src targ)) - (define (notl src) (list 'notl src)) - (define (pushl src) (list 'pushl src)) - (define (popl src) (list 'popl src)) - (define (orl src targ) (list 'orl src targ)) - (define (xorl src targ) (list 'xorl src targ)) - (define (andl src targ) (list 'andl src targ)) - (define (movl src targ) (list 'movl src targ)) - (define (movb src targ) (list 'movb src targ)) - (define (addl src targ) (list 'addl src targ)) - (define (imull src targ) (list 'imull src targ)) - (define (idivl src) (list 'idivl src)) - (define (subl src targ) (list 'subl src targ)) - (define (push src) (list 'push src)) - (define (pop targ) (list 'pop targ)) - (define (sete targ) (list 'sete targ)) - (define (call targ) (list 'call targ)) - (define (tail-indirect-cpr-call) - (jmp (mem (fx- disp-closure-code closure-tag) cpr))) - (define (indirect-cpr-call) - (call (mem (fx- disp-closure-code closure-tag) cpr))) - (define (negl targ) (list 'negl targ)) - (define (label x) (list 'label x)) - (define (label-address x) (list 'label-address x)) - (define (ret) '(ret)) - (define (cltd) '(cltd)) - (define (cmpl arg1 arg2) (list 'cmpl arg1 arg2)) - (define (je label) (list 'je label)) - (define (jne label) (list 'jne label)) - (define (jle label) (list 'jle label)) - (define (jge label) (list 'jge label)) - (define (jg label) (list 'jg label)) - (define (jl label) (list 'jl label)) - (define (jb label) (list 'jb label)) - (define (ja label) (list 'ja label)) - (define (jmp label) (list 'jmp label)) - (define edi '%edx) ; closure pointer - (define esi '%esi) ; pcb - (define ebp '%ebp) ; allocation pointer - (define esp '%esp) ; stack base pointer - (define al '%al) - (define ah '%ah) - (define bh '%bh) - (define cl '%cl) - (define eax '%eax) - (define ebx '%ebx) - (define ecx '%ecx) - (define edx '%edx) - (define apr '%ebp) - (define fpr '%esp) - (define cpr '%edi) - (define pcr '%esi) - (define register? symbol?) - (define (argc-convention n) - (fx- 0 (fxsll n fx-shift)))) - - -(define pcb-ref - (lambda (x) - (case x - [(allocation-pointer) (mem 0 pcr)] - [(allocation-redline) (mem 4 pcr)] - [(frame-pointer) (mem 8 pcr)] - [(frame-base) (mem 12 pcr)] - [(frame-redline) (mem 16 pcr)] - [(next-continuation) (mem 20 pcr)] - [(system-stack) (mem 24 pcr)] - [else (error 'pcb-ref "invalid arg ~s" x)]))) - -(define (primref-loc op) - (unless (symbol? op) (error 'primref-loc "not a symbol ~s" op)) - (mem (fx- disp-symbol-system-value symbol-tag) - (obj op))) - -(define (generate-code x) - (define who 'generate-code) - (define (rp-label x) - (case x - [(value) (label-address SL_multiple_values_error_rp)] - [(effect) (label-address SL_multiple_values_ignore_rp)] - [else (error who "invalid rp-convention ~s" x)])) - (define (align n) - (fxsll (fxsra (fx+ n (fxsub1 object-alignment)) align-shift) align-shift)) - (define unique-label - (lambda () - (label (gensym)))) - (define (constant-val x) - (cond - [(fixnum? x) (obj x)] - [(boolean? x) (int (if x bool-t bool-f))] - [(null? x) (int nil)] - [(char? x) (int (fx+ (fxsll (char->integer x) char-shift) char-tag))] - [(eq? x (void)) (int void-object)] - [else (obj x)])) - (define (cond-branch op Lt Lf ac) - (define (opposite x) - (cadr (assq x '([je jne] [jl jge] [jle jg] [jg jle] [jge jl])))) - (unless (or Lt Lf) - (error 'cond-branch "no labels")) - (cond - [(not Lf) (cons (list op Lt) ac)] - [(not Lt) (cons (list (opposite op) Lf) ac)] - [else (list* (list op Lt) (jmp Lf) ac)])) - (define (indirect-type-pred pri-mask pri-tag sec-mask sec-tag rand* Lt Lf ac) - (cond - [(and Lt Lf) - (list* (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int pri-mask) ebx) - (cmpl (int pri-tag) ebx) - (jne Lf) - (movl (mem (fx- 0 pri-tag) eax) ebx) - (if sec-mask - (andl (int sec-mask) ebx) - '(nop)) - (cmpl (int sec-tag) ebx) - (jne Lf) - (jmp Lt) - ac)] - [Lf - (list* (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int pri-mask) ebx) - (cmpl (int pri-tag) ebx) - (jne Lf) - (movl (mem (fx- 0 pri-tag) eax) ebx) - (if sec-mask - (andl (int sec-mask) ebx) - '(nop)) - (cmpl (int sec-tag) ebx) - (jne Lf) - ac)] - [Lt - (let ([L_END (unique-label)]) - (list* (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int pri-mask) ebx) - (cmpl (int pri-tag) ebx) - (jne L_END) - (movl (mem (fx- 0 pri-tag) eax) ebx) - (if sec-mask - (andl (int sec-mask) ebx) - '(nop)) - (cmpl (int sec-tag) ebx) - (je Lt) - L_END - ac))] - [else ac])) - (define (type-pred mask tag rand* Lt Lf ac) - (cond - [mask - (list* - (movl (Simple (car rand*)) eax) - (andl (int mask) eax) - (cmpl (int tag) eax) - (cond-branch 'je Lt Lf ac))] - [else - (let ([v (Simple (car rand*))]) - (cond - [(memq (car v) '(mem register)) - (list* - (cmpl (int tag) (Simple (car rand*))) - (cond-branch 'je Lt Lf ac))] - [else - (list* - (movl (Simple (car rand*)) eax) - (cmpl (int tag) eax) - (cond-branch 'je Lt Lf ac))]))])) - (define (compare-and-branch op rand* Lt Lf ac) - (define (opposite x) - (cadr (assq x '([je je] [jl jg] [jle jge] [jg jl] [jge jle])))) - (cond - [(and (constant? (car rand*)) (constant? (cadr rand*))) - (list* - (movl (Simple (car rand*)) eax) - (cmpl (Simple (cadr rand*)) eax) - (cond-branch op Lt Lf ac))] - [(constant? (cadr rand*)) - (list* - (cmpl (Simple (cadr rand*)) (Simple (car rand*))) - (cond-branch op Lt Lf ac))] - [(constant? (car rand*)) - (list* - (cmpl (Simple (car rand*)) (Simple (cadr rand*))) - (cond-branch (opposite op) Lt Lf ac))] - [else - (list* - (movl (Simple (car rand*)) eax) - (cmpl (Simple (cadr rand*)) eax) - (cond-branch op Lt Lf ac))])) - (define (do-pred-prim op rand* Lt Lf ac) - (case op - [(fixnum?) (type-pred fx-mask fx-tag rand* Lt Lf ac)] - [(pair?) (type-pred pair-mask pair-tag rand* Lt Lf ac)] - [(char?) (type-pred char-mask char-tag rand* Lt Lf ac)] - [(string?) (type-pred string-mask string-tag rand* Lt Lf ac)] - [(symbol?) (type-pred symbol-mask symbol-tag rand* Lt Lf ac)] - [(procedure?) (type-pred closure-mask closure-tag rand* Lt Lf ac)] - [(boolean?) (type-pred bool-mask bool-tag rand* Lt Lf ac)] - [(null?) (type-pred #f nil rand* Lt Lf ac)] - [($unbound-object?) (type-pred #f unbound rand* Lt Lf ac)] - [($forward-ptr?) (type-pred #f -1 rand* Lt Lf ac)] - [(not) (type-pred #f bool-f rand* Lt Lf ac)] - [(eof-object?) (type-pred #f eof rand* Lt Lf ac)] - [($fxzero?) (type-pred #f 0 rand* Lt Lf ac)] - [($fx= $char= eq?) (compare-and-branch 'je rand* Lt Lf ac)] - [($fx< $char<) (compare-and-branch 'jl rand* Lt Lf ac)] - [($fx<= $char<=) (compare-and-branch 'jle rand* Lt Lf ac)] - [($fx> $char>) (compare-and-branch 'jg rand* Lt Lf ac)] - [($fx>= $char>=) (compare-and-branch 'jge rand* Lt Lf ac)] - [(vector?) - (indirect-type-pred vector-mask vector-tag fx-mask fx-tag - rand* Lt Lf ac)] - [($record?) - (indirect-type-pred record-pmask record-ptag record-pmask record-ptag - rand* Lt Lf ac)] - [(code?) - (indirect-type-pred vector-mask vector-tag #f code-tag - rand* Lt Lf ac)] - [(hash-table?) - (indirect-type-pred vector-mask vector-tag #f hash-table-tag - rand* Lt Lf ac)] - [(immediate?) - (cond - [(and Lt Lf) - (list* (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int fx-mask) ebx) - (cmpl (int 0) ebx) - (je Lt) - (andl (int 7) eax) - (cmpl (int 7) eax) - (je Lt) - (jmp Lf) - ac)] - [Lt - (list* (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int fx-mask) ebx) - (cmpl (int 0) ebx) - (je Lt) - (andl (int 7) eax) - (cmpl (int 7) eax) - (je Lt) - ac)] - [Lf - (let ([Ljoin (unique-label)]) - (list* - (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int fx-mask) ebx) - (cmpl (int 0) ebx) - (je Ljoin) - (andl (int 7) eax) - (cmpl (int 7) eax) - (jne Lf) - Ljoin - ac))] - [else ac])] - [($ap-check-words) - (record-case (car rand*) - [(constant i) - (list* (movl (pcb-ref 'allocation-redline) eax) - (subl (Simple (cadr rand*)) eax) - (subl (int i) eax) - (cmpl eax apr) - (cond-branch 'jge Lt Lf ac))] - [else (error who "ap-check-words")])] - [($ap-check-bytes) - (record-case (car rand*) - [(constant i) - (list* (movl (Simple (cadr rand*)) eax) - (negl eax) - (addl (pcb-ref 'allocation-redline) eax) - (subl (int i) eax) - (cmpl eax apr) - (cond-branch 'jge Lt Lf ac))] - [else (error who "ap-check-bytes")])] - [($ap-check-const) - (record-case (car rand*) - [(constant i) - (if (fx< i pagesize) - (list* - (cmpl (pcb-ref 'allocation-redline) apr) - (cond-branch 'jge Lt Lf ac)) - (list* - (movl (pcb-ref 'allocation-redline) eax) - (subl (int i) eax) - (cmpl eax apr) - (cond-branch 'jge Lt Lf ac)))] - [else (error who "ap-check-const")])] - [($fp-at-base) - (list* - (movl (pcb-ref 'frame-base) eax) - (subl (int wordsize) eax) - (cmpl eax fpr) - (cond-branch 'je Lt Lf ac))] - [($fp-overflow) - (list* (cmpl (pcb-ref 'frame-redline) fpr) - (cond-branch 'jle Lt Lf ac))] - [($vector-ref) - (do-value-prim op rand* - (do-simple-test eax Lt Lf ac))] - [(cons void $fxadd1 $fxsub1) - ;;; always true - (do-effect-prim op rand* - (cond - [(not Lt) ac] - [else (cons (jmp Lt) ac)]))] - [else - (error 'pred-prim "HERE unhandled ~s" op)])) - (define (do-pred->value-prim op rand* ac) - (case op - [else - (let ([Lf (unique-label)] [Lj (unique-label)]) - (do-pred-prim op rand* #f Lf - (list* (movl (constant-val #t) eax) - (jmp Lj) - Lf - (movl (constant-val #f) eax) - Lj - ac)))])) - (define (indirect-ref arg* off ac) - (list* - (movl (Simple (car arg*)) eax) - (movl (mem off eax) eax) - ac)) - (define (do-value-prim op arg* ac) - (case op - [(eof-object) (cons (movl (int eof) eax) ac)] - [(void) (cons (movl (int void-object) eax) ac)] - [($fxadd1) - (list* (movl (Simple (car arg*)) eax) - (addl (constant-val 1) eax) - ac)] - [($fxsub1) - (list* (movl (Simple (car arg*)) eax) - (addl (constant-val -1) eax) - ac)] - [($fx+) - (list* (movl (Simple (car arg*)) eax) - (addl (Simple (cadr arg*)) eax) - ac)] - [($fx-) - (list* (movl (Simple (car arg*)) eax) - (subl (Simple (cadr arg*)) eax) - ac)] - [($fx*) - (cond - [(constant? (car arg*)) - (record-case (car arg*) - [(constant c) - (unless (fixnum? c) - (error who "invalid arg ~s to fx*" c)) - (list* (movl (Simple (cadr arg*)) eax) - (imull (int c) eax) - ac)])] - [(constant? (cadr arg*)) - (record-case (cadr arg*) - [(constant c) - (unless (fixnum? c) - (error who "invalid arg ~s to fx*" c)) - (list* (movl (Simple (car arg*)) eax) - (imull (int c) eax) - ac)])] - [else - (list* (movl (Simple (car arg*)) eax) - (sarl (int fx-shift) eax) - (imull (Simple (cadr arg*)) eax) - ac)])] - [($fxquotient) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ecx) - (cltd) - (idivl ecx) - (sall (int fx-shift) eax) - ac)] - [($fxmodulo) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl eax ecx) - (xorl ebx ecx) - (sarl (int (fxsub1 (fx* wordsize 8))) ecx) - (andl ebx ecx) - (cltd) - (idivl ebx) - (movl edx eax) - (addl ecx eax) - ac)] - [($fxlogor) - (list* (movl (Simple (car arg*)) eax) - (orl (Simple (cadr arg*)) eax) - ac)] - [($fxlogand) - (list* (movl (Simple (car arg*)) eax) - (andl (Simple (cadr arg*)) eax) - ac)] - [($fxlogxor) - (list* (movl (Simple (car arg*)) eax) - (xorl (Simple (cadr arg*)) eax) - ac)] - [($fxsra) - (record-case (cadr arg*) - [(constant i) - (unless (fixnum? i) (error who "invalid arg to fxsra")) - (list* (movl (Simple (car arg*)) eax) - (sarl (int (fx+ i fx-shift)) eax) - (sall (int fx-shift) eax) - ac)] - [else - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ecx) - (sarl (int fx-shift) ecx) - (sarl (int fx-shift) eax) - (sarl cl eax) - (sall (int fx-shift) eax) - ac)])] - [($fxsll) - (record-case (cadr arg*) - [(constant i) - (unless (fixnum? i) (error who "invalid arg to fxsll")) - (list* (movl (Simple (car arg*)) eax) - (sall (int i) eax) - ac)] - [else - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ecx) - (sarl (int fx-shift) ecx) - (sall cl eax) - ac)])] - [($fixnum->char) - (list* (movl (Simple (car arg*)) eax) - (sall (int (fx- char-shift fx-shift)) eax) - (orl (int char-tag) eax) - ac)] - [($char->fixnum) - (list* (movl (Simple (car arg*)) eax) - (sarl (int (fx- char-shift fx-shift)) eax) - ac)] - [($fxlognot) - (list* (movl (Simple (car arg*)) eax) - (orl (int fx-mask) eax) - (notl eax) - ac)] - [($car) (indirect-ref arg* (fx- disp-car pair-tag) ac)] - [($cdr) (indirect-ref arg* (fx- disp-cdr pair-tag) ac)] - [($vector-length) - (indirect-ref arg* (fx- disp-vector-length vector-tag) ac)] - [($string-length) - (indirect-ref arg* (fx- disp-string-length string-tag) ac)] - [($symbol-string) - (indirect-ref arg* (fx- disp-symbol-string symbol-tag) ac)] - [($symbol-unique-string) - (indirect-ref arg* (fx- disp-symbol-unique-string symbol-tag) ac)] - [($symbol-value) - (indirect-ref arg* (fx- disp-symbol-value symbol-tag) ac)] - [(primitive-ref) - (indirect-ref arg* (fx- disp-symbol-system-value symbol-tag) ac)] - [($symbol-plist) - (indirect-ref arg* (fx- disp-symbol-plist symbol-tag) ac)] - [($record-rtd) - (indirect-ref arg* (fx- disp-record-rtd record-ptag) ac)] - [($constant-ref) - (list* (movl (Simple (car arg*)) eax) ac)] - [($vector-ref) - (list* (movl (Simple (car arg*)) ebx) - (addl (Simple (cadr arg*)) ebx) - (movl (mem (fx- disp-vector-data vector-tag) ebx) eax) - ac)] - [($record-ref) - (list* (movl (Simple (car arg*)) ebx) - (addl (Simple (cadr arg*)) ebx) - (movl (mem (fx- disp-record-data record-ptag) ebx) eax) - ac)] - [($string-ref) - (list* (movl (Simple (cadr arg*)) ebx) - (sarl (int fx-shift) ebx) - (addl (Simple (car arg*)) ebx) - (movl (int char-tag) eax) - (movb (mem (fx- disp-string-data string-tag) ebx) ah) - ac)] - [($make-string) - (list* (movl (Simple (car arg*)) ebx) - (movl ebx (mem disp-string-length apr)) - (movl apr eax) - (addl (int string-tag) eax) - (sarl (int fx-shift) ebx) - (addl ebx apr) - (movb (int 0) (mem disp-string-data apr)) - (addl (int (fx+ disp-string-data object-alignment)) apr) - (sarl (int align-shift) apr) - (sall (int align-shift) apr) - ac)] - [($make-vector) - (list* (movl (Simple (car arg*)) ebx) - (movl ebx (mem disp-vector-length apr)) - (movl apr eax) - (addl (int vector-tag) eax) - (addl ebx apr) - (addl (int (fx+ disp-vector-data (fxsub1 object-alignment))) apr) - (sarl (int align-shift) apr) - (sall (int align-shift) apr) - ac)] - [($make-record) - (list* (movl (Simple (car arg*)) eax) - (movl eax (mem disp-record-rtd apr)) - (movl apr eax) - (addl (int record-ptag) eax) - (addl (Simple (cadr arg*)) apr) - (addl (int (fx+ disp-record-data (fxsub1 object-alignment))) apr) - (sarl (int align-shift) apr) - (sall (int align-shift) apr) - ac)] - [(cons) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl eax (mem disp-car apr)) - (movl apr eax) - (movl ebx (mem disp-cdr apr)) - (addl (int pair-tag) eax) - (addl (int (align pair-size)) apr) - ac)] - [($make-symbol) - (list* (movl (Simple (car arg*)) eax) - (movl eax (mem disp-symbol-string apr)) - (movl (int 0) (mem disp-symbol-unique-string apr)) - (movl (int unbound) (mem disp-symbol-value apr)) - (movl (int nil) (mem disp-symbol-plist apr)) - (movl (int unbound) (mem disp-symbol-system-value apr)) - (movl (int nil) (mem disp-symbol-system-plist apr)) - (movl apr eax) - (addl (int symbol-tag) eax) - (addl (int (align symbol-size)) apr) - ac)] - [(make-hash-table) - (list* (movl (int hash-table-tag) (mem 0 apr)) - (movl (int 0) (mem disp-htable-count apr)) - (movl (int 0) (mem disp-htable-size apr)) - (movl (int 0) (mem disp-htable-mem apr)) - (movl apr eax) - (addl (int vector-tag) eax) - (addl (int hash-table-size) apr) - ac)] - [(vector) - (let f ([arg* arg*] [idx disp-vector-data]) - (cond - [(null? arg*) - (list* (movl apr eax) - (addl (int vector-tag) eax) - (movl (int (fx- idx disp-vector-data)) - (mem disp-vector-length apr)) - (addl (int (align idx)) apr) - ac)] - [else - (list* (movl (Simple (car arg*)) eax) - (movl eax (mem idx apr)) - (f (cdr arg*) (fx+ idx wordsize)))]))] - ;[($pcb-ref) - ; (let ([loc (car arg*)]) - ; (record-case loc - ; [(constant i) - ; (unless (fixnum? i) (error who "invalid loc ~s" loc)) - ; (list* (movl (mem (fx* i wordsize) pcr) eax) ac)] - ; [else (error who "invalid loc ~s" loc)]))] - [($string) - (let f ([arg* arg*] [idx disp-string-data]) - (cond - [(null? arg*) - (list* (movb (int 0) (mem idx apr)) - (movl apr eax) - (addl (int string-tag) eax) - (movl (int (fx* (fx- idx disp-string-data) wordsize)) - (mem disp-string-length apr)) - (addl (int (align (fxadd1 idx))) apr) - ac)] - [else - (record-case (car arg*) - [(constant c) - (unless (char? c) (error who "invalid arg to string ~s" x)) - (list* (movb (int (char->integer c)) (mem idx apr)) - (f (cdr arg*) (fxadd1 idx)))] - [else - (list* (movl (Simple (car arg*)) ebx) - (movb bh (mem idx apr)) - (f (cdr arg*) (fxadd1 idx)))])]))] - [($current-frame) - (list* (movl (pcb-ref 'next-continuation) eax) - ac)] - [($seal-frame-and-call) - (list* (movl (Simple (car arg*)) cpr) ; proc - (movl (pcb-ref 'frame-base) eax) - ; eax=baseofstack - (movl (mem (fx- 0 wordsize) eax) ebx) ; underflow handler - (movl ebx (mem (fx- 0 wordsize) fpr)) ; set - ; create a new cont record - (movl (int continuation-tag) (mem 0 apr)) - (movl fpr (mem disp-continuation-top apr)) - ; compute the size of the captured frame - (movl eax ebx) - (subl fpr ebx) - (subl (int wordsize) ebx) - ; and store it - (movl ebx (mem disp-continuation-size apr)) - ; load next cont - (movl (pcb-ref 'next-continuation) ebx) - ; and store it - (movl ebx (mem disp-continuation-next apr)) - ; adjust ap - (movl apr eax) - (addl (int vector-tag) eax) - (addl (int continuation-size) apr) - ; store new cont in current-cont - (movl eax (pcb-ref 'next-continuation)) - ; adjust fp - (movl fpr (pcb-ref 'frame-base)) - (subl (int wordsize) fpr) - ; tail-call f - (movl eax (mem (fx- 0 wordsize) fpr)) - (movl (int (argc-convention 1)) eax) - (tail-indirect-cpr-call) - ac)] - [($code-instr-size) - (indirect-ref arg* (fx- disp-code-instrsize vector-tag) - (cons (sall (int fx-shift) eax) ac))] - [($code-reloc-size) - (indirect-ref arg* (fx- disp-code-relocsize vector-tag) ac)] - [($code-closure-size) - (indirect-ref arg* (fx- disp-code-closuresize vector-tag) ac)] - [($set-car! $set-cdr! $vector-set! $string-set! $exit - $set-symbol-value! $set-symbol-plist! - $set-code-byte! $set-code-word! primitive-set! - $set-code-object! $set-code-object+offset! $set-code-object+offset/rel! - $record-set!) - (do-effect-prim op arg* - (cons (movl (int void-object) eax) ac))] - [(fixnum? immediate? $fxzero? boolean? char? pair? vector? string? symbol? - procedure? null? not eof-object? $fx= $fx< $fx<= $fx> $fx>= eq? - $char= $char< $char<= $char> $char>= $unbound-object? code? hash-table? - $record?) - (do-pred->value-prim op arg* ac)] - [($code->closure) - (list* - (movl (Simple (car arg*)) eax) - (addl (int (fx- disp-code-data vector-tag)) eax) - (movl eax (mem 0 apr)) - (movl apr eax) - (addl (int closure-tag) eax) - (addl (int (align disp-closure-data)) apr) - ac)] - [($frame->continuation) - (NonTail - (make-closure (make-code-loc SL_continuation_code) arg*) - ac)] - [($make-call-with-values-procedure) - (NonTail - (make-closure (make-code-loc SL_call_with_values) arg*) - ac)] - [($make-values-procedure) - (NonTail - (make-closure (make-code-loc SL_values) arg*) - ac)] - [else - (error 'value-prim "unhandled ~s" op)])) - (define (do-effect-prim op arg* ac) - (case op - [($vector-set!) - (list* (movl (Simple (car arg*)) ebx) - (addl (Simple (cadr arg*)) ebx) - (movl (Simple (caddr arg*)) eax) - (movl eax (mem (fx- disp-vector-data vector-tag) ebx)) - ac)] - [($string-set!) - (list* (movl (Simple (cadr arg*)) eax) - (sarl (int fx-shift) eax) - (addl (Simple (car arg*)) eax) - (movl (Simple (caddr arg*)) ebx) - (movb bh (mem (fx- disp-string-data string-tag) eax)) - ac)] -; [($set-constant!) -; (NonTail (cadr arg*) -; (list* (movl eax (Simple (car arg*))) ac))] - [($set-car!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-car pair-tag) eax)) - ac)] - [($set-cdr!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-cdr pair-tag) eax)) - ac)] - [($set-symbol-value!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-value symbol-tag) eax)) - ac)] - [(primitive-set!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-system-value symbol-tag) eax)) - ac)] - [($set-symbol-plist!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-plist symbol-tag) eax)) - ac)] - [($set-symbol-unique-string!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-unique-string symbol-tag) eax)) - ac)] - [($set-symbol-string!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-string symbol-tag) eax)) - ac)] - [($record-set!) - (list* (movl (Simple (car arg*)) ebx) - (addl (Simple (cadr arg*)) ebx) - (movl (Simple (caddr arg*)) eax) - (movl eax (mem (fx- disp-record-data record-ptag) ebx)) - ac)] - [($set-code-byte!) - (list* (movl (Simple (cadr arg*)) eax) - (sarl (int fx-shift) eax) - (addl (Simple (car arg*)) eax) - (movl (Simple (caddr arg*)) ebx) - (sarl (int fx-shift) ebx) - (movb bl (mem (fx- disp-code-data vector-tag) eax)) - ac)] - [($set-code-word!) - (list* (movl (Simple (cadr arg*)) eax) - (sarl (int fx-shift) eax) - (addl (Simple (car arg*)) eax) - (movl (Simple (caddr arg*)) ebx) - (movl ebx (mem (fx- disp-code-data vector-tag) eax)) - ac)] - [($set-code-object!) - (let ([code (car arg*)] [object (cadr arg*)] - [code-offset (caddr arg*)] [reloc-idx (cadddr arg*)]) - (list* - (movl (Simple code) eax) - (movl (Simple object) ebx) - (movl (Simple code-offset) edx) - (movl edx ecx) - (sarl (int fx-shift) edx) - (addl eax edx) - (movl ebx (mem (fx- disp-code-data vector-tag) edx)) - (addl (mem (fx- disp-code-instrsize vector-tag) eax) eax) - (addl (Simple reloc-idx) eax) - (movl ecx (mem (fx- disp-code-data vector-tag) eax)) - ac))] - [($set-code-object+offset!) - (let ([code (car arg*)] [object (cadr arg*)] - [code-offset (caddr arg*)] [object-offset (cadddr arg*)] - [reloc-idx (car (cddddr arg*))]) - (list* - (movl (Simple code) eax) - (movl (Simple object-offset) ebx) ; ebx = fxdisp - (sarl (int fx-shift) ebx) ; ebx = disp in bytes - (movl ebx ecx) ; ecx = disp in bytes - (addl (Simple object) ecx) ; ecx = object + disp - (movl (Simple code-offset) edx) ; edx = fx codeoffset - (sarl (int fx-shift) edx) ; edx = codeoffset in bytes - (addl eax edx) - (movl ecx (mem (fx- disp-code-data vector-tag) edx)) - (subl eax edx) - (addl (mem (fx- disp-code-instrsize vector-tag) eax) eax) - (addl (Simple reloc-idx) eax) - (sall (int fx-shift) edx) - (orl (int 1) edx) - (movl edx (mem (fx- disp-code-data vector-tag) eax)) - (movl ebx (mem (fx- (fx+ disp-code-data wordsize) vector-tag) eax)) - ac))] - [($set-code-object+offset/rel!) - (let ([code (car arg*)] [object (cadr arg*)] - [code-offset (caddr arg*)] [object-offset (cadddr arg*)] - [reloc-idx (car (cddddr arg*))]) - (list* - (movl (Simple code) eax) - (movl (Simple object-offset) ebx) - (sarl (int fx-shift) ebx) - (movl (Simple code-offset) ecx) - (orl (int 2) ecx) - (movl (mem (fx- disp-code-instrsize vector-tag) eax) edx) - (addl (Simple reloc-idx) edx) - (addl eax edx) - (movl ecx (mem (fx- disp-code-data vector-tag) edx)) - (movl ebx (mem (fx- (fx+ wordsize disp-code-data) vector-tag) edx)) - (sarl (int fx-shift) ecx) ; code offset in bytes - (addl eax ecx) - (addl (int (fx- (fx+ wordsize disp-code-data) vector-tag)) ecx) - ; ecx points to next word in stream - (addl (Simple object) ebx) ; ebx is object+objectoffset - (subl ecx ebx) ; ebx is relative offset - (movl ebx (mem (fx- 0 wordsize) ecx)) - ac))] - [(cons void $fxadd1 $fxsub1) - (let f ([arg* arg*]) - (cond - [(null? arg*) ac] - [else - (Effect (car arg*) (f (cdr arg*)))]))] - [else - (error 'do-effect-prim "unhandled op ~s" op)])) - (define (do-simple-test x Lt Lf ac) - (unless (or Lt Lf) - (error 'Pred "no labels")) - (cond - [(not Lt) - (list* (cmpl (int bool-f) x) (je Lf) ac)] - [(not Lf) - (list* (cmpl (int bool-f) x) (jne Lt) ac)] - [else - (list* (cmpl (int bool-f) x) (je Lf) (jmp Lt) ac)])) - (define (Simple x) - (record-case x - [(cp-var i) - (mem (fx+ (fx* i wordsize) (fx- disp-closure-data closure-tag)) cpr)] - [(frame-var i) (mem (fx* i (fx- 0 wordsize)) fpr)] - [(constant c) (constant-val c)] - [(code-loc label) (label-address label)] - [(primref op) (primref-loc op)] - [else (error 'Simple "what ~s" x)])) - (define (frame-adjustment offset) - (fx* (fxsub1 offset) (fx- 0 wordsize))) - (define (NonTail x ac) - (record-case x - [(constant c) - (cons (movl (constant-val c) eax) ac)] - [(frame-var) - (cons (movl (Simple x) eax) ac)] - [(cp-var) - (cons (movl (Simple x) eax) ac)] - [(foreign-label L) - (cons (movl (list 'foreign-label L) eax) ac)] - [(primref c) - (cons (movl (primref-loc c) eax) ac)] - [(closure label arg*) - (let f ([arg* arg*] [off disp-closure-data]) - (cond - [(null? arg*) - (list* (movl (Simple label) (mem 0 apr)) - (movl apr eax) - (addl (int (align off)) apr) - (addl (int closure-tag) eax) - ac)] - [else - (list* (movl (Simple (car arg*)) eax) - (movl eax (mem off apr)) - (f (cdr arg*) (fx+ off wordsize)))]))] - [(conditional test conseq altern) - (let ([Lj (unique-label)] [Lf (unique-label)]) - (Pred test #f Lf - (NonTail conseq - (list* (jmp Lj) Lf (NonTail altern (cons Lj ac))))))] - [(seq e0 e1) - (Effect e0 (NonTail e1 ac))] - [(primcall op rand*) - (do-value-prim op rand* ac)] - [(new-frame base-idx size body) - (NonTail body ac)] - [(call-cp call-convention rp-convention offset size mask) - (let ([L_CALL (unique-label)]) - (case call-convention - [(normal) - (list* (addl (int (frame-adjustment offset)) fpr) - (movl (int (argc-convention size)) eax) - (jmp L_CALL) - ; NEW FRAME - `(byte-vector ,mask) - `(int ,(fx* offset wordsize)) - `(current-frame-offset) - (rp-label rp-convention) - `(byte 0) ; padding for indirect calls only - `(byte 0) ; direct calls are ok - L_CALL - (indirect-cpr-call) - (movl (mem 0 fpr) cpr) - (subl (int (frame-adjustment offset)) fpr) - ac)] - [(apply) are-we-ever-here? - (list* (addl (int (frame-adjustment offset)) fpr) - (movl (int (argc-convention size)) eax) - (jmp L_CALL) - ; NEW FRAME - (byte-vector mask) - `(int ,(fx* offset wordsize)) - `(current-frame-offset) - (rp-label rp-convention) - L_CALL - (call (label SL_apply)) - (movl (mem 0 fpr) cpr) - (subl (int (frame-adjustment offset)) fpr) - ac)] - [(foreign) - (list* (addl (int (frame-adjustment offset)) fpr) - (movl (int (argc-convention size)) eax) - (jmp L_CALL) - ; NEW FRAME - (byte-vector mask) - `(int ,(fx* offset wordsize)) - `(current-frame-offset) - (rp-label rp-convention) ; should be 0, since C has 1 rv - L_CALL - (call (label SL_foreign_call)) - (movl (mem 0 fpr) cpr) - (subl (int (frame-adjustment offset)) fpr) - ac)] - [else (error who "invalid convention ~s for call-cp" convention)]))] - [else (error 'NonTail "invalid expression ~s" x)])) - (define (Pred x Lt Lf ac) - (record-case x - [(frame-var i) - (do-simple-test (idx->frame-loc i) Lt Lf ac)] - [(cp-var i) - (do-simple-test (Simple x) Lt Lf ac)] - [(constant c) - (if c - (if Lt (cons (jmp Lt) ac) ac) - (if Lf (cons (jmp Lf) ac) ac))] - [(primcall op rand*) - (do-pred-prim op rand* Lt Lf ac)] - [(conditional test conseq altern) - (cond - [(not Lt) - (let ([Lj^ (unique-label)] [Lf^ (unique-label)]) - (Pred test #f Lf^ - (Pred conseq Lj^ Lf - (cons Lf^ - (Pred altern #f Lf - (cons Lj^ ac))))))] - [(not Lf) - (let ([Lj^ (unique-label)] [Lf^ (unique-label)]) - (Pred test #f Lf^ - (Pred conseq Lt Lj^ - (cons Lf^ - (Pred altern Lt #f - (cons Lj^ ac))))))] - [else - (let ([Lf^ (unique-label)]) - (Pred test #f Lf^ - (Pred conseq Lt Lf - (cons Lf^ - (Pred altern Lt Lf ac)))))])] - [(seq e0 e1) - (Effect e0 (Pred e1 Lt Lf ac))] - [(new-frame) - (NonTail x (do-simple-test eax Lt Lf ac))] - [else (error 'Pred "invalid expression ~s" x)])) - (define (idx->frame-loc i) - (mem (fx* i (fx- 0 wordsize)) fpr)) - (define (Effect x ac) - (record-case x - [(constant) ac] - [(primcall op rand*) - (do-effect-prim op rand* ac)] - [(conditional test conseq altern) - (let ([Lf (unique-label)] [Ljoin (unique-label)]) - (Pred test #f Lf - (Effect conseq - (list* (jmp Ljoin) Lf (Effect altern (cons Ljoin ac))))))] - [(seq e0 e1) - (Effect e0 (Effect e1 ac))] - [(assign loc val) - (record-case loc - [(frame-var i) - (NonTail val - (cons (movl eax (idx->frame-loc i)) ac))] - [else (error who "invalid assign loc ~s" loc)])] - [(eval-cp check body) - (NonTail body - (cond - [check - (list* - (movl eax cpr) - (andl (int closure-mask) eax) - (cmpl (int closure-tag) eax) - (jne (label SL_nonprocedure)) - ac)] - [else - (list* - (movl eax cpr) - ac)]))] - [(save-cp loc) - (record-case loc - [(frame-var i) - (cons (movl cpr (idx->frame-loc i)) ac)] - [else (error who "invalid cpr loc ~s" x)])] - [(new-frame) (NonTail x ac)] - [(frame-var) ac] - [else (error 'Effect "invalid expression ~s" x)])) - (define (Tail x ac) - (record-case x - [(return x) - (NonTail x (cons (ret) ac))] - [(conditional test conseq altern) - (let ([L (unique-label)]) - (Pred test #f L - (Tail conseq - (cons L (Tail altern ac)))))] - [(seq e0 e1) - (Effect e0 (Tail e1 ac))] - [(new-frame idx size body) - (Tail body ac)] - [(call-cp call-convention rp-convention idx argc mask) - (unless (eq? rp-convention 'tail) - (error who "nontail rp (~s) in tail context" rp-convention)) - (let f ([i 0]) - (cond - [(fx= i argc) - (case call-convention - [(normal) - (list* - (movl (int (argc-convention argc)) eax) - (tail-indirect-cpr-call) - ac)] - [(apply) - (list* - (movl (int (argc-convention argc)) eax) - (jmp (label SL_apply)) - ac)] - [else (error who "invalid conv ~s in tail call-cpr" convention)])] - [else - (list* (movl (mem (fx* (fx+ idx (fxadd1 i)) - (fx- 0 wordsize)) fpr) - eax) - (movl eax (mem (fx* (fx+ i 1) (fx- 0 wordsize)) fpr)) - (f (fxadd1 i)))]))] - [else (error 'Tail "invalid expression ~s" x)])) - (define (handle-vararg fml-count ac) - (define CONTINUE_LABEL (unique-label)) - (define DONE_LABEL (unique-label)) - (define CONS_LABEL (unique-label)) - (define LOOP_HEAD (unique-label)) - (define L_CALL (unique-label)) - (list* (cmpl (int (argc-convention (fxsub1 fml-count))) eax) - (jg (label SL_invalid_args)) - (jl CONS_LABEL) - (movl (int nil) ebx) - (jmp DONE_LABEL) - CONS_LABEL - (movl (pcb-ref 'allocation-redline) ebx) - (addl eax ebx) - (addl eax ebx) - (cmpl ebx apr) - (jle LOOP_HEAD) - ; overflow - (addl eax esp) ; advance esp to cover args - (pushl cpr) ; push current cp - (pushl eax) ; push argc - (negl eax) ; make argc positive - (addl (int (fx* 4 wordsize)) eax) ; add 4 words to adjust frame size - (pushl eax) ; push frame size - (addl eax eax) ; double the number of args - (movl eax (mem (fx* -2 wordsize) fpr)) ; pass it as first arg - (movl (int (argc-convention 1)) eax) ; setup argc - (movl (primref-loc 'do-vararg-overflow) cpr) ; load handler - (jmp L_CALL) ; go to overflow handler - ; NEW FRAME - (int 0) ; if the framesize=0, then the framesize is dynamic - '(current-frame-offset) - (int 0) ; multiarg rp - (byte 0) - (byte 0) - L_CALL - (indirect-cpr-call) - (popl eax) ; pop framesize and drop it - (popl eax) ; reload argc - (popl cpr) ; reload cp - (subl eax fpr) ; readjust fp - LOOP_HEAD - (movl (int nil) ebx) - CONTINUE_LABEL - (movl ebx (mem disp-cdr apr)) - (movl (mem fpr eax) ebx) - (movl ebx (mem disp-car apr)) - (movl apr ebx) - (addl (int pair-tag) ebx) - (addl (int pair-size) apr) - (addl (int (fxsll 1 fx-shift)) eax) - (cmpl (int (fx- 0 (fxsll fml-count fx-shift))) eax) - (jle CONTINUE_LABEL) - DONE_LABEL - (movl ebx (mem (fx- 0 (fxsll fml-count fx-shift)) fpr)) - ac)) - (define (Entry check? x ac) - (record-case x - [(clambda-case fml* proper body) - (let ([ac (Tail body ac)]) - (cond - [(and proper check?) - (list* (cmpl (int (argc-convention (length fml*))) eax) - (jne (label SL_invalid_args)) - ac)] - [proper ac] - [else - (handle-vararg (length fml*) ac)]))])) - (define make-dispatcher - (lambda (j? L L* x x* ac) - (cond - [(null? L*) (if j? (cons (jmp (label L)) ac) ac)] - [else - (record-case x - [(clambda-case fml* proper _) - (cond - [proper - (list* (cmpl (int (argc-convention (length fml*))) eax) - (je (label L)) - (make-dispatcher #t - (car L*) (cdr L*) (car x*) (cdr x*) ac))] - [else - (list* (cmpl (int (argc-convention (fxsub1 (length fml*)))) eax) - (jle (label L)) - (make-dispatcher #t - (car L*) (cdr L*) (car x*) (cdr x*) ac))])])]))) - (define (handle-cases x x*) - (let ([L* (map (lambda (_) (gensym)) x*)] - [L (gensym)]) - (make-dispatcher #f L L* x x* - (let f ([x x] [x* x*] [L L] [L* L*]) - (cond - [(null? x*) - (cons (label L) (Entry 'check x '()))] - [else - (cons (label L) - (Entry #f x - (f (car x*) (cdr x*) (car L*) (cdr L*))))]))))) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (list* - (fx+ disp-closure-data (fx* wordsize (length free))) - (label L) - (handle-cases (car cases) (cdr cases)))])) - (record-case x - [(codes list body) - (cons (cons 0 (Tail body '())) - (map CodeExpr list))])) - - -(define SL_nonprocedure (gensym "SL_nonprocedure")) -(define SL_invalid_args (gensym "SL_invalid_args")) -(define SL_foreign_call (gensym "SL_foreign_call")) -(define SL_continuation_code (gensym "SL_continuation_code")) -(define SL_multiple_values_error_rp (gensym "SL_multiple_values_error_rp")) -(define SL_multiple_values_ignore_rp (gensym "SL_multiple_ignore_error_rp")) -(define SL_underflow_multiple_values (gensym "SL_underflow_multiple_values")) -(define SL_underflow_handler (gensym "SL_underflow_handler")) -(define SL_scheme_exit (gensym "SL_scheme_exit")) -(define SL_apply (gensym "SL_apply")) -(define SL_values (gensym "SL_values")) -(define SL_call_with_values (gensym "SL_call_with_values")) - -(list*->code* - (list - (let ([L_cwv_done (gensym)] - [L_cwv_loop (gensym)] - [L_cwv_multi_rp (gensym)] - [L_cwv_call (gensym)] - ) - (list disp-closure-data - (label SL_call_with_values) - (cmpl (int (argc-convention 2)) eax) - (jne (label SL_invalid_args)) - (movl (mem (fx- 0 wordsize) fpr) ebx) ; producer - (movl ebx cpr) - (andl (int closure-mask) ebx) - (cmpl (int closure-tag) ebx) - (jne (label SL_nonprocedure)) - (movl (int (argc-convention 0)) eax) - (subl (int (fx* wordsize 2)) fpr) - (jmp (label L_cwv_call)) - ; MV NEW FRAME - (byte-vector '#(#b110)) - (int (fx* wordsize 3)) - '(current-frame-offset) - (label-address L_cwv_multi_rp) - (byte 0) - (byte 0) - (label L_cwv_call) - (indirect-cpr-call) - ;;; one value returned - (addl (int (fx* wordsize 2)) fpr) - (movl (mem (fx* -2 wordsize) fpr) ebx) ; consumer - (movl ebx cpr) - (movl eax (mem (fx- 0 wordsize) fpr)) - (movl (int (argc-convention 1)) eax) - (andl (int closure-mask) ebx) - (cmpl (int closure-tag) ebx) - (jne (label SL_nonprocedure)) - (tail-indirect-cpr-call) - ;;; multiple values returned - (label L_cwv_multi_rp) - ; because values does not pop the return point - ; we have to adjust fp one more word here - (addl (int (fx* wordsize 3)) fpr) - (movl (mem (fx* -2 wordsize) fpr) cpr) ; consumer - (cmpl (int (argc-convention 0)) eax) - (je (label L_cwv_done)) - (movl (int (fx* -4 wordsize)) ebx) - (addl fpr ebx) ; ebx points to first value - (movl ebx ecx) - (addl eax ecx) ; ecx points to the last value - (label L_cwv_loop) - (movl (mem 0 ebx) edx) - (movl edx (mem (fx* 3 wordsize) ebx)) - (subl (int wordsize) ebx) - (cmpl ecx ebx) - (jge (label L_cwv_loop)) - (label L_cwv_done) - (movl cpr ebx) - (andl (int closure-mask) ebx) - (cmpl (int closure-tag) ebx) - (jne (label SL_nonprocedure)) - (tail-indirect-cpr-call))) - - (let ([L_values_one_value (gensym)] - [L_values_many_values (gensym)]) - (list disp-closure-data - (label SL_values) - (cmpl (int (argc-convention 1)) eax) - (je (label L_values_one_value)) - (label L_values_many_values) - (movl (mem 0 fpr) ebx) ; return point - (jmp (mem disp-multivalue-rp ebx)) ; go - (label L_values_one_value) - (movl (mem (fx- 0 wordsize) fpr) eax) - (ret))) - - (let ([L_apply_done (gensym)] - [L_apply_loop (gensym)]) - (list 0 - (label SL_apply) - (movl (mem fpr eax) ebx) - (cmpl (int nil) ebx) - (je (label L_apply_done)) - (label L_apply_loop) - (movl (mem (fx- disp-car pair-tag) ebx) ecx) - (movl (mem (fx- disp-cdr pair-tag) ebx) ebx) - (movl ecx (mem fpr eax)) - (subl (int wordsize) eax) - (cmpl (int nil) ebx) - (jne (label L_apply_loop)) - (label L_apply_done) - (addl (int wordsize) eax) - (tail-indirect-cpr-call))) - - (list 0 - (label SL_nonprocedure) - (movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg - (movl (primref-loc '$apply-nonprocedure-error-handler) cpr) - (movl (int (argc-convention 1)) eax) - (tail-indirect-cpr-call)) - - (list 0 - (label SL_multiple_values_error_rp) - (movl (primref-loc '$multiple-values-error) cpr) - (tail-indirect-cpr-call)) - - (list 0 - (label SL_multiple_values_ignore_rp) - (ret)) - - (list 0 - (label SL_invalid_args) - ;;; - (movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg - (negl eax) - (movl eax (mem (fx- 0 (fx* 2 wordsize)) fpr)) - (movl (primref-loc '$incorrect-args-error-handler) cpr) - (movl (int (argc-convention 2)) eax) - (tail-indirect-cpr-call)) - - (let ([Lset (gensym)] [Lloop (gensym)]) - (list 0 - (label SL_foreign_call) - (movl fpr (pcb-ref 'frame-pointer)) - (movl apr (pcb-ref 'allocation-pointer)) - (movl fpr ebx) - (movl (pcb-ref 'system-stack) esp) - (pushl pcr) - (cmpl (int 0) eax) - (je (label Lset)) - (label Lloop) - (movl (mem ebx eax) ecx) - (pushl ecx) - (addl (int 4) eax) - (cmpl (int 0) eax) - (jne (label Lloop)) - (label Lset) - ; FOREIGN NEW FRAME - (call cpr) - (movl (pcb-ref 'frame-pointer) fpr) - (movl (pcb-ref 'allocation-pointer) apr) - (ret))) - - (let ([L_cont_zero_args (gensym)] - [L_cont_mult_args (gensym)] - [L_cont_one_arg (gensym)] - [L_cont_mult_move_args (gensym)] - [L_cont_mult_copy_loop (gensym)]) - (list - (fx+ disp-closure-data wordsize) - (label SL_continuation_code) - (movl (mem (fx- disp-closure-data closure-tag) cpr) ebx) ; captured-k - (movl ebx (pcb-ref 'next-continuation)) ; set - (movl (pcb-ref 'frame-base) ebx) - (cmpl (int (argc-convention 1)) eax) - (jg (label L_cont_zero_args)) - (jl (label L_cont_mult_args)) - (label L_cont_one_arg) - (movl (mem (fx- 0 wordsize) fpr) eax) - (movl ebx fpr) - (subl (int wordsize) fpr) - (ret) - (label L_cont_zero_args) - (subl (int wordsize) ebx) - (movl ebx fpr) - (movl (mem 0 ebx) ebx) ; return point - (jmp (mem disp-multivalue-rp ebx)) ; go - (label L_cont_mult_args) - (subl (int wordsize) ebx) - (cmpl ebx fpr) - (jne (label L_cont_mult_move_args)) - (movl (mem 0 ebx) ebx) - (jmp (mem disp-multivalue-rp ebx)) - (label L_cont_mult_move_args) - ; move args from fpr to ebx - (movl (int 0) ecx) - (label L_cont_mult_copy_loop) - (subl (int wordsize) ecx) - (movl (mem fpr ecx) edx) - (movl edx (mem ebx ecx)) - (cmpl ecx eax) - (jne (label L_cont_mult_copy_loop)) - (movl ebx fpr) - (movl (mem 0 ebx) ebx) - (jmp (mem disp-multivalue-rp ebx)) - )) - )) - - - -(define (compile-program original-program) - (let* (;;; - [p (expand original-program)] - [p (recordize p)] - ;[f (pretty-print (unparse p))] - [p (optimize-direct-calls p)] - [p (remove-assignments p)] - [p (convert-closures p)] - [p (lift-codes p)] - ;[p (lift-complex-constants p)] - [p (introduce-primcalls p)] - [p (simplify-operands p)] - ;[f (pretty-print (unparse p))] - [p (insert-stack-overflow-checks p)] - [p (insert-allocation-checks p)] - [p (remove-local-variables p)] - ;[f (pretty-print (unparse p))] - [ls* (generate-code p)] - [f (when (assembler-output) - (for-each - (lambda (ls) - (for-each (lambda (x) (printf " ~s\n" x)) ls)) - ls*))] - [code* (list*->code* ls*)]) - (fasl-write (car code*) (compile-port)))) - - -(define compile-expr - (lambda (expr output-file) - (let ([op (open-output-file output-file 'replace)]) - (parameterize ([compile-port op]) - (compile-program expr)) - (close-output-port op)))) - -(define compile-file - (lambda (input-file output-file) - (let ([ip (open-input-file input-file)] - [op (open-output-file output-file 'replace)]) - (parameterize ([compile-port op]) - (let f () - (let ([x (read ip)]) - (unless (eof-object? x) - (compile-program x) - (f))))) - (close-input-port ip) - (close-output-port op)))) - - -(parameterize ([assembler-output #f]) - (for-each - (lambda (x) - (printf "compiling ~a ...\n" x) - (compile-file (car x) (cadr x))) - scheme-library-files)) - -(system "rm -f ikarus.fasl") - -(for-each - (lambda (x) - (system (format "cat ~a >> ikarus.fasl" (cadr x)))) - scheme-library-files) - - - -(define replace-safe-prims-with-unsafe - (lambda (x) - (define prims - '([fx+ $fx+] [fx- $fx-] [fx* $fx*] [fxadd1 $fxadd1] [fxsub1 $fxsub1] - [fxlogand $fxlogand] [fxlogor $fxlogor] [fxlognot $fxlognot] - [fx= $fx=] [fx< $fx<] [fx<= $fx<=] [fx> $fx>] [fx>= $fx>=] - [fxzero? $fxzero?] - [fixnum->char $fixnum->char] [char->fixnum $char->fixnum] - [char= $char=] - [char< $char<] [char> $char>] [char<= $char<=] [char>= $char>=] - [car $car] [cdr $cdr] [set-car! $set-car!] [set-cdr! $set-cdr!] - [vector-length $vector-length] [vector-ref $vector-ref] - [vector-set! $vector-set!] [make-vector $make-vector] - [string-length $string-length] [string-ref $string-ref] - [string-set! $string-set!] [make-string $make-string] - )) - (define (E x) - (cond - [(pair? x) (cons (E (car x)) (E (cdr x)))] - [(symbol? x) - (cond - [(assq x prims) => cadr] - [else x])] - [else x])) - (E x))) - -(parameterize ([input-filter - (lambda (x) - `(begin (write (eval ',x)) (newline) (exit 0)))]) - (test-all)) - -(define (get-date) - (system "date +\"%F\" > build-date.tmp") - (let ([ip (open-input-file "build-date.tmp")]) - (list->string - (let f () - (let ([x (read-char ip)]) - (if (char= x #\newline) - '() - (cons x (f)))))))) - -(compile-expr - `(begin - (display ,(format "Petite Ikarus Scheme (Build ~a)\n" (get-date))) - (display "Copyright (c) 2006 Abdulaziz Ghuloum\n\n") - (new-cafe)) - "petite-ikarus.fasl") diff --git a/src/compiler-6.2.ss b/src/compiler-6.2.ss deleted file mode 100644 index 30649cc..0000000 --- a/src/compiler-6.2.ss +++ /dev/null @@ -1,3185 +0,0 @@ - - -;;; 6.2: * side-effects now modify the dirty-vector -;;; * added bwp-object? -;;; * added pointer-value -;;; * added tcbuckets -;;; 6.1: * added case-lambda, dropped lambda -;;; 6.0: * basic compiler - -(when (eq? "" "") - (load "chez-compat.ss") - (set! primitive-ref top-level-value) - (load "libexpand-6.2.ss") - ;(load "libinterpret-6.0.ss") - (load "record-case.ss") - ;(#%current-eval eval) - ) - -(define primitive-set! set-top-level-value!) - -(load "libassembler-compat-6.0.ss") ; defines make-code etc. -(load "libintelasm-6.0.ss") ; uses make-code, etc. -(load "libfasl-6.0.ss") ; uses code? etc. - - - -(load "tests-driver.ss") -(print-gensym #f) -(gensym-prefix "L_") - - -(define assembler-output (make-parameter #t)) - -(load "set-operations.ss") -;(load "tests-5.6-req.scm") -;(load "tests-5.3-req.scm") -;(load "tests-5.2-req.scm") -;(load "tests-5.1-req.scm") -;(load "tests-4.3-req.scm") -;(load "tests-4.2-req.scm") - -;(load "tests-4.1-req.scm") -;(load "tests-3.4-req.scm") - -;(load "tests-3.3-req.scm") -;(load "tests-3.2-req.scm") -;(load "tests-3.1-req.scm") -;(load "tests-2.9-req.scm") -;(load "tests-2.8-req.scm") -;(load "tests-2.6-req.scm") -;(load "tests-2.4-req.scm") -;(load "tests-2.3-req.scm") -;(load "tests-2.2-req.scm") -;(load "tests-2.1-req.scm") -;(load "tests-1.9-req.scm") -;(load "tests-1.8-req.scm") -;(load "tests-1.7-req.scm") -;(load "tests-1.6-req.scm") -;(load "tests-1.5-req.scm") -;(load "tests-1.4-req.scm") -;(load "tests-1.3-req.scm") -;(load "tests-1.2-req.scm") -;(load "tests-1.1-req.scm") - - -(define scheme-library-files - '(["libhandlers-6.0.ss" "libhandlers.fasl"] - ["libcontrol-6.1.ss" "libcontrol.fasl"] - ["libcollect-6.1.ss" "libcollect.fasl"] - ["librecord-6.1.ss" "librecord.fasl"] - ["libcxr-6.0.ss" "libcxr.fasl"] - ["libcore-6.2.ss" "libcore.fasl"] - ["libio-6.1.ss" "libio.fasl"] - ["libwriter-6.2.ss" "libwriter.fasl"] - ["libtokenizer-6.1.ss" "libtokenizer.fasl"] - ["libexpand-6.2.ss" "libexpand.fasl"] - ["libinterpret-6.1.ss" "libinterpret.fasl"] - ;["libintelasm-6.0.ss" "libintelasm.fasl"] - ["libcafe-6.1.ss" "libcafe.fasl"] -; ["libtrace-5.3.ss" "libtrace-5.3.s" "libtrace" ] - ["libposix-6.0.ss" "libposix.fasl"] - ["libhash-6.2.ss" "libhash.fasl"] - ["libtoplevel-6.0.ss" "libtoplevel.fasl"] - )) - -(define primitive? - (lambda (x) - (or (assq x open-coded-primitives) - (memq x public-primitives)))) - -(define open-coded-primitives -;;; these primitives, when found in operator position with the correct -;;; number of arguments, will be open-coded by the generator. If an -;;; incorrect number of args is detected, or if they appear in non-operator -;;; position, then they cannot be open-coded, and the pcb-primitives table -;;; is consulted for a reference of the pcb slot containing the primitive. -;;; If it's not found there, an error is signalled. -;;; -;;; prim-name args - '([$constant-ref 1 value] - [$constant-set! 2 effect] - [$pcb-ref 1 value] - [$pcb-set! 2 effect] - ;;; type predicates - [fixnum? 1 pred] - [immediate? 1 pred] - [boolean? 1 pred] - [char? 1 pred] - [pair? 1 pred] - [symbol? 1 pred] - [vector? 1 pred] - [string? 1 pred] - [procedure? 1 pred] - [null? 1 pred] - [eof-object? 1 pred] - [bwp-object? 1 pred] - [$unbound-object? 1 pred] - [$forward-ptr? 1 pred] - [not 1 pred] - [pointer-value 1 value] - [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] - ;;; tcbuckets - [$make-tcbucket 4 value] - [$tcbucket-key 1 value] - [$tcbucket-val 1 value] - [$tcbucket-next 1 value] - [$set-tcbucket-val! 2 effect] - [$set-tcbucket-next! 2 effect] - [$set-tcbucket-tconc! 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] - ;;; - ;;; asm - ;;; - ;[code? 1 pred] - ;[$code-instr-size 1 value] - ;[$code-reloc-size 1 value] - ;[$code-closure-size 1 value] - ;[$code->closure 1 value] - ;[$set-code-byte! 3 effect] - ;[$set-code-word! 3 effect] - ;[$set-code-object! 4 effect] - ;[$set-code-object+offset! 5 effect] - ;[$set-code-object+offset/rel! 5 effect] - ;;; - [$make-call-with-values-procedure 0 value] - [$make-values-procedure 0 value] - [$install-underflow-handler 0 effect] - )) - -(define (primitive-context x) - (cond - [(assq x open-coded-primitives) => caddr] - [else (error 'primitive-context "unknown prim ~s" x)])) - - -;;; primitives table section -(define primitives-table - '(;;; system locations used by the C/Scheme interface - [$apply-nonprocedure-error-handler library] - [$incorrect-args-error-handler library] - [$multiple-values-error library] - [$intern library] - [do-overflow library] - [do-vararg-overflow library] - [do-stack-overflow library] - ;;; type predicates - [fixnum? public] - [immediate? public] - [boolean? public] - [char? public] - [null? public] - [pair? public] - [symbol? public] - [vector? public] - [string? public] - [procedure? public] - [eof-object? public] - [not public] - [eq? public] - [equal? public] - ;;; fixnum primitives - [fxadd1 public] - [fxsub1 public] - [fx+ public] - [fx- public] - [fx* public] - [fxsll public] - [fxsra public] - [fxlogor public] - [fxlogand public] - [fxlogxor public] - [fxlognot public] - [fxquotient public] - [fxremainder public] - [fxmodulo public] - ;;; fixnum predicates - [fxzero? public] - [fx= public] - [fx< public] - [fx<= public] - [fx> public] - [fx>= public] - ;;; characters - [char=? public] - [char? public] - [char>=? public] - [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] - [primitive-set! 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] - [syntax-error public] - [core-expand public] - [current-expand public] - - [$sc-put-cte public] - [sc-expand public] - [$make-environment public] - [environment? public] - [interaction-environment public] - [identifier? public] - [syntax->list public] - [syntax-object->datum public] - [datum->syntax-object public] - [generate-temporaries public] - [free-identifier=? public] - [bound-identifier=? public] - [literal-identifier=? public] - [syntax-error public] - [$syntax-dispatch public] - - - - [interpret public] - [eval public] - [current-eval public] - [load public] - [new-cafe public] - [collect public] - [call/cc public] - [call/cf library] - [dynamic-wind public] - [values public] - [call-with-values public] - [make-traced-procedure library] - [trace-symbol! library] - [untrace-symbol! library] - ;;; record - [$base-rtd library] - [record? public] - [record-rtd public] - [record-name public] - [record-printer public] - [record-length public] - [record-ref public] - [record-set! public] - ;;; record rtds - [make-record-type public] - [record-constructor public] - [record-predicate public] - [record-field-accessor public] - [record-field-mutator public] - ;;; hash tables - [make-hash-table public] - [hash-table? public] - [get-hash-table public] - [put-hash-table! public] - ;;; asm - [make-code public] - [code? public] - [make-code-executable! public] - [code-instr-size public] - [code-reloc-size public] - [code-closure-size public] - [set-code-byte! public] - [set-code-word! public] - [set-code-object! public] - [set-code-foreign-object! public] - [set-code-object+offset! public] - [set-code-object+offset/rel! public] - [set-code-object/reloc/relative! public] - [code->closure public] - [list*->code* library] - ;;; - ;;; POSIX - ;;; - [fork public] - [posix-fork public] - [system public] - [$debug public] - [$underflow-misaligned-error public] - )) - -(define (primitive? x) - (cond - [(assq x primitives-table) #t] - [(assq x open-coded-primitives) #t] - [else #f])) - -(define (open-codeable? x) - (cond - [(assq x open-coded-primitives) #t] - [(assq x primitives-table) #f] - [else (error 'open-codeable "invalid primitive ~s" x)])) - -(define (open-coded-primitive-args x) - (cond - [(assq x open-coded-primitives) => cadr] - [else (error 'open-coded-primitive-args "invalid ~s" x)])) - -;;; end of primitives table section - - -(define-record constant (value)) -(define-record code-loc (label)) -(define-record foreign-label (label)) -(define-record var (name)) -(define-record cp-var (idx)) -(define-record frame-var (idx)) -(define-record new-frame (base-idx size body)) -(define-record save-cp (loc)) -(define-record eval-cp (check body)) -(define-record return (value)) -(define-record call-cp - (call-convention rp-convention base-idx arg-count live-mask)) -(define-record primcall (op arg*)) -(define-record primref (name)) -(define-record conditional (test conseq altern)) -(define-record bind (lhs* rhs* body)) -(define-record seq (e0 e1)) -(define-record function (arg* proper body)) -(define-record clambda-case (arg* proper body)) -(define-record clambda (cases)) -(define-record clambda-code (label cases free)) - -(define-record closure (code free*)) -(define-record funcall (op rand*)) -(define-record appcall (op rand*)) -(define-record forcall (op rand*)) -(define-record code-rec (arg* proper free* body)) - -(define-record codes (list body)) -(define-record assign (lhs rhs)) - -(define unique-var - (let ([counter 0]) - (lambda (x) - (let ([g (gensym (format "~a:~a" x counter))]) - (set! counter (fxadd1 counter)) - (make-var g))))) - -(define (make-bind^ lhs* rhs* body) - (if (null? lhs*) - body - (make-bind lhs* rhs* body))) - -(define (recordize x) - (define (gen-fml* fml*) - (cond - [(pair? fml*) - (cons (unique-var (car fml*)) - (gen-fml* (cdr fml*)))] - [(symbol? fml*) - (unique-var fml*)] - [else '()])) - (define (properize fml*) - (cond - [(pair? fml*) - (cons (car fml*) (properize (cdr fml*)))] - [(null? fml*) '()] - [else (list fml*)])) - (define (extend-env fml* nfml* env) - (cons (cons fml* nfml*) env)) - (define (quoted-sym x) - (if (and (list? x) - (fx= (length x) 2) - (eq? 'quote (car x)) - (symbol? (cadr x))) - (cadr x) - (error 'quoted-sym "not a quoted symbol ~s" x))) - (define (quoted-string x) - (if (and (list? x) - (fx= (length x) 2) - (eq? 'quote (car x)) - (string? (cadr x))) - (cadr x) - (error 'quoted-string "not a quoted string ~s" x))) - (define (lookup^ x lhs* rhs*) - (cond - [(pair? lhs*) - (if (eq? x (car lhs*)) - (car rhs*) - (lookup^ x (cdr lhs*) (cdr rhs*)))] - [(eq? x lhs*) rhs*] - [else #f])) - (define (lookup x env) - (cond - [(pair? env) - (or (lookup^ x (caar env) (cdar env)) - (lookup x (cdr env)))] - [else #f])) - (define (E x env) - (cond - [(pair? x) - (case (car x) - [(quote) (make-constant (cadr x))] - [(if) - (make-conditional - (E (cadr x) env) - (E (caddr x) env) - (E (cadddr x) env))] - [(set!) - (let ([lhs (cadr x)] [rhs (caddr x)]) - (make-assign - (or (lookup lhs env) - (error 'recordize "invalid assignment ~s" x)) - (E rhs env)))] - [(begin) - (let f ([a (cadr x)] [d (cddr x)]) - (cond - [(null? d) (E a env)] - [else - (make-seq - (E a env) - (f (car d) (cdr d)))]))] - [(case-lambda) - (let ([cls* - (map - (lambda (cls) - (let ([fml* (car cls)] [body (cadr cls)]) - (let ([nfml* (gen-fml* fml*)]) - (let ([body (E body (extend-env fml* nfml* env))]) - (make-clambda-case - (properize nfml*) - (list? fml*) - body))))) - (cdr x))]) - (make-clambda cls*))] - [(foreign-call) - (let ([name (quoted-string (cadr x))] [arg* (cddr x)]) - (make-forcall name - (map (lambda (x) (E x env)) arg*)))] - [(|#primitive|) - (let ([var (cadr x)]) - (if (primitive? var) - (make-primref var) - (error 'recordize "invalid primitive ~s" var)))] - [(top-level-value) - (let ([var (quoted-sym (cadr x))]) - (if (primitive? var) - (make-primref var) - (error 'recordize "invalid top-level var ~s" var)))] - [(memv) - (make-funcall - (make-primref 'memq) - (map (lambda (x) (E x env)) (cdr x)))] - [($apply) - (let ([proc (cadr x)] [arg* (cddr x)]) - (make-appcall - (E proc env) - (map (lambda (x) (E x env)) arg*)))] - [(void) - (make-constant (void))] - [else - (make-funcall - (E (car x) env) - (map (lambda (x) (E x env)) (cdr x)))])] - [(symbol? x) - (or (lookup x env) - (error 'recordize "invalid reference in ~s" x))] - [else (error 'recordize "invalid expression ~s" x)])) - (E x '())) - - -(define (unparse x) - (define (E-args proper x) - (if proper - (map E x) - (let f ([a (car x)] [d (cdr x)]) - (cond - [(null? d) (E a)] - [else (cons (E a) (f (car d) (cdr d)))])))) - (define (E x) - (record-case x - [(constant c) `(quote ,c)] - [(code-loc x) `(code-loc ,x)] - [(var x) (string->symbol (format "v:~a" x))] - [(primref x) x] - [(conditional test conseq altern) - `(if ,(E test) ,(E conseq) ,(E altern))] - [(primcall op arg*) `(,op . ,(map E arg*))] - [(bind lhs* rhs* body) - `(let ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*) - ,(E body))] - [(seq e0 e1) `(begin ,(E e0) ,(E e1))] - [(function args proper body) - `(lambda ,(E-args proper args) ,(E body))] - [(clambda-case args proper body) - `(clambda-case ,(E-args proper args) ,(E body))] - [(clambda cls*) - `(case-lambda . ,(map E cls*))] - [(clambda-code label clauses free) - `(code ,label . ,(map E clauses))] - [(closure code free*) - `(closure ,(E code) ,(map E free*))] - [(code-rec arg* proper free* body) - `(code-rec [arg: ,(E-args proper arg*)] - [free: ,(map E free*)] - ,(E body))] - [(codes list body) - `(codes ,(map E list) - ,(E body))] - [(funcall rator rand*) `(funcall ,(E rator) . ,(map E rand*))] - [(appcall rator rand*) `(appcall ,(E rator) . ,(map E rand*))] - [(forcall rator rand*) `(foreign-call ,rator . ,(map E rand*))] - [(assign lhs rhs) `(set! ,(E lhs) ,(E rhs))] - [(return x) `(return ,(E x))] - [(new-frame base-idx size body) - `(new-frame [base: ,base-idx] - [size: ,size] - ,(E body))] - [(frame-var idx) - (string->symbol (format "fv.~a" idx))] - [(cp-var idx) - (string->symbol (format "cp.~a" idx))] - [(save-cp expr) - `(save-cp ,(E expr))] - [(eval-cp check body) - `(eval-cp ,check ,(E body))] - [(call-cp call-convention rp-convention base-idx arg-count live-mask) - `(call-cp [conv: ,call-convention] - [rpconv: ,rp-convention] - [base-idx: ,base-idx] - [arg-count: ,arg-count] - [live-mask: ,live-mask])] - [(foreign-label x) `(foreign-label ,x)] - [else (error 'unparse "invalid record ~s" x)])) - (E x)) - -(define (optimize-direct-calls x) - (define who 'optimize-direct-calls) - (define (make-conses ls) - (cond - [(null? ls) (make-constant '())] - [else - (make-primcall 'cons - (list (car ls) (make-conses (cdr ls))))])) - (define (properize lhs* rhs*) - (cond - [(null? lhs*) (error who "improper improper")] - [(null? (cdr lhs*)) - (list (make-conses rhs*))] - [else (cons (car rhs*) (properize (cdr lhs*) (cdr rhs*)))])) - (define (inline-case cls rand*) - (record-case cls - [(clambda-case fml* proper body) - (if proper - (and (fx= (length fml*) (length rand*)) - (make-bind fml* rand* body)) - (and (fx<= (length fml*) (length rand*)) - (make-bind fml* (properize fml* rand*) body)))])) - (define (try-inline cls* rand* default) - (cond - [(null? cls*) default] - [(inline-case (car cls*) rand*)] - [else (try-inline (cdr cls*) rand* default)])) - (define (inline rator rand*) - (record-case rator - [(clambda cls*) - (try-inline cls* rand* - (make-funcall rator rand*))] -; [(function fml* proper body) -; (cond -; [proper -; (if (fx= (length fml*) (length rand*)) -; (make-bind fml* rand* body) -; (begin -; (warning 'compile "possible application error in ~s" -; (unparse (make-funcall rator rand*))) -; (make-funcall rator rand*)))] -; [else -; (if (fx<= (length fml*) (length rand*)) -; (make-bind fml* (properize fml* rand*) body) -; (begin -; (warning 'compile "possible application error in ~s" -; (unparse (make-funcall rator rand*))) -; (make-funcall rator rand*)))])] - [else (make-funcall rator rand*)])) - (define (Expr x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (make-conditional - (Expr test) - (Expr conseq) - (Expr altern))] - [(seq e0 e1) - (make-seq (Expr e0) (Expr e1))] - [(function fml* proper body) - (make-function fml* proper (Expr body))] - [(clambda cls*) - (make-clambda - (map (lambda (x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (Expr body))])) - cls*))] - [(primcall rator rand*) - (make-primcall rator (map Expr rand*))] - [(funcall rator rand*) - (inline (Expr rator) (map Expr rand*))] - [(appcall rator rand*) - (make-appcall (Expr rator) (map Expr rand*))] - [(forcall rator rand*) - (make-forcall rator (map Expr rand*))] - [(assign lhs rhs) - (make-assign lhs (Expr rhs))] - [else (error who "invalid expression ~s" (unparse x))])) - (Expr x)) - - - -(define (uncover-assigned x) - (define who 'uncover-assigned) - (define (Expr* x*) - (cond - [(null? x*) '()] - [else (union (Expr (car x*)) (Expr* (cdr x*)))])) - (define (Expr x) - (record-case x - [(constant) '()] - [(var) '()] - [(primref) '()] - [(bind lhs* rhs* body) - (union (Expr body) (Expr* rhs*))] - [(conditional test conseq altern) - (union (Expr test) (union (Expr conseq) (Expr altern)))] - [(seq e0 e1) (union (Expr e0) (Expr e1))] - [(clambda cls*) - (Expr* (map clambda-case-body cls*))] - [(function fml* proper body) (Expr body)] - [(primcall rator rand*) (Expr* rand*)] - [(funcall rator rand*) - (union (Expr rator) (Expr* rand*))] - [(appcall rator rand*) - (union (Expr rator) (Expr* rand*))] - [(forcall rator rand*) (Expr* rand*)] - [(assign lhs rhs) - (union (singleton lhs) (Expr rhs))] - [else (error who "invalid expression ~s" (unparse x))])) - (Expr x)) - -(define (rewrite-assignments assigned x) - (define who 'rewrite-assignments) - (define (fix lhs*) - (cond - [(null? lhs*) (values '() '() '())] - [else - (let ([x (car lhs*)]) - (let-values ([(lhs* a-lhs* a-rhs*) (fix (cdr lhs*))]) - (cond - [(memq x assigned) - (let ([t (make-var 'assignment-tmp)]) - (values (cons t lhs*) (cons x a-lhs*) (cons t a-rhs*)))] - [else - (values (cons x lhs*) a-lhs* a-rhs*)])))])) - (define (bind-assigned lhs* rhs* body) - (cond - [(null? lhs*) body] - [else - (make-bind lhs* - (map (lambda (rhs) (make-primcall 'vector (list rhs))) rhs*) - body)])) - (define (Expr x) - (record-case x - [(constant) x] - [(var) - (cond - [(memq x assigned) - (make-primcall '$vector-ref (list x (make-constant 0)))] - [else x])] - [(primref) x] - [(bind lhs* rhs* body) - (let-values ([(lhs* a-lhs* a-rhs*) (fix lhs*)]) - (make-bind lhs* (map Expr rhs*) - (bind-assigned a-lhs* a-rhs* (Expr body))))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (make-seq (Expr e0) (Expr e1))] - [(function fml* proper body) - (let-values ([(fml* a-lhs* a-rhs*) (fix fml*)]) - (make-function fml* proper - (bind-assigned a-lhs* a-rhs* (Expr body))))] - [(clambda cls*) - (make-clambda - (map (lambda (cls) - (record-case cls - [(clambda-case fml* proper body) - (let-values ([(fml* a-lhs* a-rhs*) (fix fml*)]) - (make-clambda-case fml* proper - (bind-assigned a-lhs* a-rhs* (Expr body))))])) - cls*))] - [(primcall op rand*) - (make-primcall op (map Expr rand*))] - [(forcall op rand*) - (make-forcall op (map Expr rand*))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(appcall rator rand*) - (make-appcall (Expr rator) (map Expr rand*))] - [(assign lhs rhs) - (unless (memq lhs assigned) - (error 'rewrite-assignments "not assigned ~s in ~s" lhs x)) - (make-primcall '$vector-set! (list lhs (make-constant 0) (Expr rhs)))] - [else (error who "invalid expression ~s" (unparse x))])) - (Expr x)) - - -(define (remove-assignments x) - (let ([assigned (uncover-assigned x)]) - (rewrite-assignments assigned x))) - - -(define (convert-closures prog) - (define who 'convert-closures) - (define (Expr* x*) - (cond - [(null? x*) (values '() '())] - [else - (let-values ([(a a-free) (Expr (car x*))] - [(d d-free) (Expr* (cdr x*))]) - (values (cons a d) (union a-free d-free)))])) - (define (Expr ex) - (record-case ex - [(constant) (values ex '())] - [(var) (values ex (singleton ex))] - [(primref) (values ex '())] - [(bind lhs* rhs* body) - (let-values ([(rhs* rhs-free) (Expr* rhs*)] - [(body body-free) (Expr body)]) - (values (make-bind lhs* rhs* body) - (union rhs-free (difference body-free lhs*))))] - [(conditional test conseq altern) - (let-values ([(test test-free) (Expr test)] - [(conseq conseq-free) (Expr conseq)] - [(altern altern-free) (Expr altern)]) - (values (make-conditional test conseq altern) - (union test-free (union conseq-free altern-free))))] - [(seq e0 e1) - (let-values ([(e0 e0-free) (Expr e0)] - [(e1 e1-free) (Expr e1)]) - (values (make-seq e0 e1) (union e0-free e1-free)))] - [(function fml* proper body) - (let-values ([(body body-free) (Expr body)]) - (let ([free (difference body-free fml*)]) - (values (make-closure (make-code-rec fml* proper free body) free) - free)))] - [(clambda cls*) - (let-values ([(cls* free) - (let f ([cls* cls*]) - (cond - [(null? cls*) (values '() '())] - [else - (record-case (car cls*) - [(clambda-case fml* proper body) - (let-values ([(body body-free) (Expr body)] - [(cls* cls*-free) (f (cdr cls*))]) - (values - (cons (make-clambda-case fml* proper body) - cls*) - (union (difference body-free fml*) - cls*-free)))])]))]) - (values (make-closure (make-clambda-code (gensym) cls* free) free) - free))] - [(primcall op rand*) - (let-values ([(rand* rand*-free) (Expr* rand*)]) - (values (make-primcall op rand*) rand*-free))] - [(forcall op rand*) - (let-values ([(rand* rand*-free) (Expr* rand*)]) - (values (make-forcall op rand*) rand*-free))] - [(funcall rator rand*) - (let-values ([(rator rat-free) (Expr rator)] - [(rand* rand*-free) (Expr* rand*)]) - (values (make-funcall rator rand*) - (union rat-free rand*-free)))] - [(appcall rator rand*) - (let-values ([(rator rat-free) (Expr rator)] - [(rand* rand*-free) (Expr* rand*)]) - (values (make-appcall rator rand*) - (union rat-free rand*-free)))] - [else (error who "invalid expression ~s" (unparse ex))])) - (let-values ([(prog free) (Expr prog)]) - (unless (null? free) - (error 'convert-closures "free vars ~s encountered in ~a" - free (unparse prog))) - prog)) - - -(define (lift-codes x) - (define who 'lift-codes) - (define all-codes '()) - (define (do-code x) - (record-case x - [(clambda-code label cls* free) - (let ([cls* (map - (lambda (x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (E body))])) - cls*)]) - (let ([g (make-code-loc label)]) - (set! all-codes - (cons (make-clambda-code label cls* free) all-codes)) - g))])) - (define (E x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(bind lhs* rhs* body) - (make-bind lhs* (map E rhs*) (E body))] - [(conditional test conseq altern) - (make-conditional (E test) (E conseq) (E altern))] - [(seq e0 e1) (make-seq (E e0) (E e1))] - [(closure c free) (make-closure (do-code c) free)] - [(primcall op rand*) (make-primcall op (map E rand*))] - [(forcall op rand*) (make-forcall op (map E rand*))] - [(funcall rator rand*) (make-funcall (E rator) (map E rand*))] - [(appcall rator rand*) (make-appcall (E rator) (map E rand*))] - [else (error who "invalid expression ~s" (unparse x))])) - (let ([x (E x)]) - (make-codes all-codes x))) - - - - -(define (syntactically-valid? op rand*) - (define (valid-arg-count? op rand*) - (let ([n (open-coded-primitive-args op)] [m (length rand*)]) - (cond - [(eq? n 'any) #t] - [(eq? n 'no-code) - (error 'syntactically-valid - "should not primcall non codable prim ~s" op)] - [(fixnum? n) - (cond - [(fx= n m) #t] - [else - (error 'compile - "Possible incorrect number of args in ~s" - (cons op (map unparse rand*))) - #f])] - [else (error 'do-primcall "BUG: what ~s" n)]))) - (define (check op pred?) - (lambda (arg) - (record-case arg - [(constant c) - (cond - [(pred? c) #t] - [else - (error 'compile "Possible argument error to primitive ~s" op) - #f])] - [(primref) - (cond - [(pred? (lambda (x) x)) #t] - [else - (error 'compile "Possible argument error to primitive ~s" op) - #f])] - [else #t]))) - (define (nonnegative-fixnum? n) - (and (fixnum? n) (fx>= n 0))) - (define (byte? n) - (and (fixnum? n) (fx<= 0 n) (fx<= n 127))) - (define (valid-arg-types? op rand*) - (case op - [(fixnum? immediate? boolean? char? vector? string? procedure? - null? pair? not cons eq? vector symbol? error eof-object eof-object? - void $unbound-object? code? $forward-ptr? bwp-object? - pointer-value) - '#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 - $make-tcbucket $tcbucket-key $tcbucket-val $tcbucket-next - $set-tcbucket-val! $set-tcbucket-next! $set-tcbucket-tconc!) - #t] - [else (error 'valid-arg-types? "unhandled op ~s" op)])) - (and (valid-arg-count? op rand*) - (or (null? rand*) - (valid-arg-types? op rand*)))) - - -;;; the output of simplify-operands differs from the input in that the -;;; operands to primcalls are all simple (variables, primrefs, or constants). -;;; funcalls to open-codable primrefs whos arguments are "ok" are converted to -;;; primcalls. - -(define (introduce-primcalls x) - (define who 'introduce-primcalls) - (define (simple? x) - (or (constant? x) (var? x) (primref? x))) - (define (Expr x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(closure) x] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (make-seq (Expr e0) (Expr e1))] - [(primcall op arg*) - (case op - ;[(values) - ; (if (fx= (length arg*) 1) - ; (Expr (car arg*)) - ; (begin - ; (warning 'compile "possible incorrect number of values") - ; (make-funcall (make-primref 'values) (map Expr arg*))))] - [else - (make-primcall op (map Expr arg*))])] - [(forcall op arg*) - (make-forcall op (map Expr arg*))] - [(funcall rator rand*) - (cond - [(and (primref? rator) - (open-codeable? (primref-name rator)) - (syntactically-valid? (primref-name rator) rand*)) - (Expr (make-primcall (primref-name rator) rand*))] - [else - (make-funcall (Expr rator) (map Expr rand*))])] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (Tail x) - (record-case x - [(constant) (make-return x)] - [(var) (make-return x)] - [(primref) (make-return x)] - [(closure) (make-return x)] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Tail body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Tail conseq) (Tail altern))] - [(seq e0 e1) (make-seq (Expr e0) (Tail e1))] - [(primcall op arg*) - (case op - ;[(values) - ; (if (fx= (length arg*) 1) - ; (make-return (Expr (car arg*))) - ; (make-return* (map Expr arg*)))] - [else - (make-return (make-primcall op (map Expr arg*)))])] - [(forcall op arg*) - (make-return (make-forcall op (map Expr arg*)))] - [(funcall rator rand*) - (cond - [(and (primref? rator) - (open-codeable? (primref-name rator)) - (syntactically-valid? (primref-name rator) rand*)) - (Tail (make-primcall (primref-name rator) rand*))] - [else - (make-funcall (Expr rator) (map Expr rand*))])] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (CaseExpr x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (Tail body))])) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (make-clambda-code L (map CaseExpr cases) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) (Tail body))])) - (CodesExpr x)) - - -(define (simplify-operands x) - (define who 'simplify-operands) - (define (simple? x) - (or (constant? x) (var? x) (primref? x))) - (define (simplify arg lhs* rhs* k) - (if (simple? arg) - (k arg lhs* rhs*) - (let ([v (unique-var 'tmp)]) - (k v (cons v lhs*) (cons (Expr arg) rhs*))))) - (define (simplify* arg* lhs* rhs* k) - (cond - [(null? arg*) (k '() lhs* rhs*)] - [else - (simplify (car arg*) lhs* rhs* - (lambda (a lhs* rhs*) - (simplify* (cdr arg*) lhs* rhs* - (lambda (d lhs* rhs*) - (k (cons a d) lhs* rhs*)))))])) - (define (Expr x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(closure) x] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (make-seq (Expr e0) (Expr e1))] - [(primcall op arg*) - (simplify* arg* '() '() - (lambda (arg* lhs* rhs*) - (make-bind^ lhs* rhs* - (make-primcall op arg*))))] - [(forcall op arg*) - (make-forcall op (map Expr arg*))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (Tail x) - (record-case x - [(return v) (make-return (Expr v))] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Tail body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Tail conseq) (Tail altern))] - [(seq e0 e1) (make-seq (Expr e0) (Tail e1))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (CaseExpr x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (Tail body))])) - (define (CodeExpr x) - (record-case x - [(clambda-code L clauses free) - (make-clambda-code L (map CaseExpr clauses) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) (Tail body))])) - (CodesExpr x)) - - -(define (insert-stack-overflow-checks x) - (define who 'insert-stack-overflow-checks) - (define (insert-check body) - (make-seq - (make-conditional - (make-primcall '$fp-overflow '()) - (make-funcall (make-primref 'do-stack-overflow) '()) - (make-primcall 'void '())) - body)) - (define (Expr x) - (record-case x - [(constant) #f] - [(var) #f] - [(primref) #f] - [(closure code free*) #f] - [(bind lhs* rhs* body) - (or (ormap Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (or (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (or (Expr e0) (Expr e1))] - [(primcall op arg*) (ormap Expr arg*)] - [(forcall op arg*) (ormap Expr arg*)] - [(funcall rator arg*) #t] - [(appcall rator arg*) #t] - [else (error who "invalid expression ~s" (unparse x))])) - (define (Tail x) - (record-case x - [(return v) (Expr v)] - [(bind lhs* rhs* body) - (or (ormap Expr rhs*) (Tail body))] - [(conditional test conseq altern) - (or (Expr test) (Tail conseq) (Tail altern))] - [(seq e0 e1) (or (Expr e0) (Tail e1))] - [(funcall rator arg*) (or (Expr rator) (ormap Expr arg*))] - [(appcall rator arg*) (or (Expr rator) (ormap Expr arg*))] - [else (error who "invalid tail expression ~s" (unparse x))])) - (define (CaseExpr x) - (record-case x - [(clambda-case fml* proper body) - (if (Tail body) - (make-clambda-case fml* proper (insert-check body)) - x)])) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (make-clambda-code L (map CaseExpr cases) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) - (if (Tail body) - (insert-check body) - body))])) - (CodesExpr x)) - - -(define (insert-allocation-checks x) - (define who 'insert-allocation-checks) - (define (check-bytes n var body) - (make-seq - (make-conditional - (make-primcall '$ap-check-bytes - (list (make-constant n) var)) - (make-funcall (make-primref 'do-overflow) - (list - (make-primcall '$fx+ - (list (make-constant n) var)))) - (make-primcall 'void '())) - body)) - (define (check-words n var body) - (make-seq - (make-conditional - (make-primcall '$ap-check-words - (list (make-constant n) var)) - (make-funcall (make-primref 'do-overflow-words) - (list - (make-primcall '$fx+ - (list (make-constant n) var)))) - (make-primcall 'void '())) - body)) - (define (check-const n body) - (make-seq - (make-conditional - (make-primcall '$ap-check-const - (list (make-constant n))) - (make-funcall (make-primref 'do-overflow) - (list (make-constant n))) - (make-primcall 'void '())) - body)) - (define (Expr x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(closure code free*) - (check-const (fx+ disp-closure-data (fx* (length free*) wordsize)) x)] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (make-seq (Expr e0) (Expr e1))] - [(primcall op arg*) - (let ([x (make-primcall op (map Expr arg*))]) - (case op - [(cons) (check-const pair-size x)] - [($make-symbol) (check-const symbol-size x)] - [($make-tcbucket) (check-const tcbucket-size x)] - [($frame->continuation $code->closure) - (check-const (fx+ disp-closure-data (fx* (length arg*) wordsize)) x)] - [($make-string) - (record-case (car arg*) - [(constant i) - (check-const (fx+ i (fx+ disp-string-data 1)) x)] - [else - (check-bytes (fxadd1 disp-string-data) (car arg*) x)])] - [($string) - (check-const (fx+ (length arg*) (fx+ disp-string-data 1)) x)] - [($make-vector) - (record-case (car arg*) - [(constant i) - (check-const (fx+ (fx* i wordsize) disp-vector-data) x)] - [else - (check-words (fxadd1 disp-vector-data) (car arg*) x)])] - [($make-record) - (record-case (cadr arg*) - [(constant i) - (check-const (fx+ (fx* i wordsize) disp-record-data) x)] - [else - (check-words (fxadd1 disp-record-data) (cadr arg*) x)])] - [(vector) - (check-const (fx+ (fx* (length arg*) wordsize) disp-vector-data) x)] - [else x]))] - [(forcall op arg*) - (make-forcall op (map Expr arg*))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (Tail x) - (record-case x - [(return v) (make-return (Expr v))] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Tail body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Tail conseq) (Tail altern))] - [(seq e0 e1) (make-seq (Expr e0) (Tail e1))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (CaseExpr x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (Tail body))])) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (make-clambda-code L (map CaseExpr cases) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) (Tail body))])) - (CodesExpr x)) - - -(define (remove-local-variables x) - (define who 'remove-local-variables) - (define (simple* x* r) - (map (lambda (x) - (cond - [(assq x r) => cdr] - [else - (when (var? x) (error who "unbound var ~s" x)) - x])) - x*)) - (define (env->mask r sz) - (let ([s (make-vector (fxsra (fx+ sz 7) 3) 0)]) - (for-each - (lambda (idx) - (let ([q (fxsra idx 3)] - [r (fxlogand idx 7)]) - (vector-set! s q - (fxlogor (vector-ref s q) (fxsll 1 r))))) - r) - s)) - (define (do-new-frame op rand* si r call-convention rp-convention orig-live) - (make-new-frame (fxadd1 si) (fx+ (length rand*) 2) - (let f ([r* rand*] [nsi (fx+ si 2)] [live orig-live]) - (cond - [(null? r*) - (make-seq - (make-seq - (make-save-cp (make-frame-var si)) - (case call-convention - [(normal apply) - (make-eval-cp #t (Expr op nsi r (cons si live)))] - [(foreign) - (make-eval-cp #f (make-foreign-label op))] - [else (error who "invalid convention ~s" convention)])) - (make-call-cp call-convention - rp-convention - (fxadd1 si) ; frame size - (length rand*) ; argc - (env->mask (cons si orig-live) ; cp and everything before it - (fxadd1 si))))] ; mask-size ~~ frame size - [else - (make-seq - (make-assign (make-frame-var nsi) - (Expr (car r*) nsi r live)) - (f (cdr r*) (fxadd1 nsi) (cons nsi live)))])))) - (define (nop) (make-primcall 'void '())) - (define (do-bind lhs* rhs* body si r live k) - (let f ([lhs* lhs*] [rhs* rhs*] [si si] [nr r] [live live]) - (cond - [(null? lhs*) (k body si nr live)] - [else - (let ([v (make-frame-var si)]) - (make-seq - (make-assign v (Expr (car rhs*) si r live)) - (f (cdr lhs*) (cdr rhs*) (fxadd1 si) - (cons (cons (car lhs*) v) nr) - (cons si live))))]))) - (define (Tail x si r live) - (record-case x - [(return v) (make-return (Expr v si r live))] - [(bind lhs* rhs* body) - (do-bind lhs* rhs* body si r live Tail)] - [(conditional test conseq altern) - (make-conditional - (Expr test si r live) - (Tail conseq si r live) - (Tail altern si r live))] - [(seq e0 e1) (make-seq (Effect e0 si r live) (Tail e1 si r live))] - [(primcall op arg*) - (case op -; [(values) (make-primcall op (simple* arg* r))] - [else (make-return (make-primcall op (simple* arg* r)))])] - [(funcall op rand*) - (do-new-frame op rand* si r 'normal 'tail live)] - [(appcall op rand*) - (do-new-frame op rand* si r 'apply 'tail live)] - [else (error who "invalid expression ~s" (unparse x))])) - (define (Effect x si r live) - (record-case x - [(constant) (nop)] - [(var) (nop)] - [(primref) (nop)] - [(closure code free*) (nop)] - [(bind lhs* rhs* body) - (do-bind lhs* rhs* body si r live Effect)] - [(conditional test conseq altern) - (make-conditional - (Expr test si r live) - (Effect conseq si r live) - (Effect altern si r live))] - [(seq e0 e1) (make-seq (Effect e0 si r live) (Effect e1 si r live))] - [(primcall op arg*) - (make-primcall op (simple* arg* r))] - [(forcall op rand*) - (do-new-frame op rand* si r 'foreign 'effect live)] - [(funcall op rand*) - (do-new-frame op rand* si r 'normal 'effect live)] - [(appcall op rand*) - (do-new-frame op rand* si r 'apply 'effect live)] - [else (error who "invalid effect expression ~s" (unparse x))])) - (define (Expr x si r live) - (record-case x - [(constant) x] - [(var) - (cond - [(assq x r) => cdr] - [else (error who "unbound var ~s" x)])] - [(primref) x] - [(closure code free*) - (make-closure code (simple* free* r))] - [(bind lhs* rhs* body) - (do-bind lhs* rhs* body si r live Expr)] - [(conditional test conseq altern) - (make-conditional - (Expr test si r live) - (Expr conseq si r live) - (Expr altern si r live))] - [(seq e0 e1) (make-seq (Effect e0 si r live) (Expr e1 si r live))] - [(primcall op arg*) - (make-primcall op (simple* arg* r))] - [(forcall op rand*) - (do-new-frame op rand* si r 'foreign 'value live)] - [(funcall op rand*) - (do-new-frame op rand* si r 'normal 'value live)] - [(appcall op rand*) - (do-new-frame op rand* si r 'apply 'value live)] - [else (error who "invalid expression ~s" (unparse x))])) - (define (bind-fml* fml* r) - (let f ([si 1] [fml* fml*]) - (cond - [(null? fml*) (values '() si r '())] - [else - (let-values ([(nfml* nsi r live) (f (fxadd1 si) (cdr fml*))]) - (let ([v (make-frame-var si)]) - (values (cons v nfml*) - nsi - (cons (cons (car fml*) v) r) - (cons si live))))]))) - (define (bind-free* free*) - (let f ([free* free*] [idx 0] [r '()]) - (cond - [(null? free*) r] - [else - (f (cdr free*) (fxadd1 idx) - (cons (cons (car free*) (make-cp-var idx)) r))]))) - (define CaseExpr - (lambda (r) - (lambda (x) - (record-case x - [(clambda-case fml* proper body) - (let-values ([(fml* si r live) (bind-fml* fml* r)]) - (make-clambda-case fml* proper (Tail body si r live)))])))) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (let ([r (bind-free* free)]) - (make-clambda-code L (map (CaseExpr r) cases) free))])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) - (Tail body 1 '() '()))])) - (CodesExpr x)) - - -(begin - (define fx-shift 2) - (define fx-mask #x03) - (define fx-tag 0) - (define bool-f #x2F) - (define bool-t #x3F) - (define bool-mask #xEF) - (define bool-tag bool-f) - (define bool-shift 4) - (define nil #x4F) - (define eof #x5F) ; double check - (define unbound #x6F) ; double check - (define void-object #x7F) ; double check - (define bwp-object #x8F) ; double check - (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 pagesize 4096) - (define pageshift 12) - (define wordsize 4) - (define wordshift 2) - - (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 disp-tcbucket-tconc 0) - (define disp-tcbucket-key 4) - (define disp-tcbucket-val 8) - (define disp-tcbucket-next 12) - (define tcbucket-size 16) - - (define record-ptag vector-tag) - (define record-pmask vector-mask) - (define disp-record-rtd 0) - (define disp-record-data 4) - (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) - (define dirty-word -1)) - -(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)] - [(dirty-vector) (mem 28 pcr)] - [else (error 'pcb-ref "invalid arg ~s" x)]))) - -(define (primref-loc op) - (unless (symbol? op) (error 'primref-loc "not a symbol ~s" op)) - (mem (fx- disp-symbol-system-value symbol-tag) - (obj op))) - -(define (generate-code x) - (define who 'generate-code) - (define (rp-label x) - (case x - [(value) (label-address SL_multiple_values_error_rp)] - [(effect) (label-address SL_multiple_values_ignore_rp)] - [else (error who "invalid rp-convention ~s" x)])) - (define (align n) - (fxsll (fxsra (fx+ n (fxsub1 object-alignment)) align-shift) align-shift)) - (define unique-label - (lambda () - (label (gensym)))) - (define (constant-val x) - (cond - [(fixnum? x) (obj x)] - [(boolean? x) (int (if x bool-t bool-f))] - [(null? x) (int nil)] - [(char? x) (int (fx+ (fxsll (char->integer x) char-shift) char-tag))] - [(eq? x (void)) (int void-object)] - [else (obj x)])) - (define (cond-branch op Lt Lf ac) - (define (opposite x) - (cadr (assq x '([je jne] [jl jge] [jle jg] [jg jle] [jge jl])))) - (unless (or Lt Lf) - (error 'cond-branch "no labels")) - (cond - [(not Lf) (cons (list op Lt) ac)] - [(not Lt) (cons (list (opposite op) Lf) ac)] - [else (list* (list op Lt) (jmp Lf) ac)])) - (define (indirect-type-pred pri-mask pri-tag sec-mask sec-tag rand* Lt Lf ac) - (cond - [(and Lt Lf) - (list* (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int pri-mask) ebx) - (cmpl (int pri-tag) ebx) - (jne Lf) - (movl (mem (fx- 0 pri-tag) eax) ebx) - (if sec-mask - (andl (int sec-mask) ebx) - '(nop)) - (cmpl (int sec-tag) ebx) - (jne Lf) - (jmp Lt) - ac)] - [Lf - (list* (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int pri-mask) ebx) - (cmpl (int pri-tag) ebx) - (jne Lf) - (movl (mem (fx- 0 pri-tag) eax) ebx) - (if sec-mask - (andl (int sec-mask) ebx) - '(nop)) - (cmpl (int sec-tag) ebx) - (jne Lf) - ac)] - [Lt - (let ([L_END (unique-label)]) - (list* (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int pri-mask) ebx) - (cmpl (int pri-tag) ebx) - (jne L_END) - (movl (mem (fx- 0 pri-tag) eax) ebx) - (if sec-mask - (andl (int sec-mask) ebx) - '(nop)) - (cmpl (int sec-tag) ebx) - (je Lt) - L_END - ac))] - [else ac])) - (define (type-pred mask tag rand* Lt Lf ac) - (cond - [mask - (list* - (movl (Simple (car rand*)) eax) - (andl (int mask) eax) - (cmpl (int tag) eax) - (cond-branch 'je Lt Lf ac))] - [else - (let ([v (Simple (car rand*))]) - (cond - [(memq (car v) '(mem register)) - (list* - (cmpl (int tag) (Simple (car rand*))) - (cond-branch 'je Lt Lf ac))] - [else - (list* - (movl (Simple (car rand*)) eax) - (cmpl (int tag) eax) - (cond-branch 'je Lt Lf ac))]))])) - (define (compare-and-branch op rand* Lt Lf ac) - (define (opposite x) - (cadr (assq x '([je je] [jl jg] [jle jge] [jg jl] [jge jle])))) - (cond - [(and (constant? (car rand*)) (constant? (cadr rand*))) - (list* - (movl (Simple (car rand*)) eax) - (cmpl (Simple (cadr rand*)) eax) - (cond-branch op Lt Lf ac))] - [(constant? (cadr rand*)) - (list* - (cmpl (Simple (cadr rand*)) (Simple (car rand*))) - (cond-branch op Lt Lf ac))] - [(constant? (car rand*)) - (list* - (cmpl (Simple (car rand*)) (Simple (cadr rand*))) - (cond-branch (opposite op) Lt Lf ac))] - [else - (list* - (movl (Simple (car rand*)) eax) - (cmpl (Simple (cadr rand*)) eax) - (cond-branch op Lt Lf ac))])) - (define (do-pred-prim op rand* Lt Lf ac) - (case op - [(fixnum?) (type-pred fx-mask fx-tag rand* Lt Lf ac)] - [(pair?) (type-pred pair-mask pair-tag rand* Lt Lf ac)] - [(char?) (type-pred char-mask char-tag rand* Lt Lf ac)] - [(string?) (type-pred string-mask string-tag rand* Lt Lf ac)] - [(symbol?) (type-pred symbol-mask symbol-tag rand* Lt Lf ac)] - [(procedure?) (type-pred closure-mask closure-tag rand* Lt Lf ac)] - [(boolean?) (type-pred bool-mask bool-tag rand* Lt Lf ac)] - [(null?) (type-pred #f nil rand* Lt Lf ac)] - [($unbound-object?) (type-pred #f unbound rand* Lt Lf ac)] - [($forward-ptr?) (type-pred #f -1 rand* Lt Lf ac)] - [(not) (type-pred #f bool-f rand* Lt Lf ac)] - [(eof-object?) (type-pred #f eof rand* Lt Lf ac)] - [(bwp-object?) (type-pred #f bwp-object 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)] - [(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)] - [($tcbucket-key) - (indirect-ref arg* (fx- disp-tcbucket-key vector-tag) ac)] - [($tcbucket-val) - (indirect-ref arg* (fx- disp-tcbucket-val vector-tag) ac)] - [($tcbucket-next) - (indirect-ref arg* (fx- disp-tcbucket-next vector-tag) ac)] - [(pointer-value) - (list* - (movl (Simple (car arg*)) eax) - (sarl (int fx-shift) eax) - (sall (int fx-shift) eax) - ac)] - [($symbol-plist) - (indirect-ref arg* (fx- disp-symbol-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-tcbucket) - (list* (movl (Simple (car arg*)) eax) - (movl eax (mem disp-tcbucket-tconc apr)) - (movl (Simple (cadr arg*)) eax) - (movl eax (mem disp-tcbucket-key apr)) - (movl (Simple (caddr arg*)) eax) - (movl eax (mem disp-tcbucket-val apr)) - (movl (Simple (cadddr arg*)) eax) - (movl eax (mem disp-tcbucket-next apr)) - (movl apr eax) - (addl (int vector-tag) eax) - (addl (int (align tcbucket-size)) apr) - ac)] - [(vector) - (let f ([arg* arg*] [idx disp-vector-data]) - (cond - [(null? arg*) - (list* (movl apr eax) - (addl (int vector-tag) eax) - (movl (int (fx- idx disp-vector-data)) - (mem disp-vector-length apr)) - (addl (int (align idx)) apr) - ac)] - [else - (list* (movl (Simple (car arg*)) eax) - (movl eax (mem idx apr)) - (f (cdr arg*) (fx+ idx wordsize)))]))] - [($string) - (let f ([arg* arg*] [idx disp-string-data]) - (cond - [(null? arg*) - (list* (movb (int 0) (mem idx apr)) - (movl apr eax) - (addl (int string-tag) eax) - (movl (int (fx* (fx- idx disp-string-data) wordsize)) - (mem disp-string-length apr)) - (addl (int (align (fxadd1 idx))) apr) - ac)] - [else - (record-case (car arg*) - [(constant c) - (unless (char? c) (error who "invalid arg to string ~s" x)) - (list* (movb (int (char->integer c)) (mem idx apr)) - (f (cdr arg*) (fxadd1 idx)))] - [else - (list* (movl (Simple (car arg*)) ebx) - (movb bh (mem idx apr)) - (f (cdr arg*) (fxadd1 idx)))])]))] - [($current-frame) - (list* (movl (pcb-ref 'next-continuation) eax) - ac)] - [($seal-frame-and-call) - (list* (movl (Simple (car arg*)) cpr) ; proc - (movl (pcb-ref 'frame-base) eax) - ; eax=baseofstack - (movl (mem (fx- 0 wordsize) eax) ebx) ; underflow handler - (movl ebx (mem (fx- 0 wordsize) fpr)) ; set - ; create a new cont record - (movl (int continuation-tag) (mem 0 apr)) - (movl fpr (mem disp-continuation-top apr)) - ; compute the size of the captured frame - (movl eax ebx) - (subl fpr ebx) - (subl (int wordsize) ebx) - ; and store it - (movl ebx (mem disp-continuation-size apr)) - ; load next cont - (movl (pcb-ref 'next-continuation) ebx) - ; and store it - (movl ebx (mem disp-continuation-next apr)) - ; adjust ap - (movl apr eax) - (addl (int vector-tag) eax) - (addl (int continuation-size) apr) - ; store new cont in current-cont - (movl eax (pcb-ref 'next-continuation)) - ; adjust fp - (movl fpr (pcb-ref 'frame-base)) - (subl (int wordsize) fpr) - ; tail-call f - (movl eax (mem (fx- 0 wordsize) fpr)) - (movl (int (argc-convention 1)) eax) - (tail-indirect-cpr-call) - ac)] - [($code-instr-size) - (indirect-ref arg* (fx- disp-code-instrsize vector-tag) - (cons (sall (int fx-shift) eax) ac))] - [($code-reloc-size) - (indirect-ref arg* (fx- disp-code-relocsize vector-tag) ac)] - [($code-closure-size) - (indirect-ref arg* (fx- disp-code-closuresize vector-tag) ac)] - [($set-car! $set-cdr! $vector-set! $string-set! $exit - $set-symbol-value! $set-symbol-plist! - $set-code-byte! $set-code-word! primitive-set! - $set-code-object! $set-code-object+offset! $set-code-object+offset/rel! - $record-set!) - (do-effect-prim op arg* - (cons (movl (int void-object) eax) ac))] - [(fixnum? immediate? $fxzero? boolean? char? pair? vector? string? symbol? - procedure? null? not eof-object? $fx= $fx< $fx<= $fx> $fx>= eq? - $char= $char< $char<= $char> $char>= $unbound-object? code? - $record? bwp-object?) - (do-pred->value-prim op arg* ac)] - [($code->closure) - (list* - (movl (Simple (car arg*)) eax) - (addl (int (fx- disp-code-data vector-tag)) eax) - (movl eax (mem 0 apr)) - (movl apr eax) - (addl (int closure-tag) eax) - (addl (int (align disp-closure-data)) apr) - ac)] - [($frame->continuation) - (NonTail - (make-closure (make-code-loc SL_continuation_code) arg*) - ac)] - [($make-call-with-values-procedure) - (NonTail - (make-closure (make-code-loc SL_call_with_values) arg*) - ac)] - [($make-values-procedure) - (NonTail - (make-closure (make-code-loc SL_values) arg*) - ac)] - [else - (error 'value-prim "unhandled ~s" op)])) - (define (indirect-assignment arg* offset ac) - (list* - (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem offset eax)) - ;;; record side effect - (addl (int offset) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)) - (define (do-effect-prim op arg* ac) - (case op - [($vector-set!) - (list* (movl (Simple (car arg*)) ebx) - (addl (Simple (cadr arg*)) ebx) - (addl (int (fx- disp-vector-data vector-tag)) ebx) - (movl (Simple (caddr arg*)) eax) - (movl eax (mem 0 ebx)) - ;;; record side effect - (shrl (int pageshift) ebx) - (sall (int wordshift) ebx) - (addl (pcb-ref 'dirty-vector) ebx) - (movl (int dirty-word) (mem 0 ebx)) - ac)] - [($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-car!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-car pair-tag) eax)) - ;;; record side effect - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-cdr!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-cdr pair-tag) eax)) - ;;; record side effect - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-tcbucket-key!) - (indirect-assignment arg* (fx- disp-tcbucket-key vector-tag) ac)] - [($set-tcbucket-val!) - (indirect-assignment arg* (fx- disp-tcbucket-val vector-tag) ac)] - [($set-tcbucket-next!) - (indirect-assignment arg* (fx- disp-tcbucket-next vector-tag) ac)] - [($set-tcbucket-tconc!) - (indirect-assignment arg* (fx- disp-tcbucket-tconc vector-tag) ac)] - - [($set-symbol-value!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-value symbol-tag) eax)) - ;;; record side effect - (addl (int (fx- disp-symbol-value symbol-tag)) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 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)) - ;;; record side effect - (addl (int (fx- disp-symbol-system-value symbol-tag)) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-symbol-plist!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-plist symbol-tag) eax)) - ;;; record side effect - (addl (int (fx- disp-symbol-plist symbol-tag)) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-symbol-unique-string!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-unique-string symbol-tag) eax)) - ;;; record side effect - (addl (int (fx- disp-symbol-unique-string symbol-tag)) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-symbol-string!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-string symbol-tag) eax)) - ;;; record side effect - (addl (int (fx- disp-symbol-string symbol-tag)) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($record-set!) - (list* (movl (Simple (car arg*)) ebx) - (addl (Simple (cadr arg*)) ebx) - (movl (Simple (caddr arg*)) eax) - (addl (int (fx- disp-record-data record-ptag)) ebx) - (movl eax (mem 0 ebx)) - ;;; record side effect - (shrl (int pageshift) ebx) - (sall (int wordshift) ebx) - (addl (pcb-ref 'dirty-vector) ebx) - (movl (int dirty-word) (mem 0 ebx)) - ac)] - [(cons void $fxadd1 $fxsub1) - (let f ([arg* arg*]) - (cond - [(null? arg*) ac] - [else - (Effect (car arg*) (f (cdr arg*)))]))] - [else - (error 'do-effect-prim "unhandled op ~s" op)])) - (define (do-simple-test x Lt Lf ac) - (unless (or Lt Lf) - (error 'Pred "no labels")) - (cond - [(not Lt) - (list* (cmpl (int bool-f) x) (je Lf) ac)] - [(not Lf) - (list* (cmpl (int bool-f) x) (jne Lt) ac)] - [else - (list* (cmpl (int bool-f) x) (je Lf) (jmp Lt) ac)])) - (define (Simple x) - (record-case x - [(cp-var i) - (mem (fx+ (fx* i wordsize) (fx- disp-closure-data closure-tag)) cpr)] - [(frame-var i) (mem (fx* i (fx- 0 wordsize)) fpr)] - [(constant c) (constant-val c)] - [(code-loc label) (label-address label)] - [(primref op) (primref-loc op)] - [else (error 'Simple "what ~s" x)])) - (define (frame-adjustment offset) - (fx* (fxsub1 offset) (fx- 0 wordsize))) - (define (NonTail x ac) - (record-case x - [(constant c) - (cons (movl (constant-val c) eax) ac)] - [(frame-var) - (cons (movl (Simple x) eax) ac)] - [(cp-var) - (cons (movl (Simple x) eax) ac)] - [(foreign-label L) - (cons (movl (list 'foreign-label L) eax) ac)] - [(primref c) - (cons (movl (primref-loc c) eax) ac)] - [(closure label arg*) - (let f ([arg* arg*] [off disp-closure-data]) - (cond - [(null? arg*) - (list* (movl (Simple label) (mem 0 apr)) - (movl apr eax) - (addl (int (align off)) apr) - (addl (int closure-tag) eax) - ac)] - [else - (list* (movl (Simple (car arg*)) eax) - (movl eax (mem off apr)) - (f (cdr arg*) (fx+ off wordsize)))]))] - [(conditional test conseq altern) - (let ([Lj (unique-label)] [Lf (unique-label)]) - (Pred test #f Lf - (NonTail conseq - (list* (jmp Lj) Lf (NonTail altern (cons Lj ac))))))] - [(seq e0 e1) - (Effect e0 (NonTail e1 ac))] - [(primcall op rand*) - (do-value-prim op rand* ac)] - [(new-frame base-idx size body) - (NonTail body ac)] - [(call-cp call-convention rp-convention offset size mask) - (let ([L_CALL (unique-label)]) - (case call-convention - [(normal) - (list* (addl (int (frame-adjustment offset)) fpr) - (movl (int (argc-convention size)) eax) - (jmp L_CALL) - ; NEW FRAME - `(byte-vector ,mask) - `(int ,(fx* offset wordsize)) - `(current-frame-offset) - (rp-label rp-convention) - `(byte 0) ; padding for indirect calls only - `(byte 0) ; direct calls are ok - L_CALL - (indirect-cpr-call) - (movl (mem 0 fpr) cpr) - (subl (int (frame-adjustment offset)) fpr) - ac)] - [(apply) are-we-ever-here? - (list* (addl (int (frame-adjustment offset)) fpr) - (movl (int (argc-convention size)) eax) - (jmp L_CALL) - ; NEW FRAME - (byte-vector mask) - `(int ,(fx* offset wordsize)) - `(current-frame-offset) - (rp-label rp-convention) - L_CALL - (call (label SL_apply)) - (movl (mem 0 fpr) cpr) - (subl (int (frame-adjustment offset)) fpr) - ac)] - [(foreign) - (list* (addl (int (frame-adjustment offset)) fpr) - (movl (int (argc-convention size)) eax) - (movl '(foreign-label "ik_foreign_call") ebx) - (jmp L_CALL) - ; NEW FRAME - (byte-vector mask) - `(int ,(fx* offset wordsize)) - `(current-frame-offset) - (rp-label rp-convention) ; should be 0, since C has 1 rv - '(byte 0) - '(byte 0) - '(byte 0) - L_CALL - (call ebx) - (movl (mem 0 fpr) cpr) - (subl (int (frame-adjustment offset)) fpr) - ac)] - [else (error who "invalid convention ~s for call-cp" convention)]))] - [else (error 'NonTail "invalid expression ~s" x)])) - (define (Pred x Lt Lf ac) - (record-case x - [(frame-var i) - (do-simple-test (idx->frame-loc i) Lt Lf ac)] - [(cp-var i) - (do-simple-test (Simple x) Lt Lf ac)] - [(constant c) - (if c - (if Lt (cons (jmp Lt) ac) ac) - (if Lf (cons (jmp Lf) ac) ac))] - [(primcall op rand*) - (do-pred-prim op rand* Lt Lf ac)] - [(conditional test conseq altern) - (cond - [(not Lt) - (let ([Lj^ (unique-label)] [Lf^ (unique-label)]) - (Pred test #f Lf^ - (Pred conseq Lj^ Lf - (cons Lf^ - (Pred altern #f Lf - (cons Lj^ ac))))))] - [(not Lf) - (let ([Lj^ (unique-label)] [Lf^ (unique-label)]) - (Pred test #f Lf^ - (Pred conseq Lt Lj^ - (cons Lf^ - (Pred altern Lt #f - (cons Lj^ ac))))))] - [else - (let ([Lf^ (unique-label)]) - (Pred test #f Lf^ - (Pred conseq Lt Lf - (cons Lf^ - (Pred altern Lt Lf ac)))))])] - [(seq e0 e1) - (Effect e0 (Pred e1 Lt Lf ac))] - [(new-frame) - (NonTail x (do-simple-test eax Lt Lf ac))] - [else (error 'Pred "invalid expression ~s" x)])) - (define (idx->frame-loc i) - (mem (fx* i (fx- 0 wordsize)) fpr)) - (define (Effect x ac) - (record-case x - [(constant) ac] - [(primcall op rand*) - (do-effect-prim op rand* ac)] - [(conditional test conseq altern) - (let ([Lf (unique-label)] [Ljoin (unique-label)]) - (Pred test #f Lf - (Effect conseq - (list* (jmp Ljoin) Lf (Effect altern (cons Ljoin ac))))))] - [(seq e0 e1) - (Effect e0 (Effect e1 ac))] - [(assign loc val) - (record-case loc - [(frame-var i) - (NonTail val - (cons (movl eax (idx->frame-loc i)) ac))] - [else (error who "invalid assign loc ~s" loc)])] - [(eval-cp check body) - (NonTail body - (cond - [check - (list* - (movl eax cpr) - (andl (int closure-mask) eax) - (cmpl (int closure-tag) eax) - (jne (label SL_nonprocedure)) - ac)] - [else - (list* - (movl eax cpr) - ac)]))] - [(save-cp loc) - (record-case loc - [(frame-var i) - (cons (movl cpr (idx->frame-loc i)) ac)] - [else (error who "invalid cpr loc ~s" x)])] - [(new-frame) (NonTail x ac)] - [(frame-var) ac] - [else (error 'Effect "invalid expression ~s" x)])) - (define (Tail x ac) - (record-case x - [(return x) - (NonTail x (cons (ret) ac))] - [(conditional test conseq altern) - (let ([L (unique-label)]) - (Pred test #f L - (Tail conseq - (cons L (Tail altern ac)))))] - [(seq e0 e1) - (Effect e0 (Tail e1 ac))] - [(new-frame idx size body) - (Tail body ac)] - [(call-cp call-convention rp-convention idx argc mask) - (unless (eq? rp-convention 'tail) - (error who "nontail rp (~s) in tail context" rp-convention)) - (let f ([i 0]) - (cond - [(fx= i argc) - (case call-convention - [(normal) - (list* - (movl (int (argc-convention argc)) eax) - (tail-indirect-cpr-call) - ac)] - [(apply) - (list* - (movl (int (argc-convention argc)) eax) - (jmp (label SL_apply)) - ac)] - [else (error who "invalid conv ~s in tail call-cpr" convention)])] - [else - (list* (movl (mem (fx* (fx+ idx (fxadd1 i)) - (fx- 0 wordsize)) fpr) - eax) - (movl eax (mem (fx* (fx+ i 1) (fx- 0 wordsize)) fpr)) - (f (fxadd1 i)))]))] - [else (error 'Tail "invalid expression ~s" x)])) - (define (handle-vararg fml-count ac) - (define CONTINUE_LABEL (unique-label)) - (define DONE_LABEL (unique-label)) - (define CONS_LABEL (unique-label)) - (define LOOP_HEAD (unique-label)) - (define L_CALL (unique-label)) - (list* (cmpl (int (argc-convention (fxsub1 fml-count))) eax) - (jg (label SL_invalid_args)) - (jl CONS_LABEL) - (movl (int nil) ebx) - (jmp DONE_LABEL) - CONS_LABEL - (movl (pcb-ref 'allocation-redline) ebx) - (addl eax ebx) - (addl eax ebx) - (cmpl ebx apr) - (jle LOOP_HEAD) - ; overflow - (addl eax esp) ; advance esp to cover args - (pushl cpr) ; push current cp - (pushl eax) ; push argc - (negl eax) ; make argc positive - (addl (int (fx* 4 wordsize)) eax) ; add 4 words to adjust frame size - (pushl eax) ; push frame size - (addl eax eax) ; double the number of args - (movl eax (mem (fx* -2 wordsize) fpr)) ; pass it as first arg - (movl (int (argc-convention 1)) eax) ; setup argc - (movl (primref-loc 'do-vararg-overflow) cpr) ; load handler - (jmp L_CALL) ; go to overflow handler - ; NEW FRAME - (int 0) ; if the framesize=0, then the framesize is dynamic - '(current-frame-offset) - (int 0) ; multiarg rp - (byte 0) - (byte 0) - L_CALL - (indirect-cpr-call) - (popl eax) ; pop framesize and drop it - (popl eax) ; reload argc - (popl cpr) ; reload cp - (subl eax fpr) ; readjust fp - LOOP_HEAD - (movl (int nil) ebx) - CONTINUE_LABEL - (movl ebx (mem disp-cdr apr)) - (movl (mem fpr eax) ebx) - (movl ebx (mem disp-car apr)) - (movl apr ebx) - (addl (int pair-tag) ebx) - (addl (int pair-size) apr) - (addl (int (fxsll 1 fx-shift)) eax) - (cmpl (int (fx- 0 (fxsll fml-count fx-shift))) eax) - (jle CONTINUE_LABEL) - DONE_LABEL - (movl ebx (mem (fx- 0 (fxsll fml-count fx-shift)) fpr)) - ac)) - (define (Entry check? x ac) - (record-case x - [(clambda-case fml* proper body) - (let ([ac (Tail body ac)]) - (cond - [(and proper check?) - (list* (cmpl (int (argc-convention (length fml*))) eax) - (jne (label SL_invalid_args)) - ac)] - [proper ac] - [else - (handle-vararg (length fml*) ac)]))])) - (define make-dispatcher - (lambda (j? L L* x x* ac) - (cond - [(null? L*) (if j? (cons (jmp (label L)) ac) ac)] - [else - (record-case x - [(clambda-case fml* proper _) - (cond - [proper - (list* (cmpl (int (argc-convention (length fml*))) eax) - (je (label L)) - (make-dispatcher #t - (car L*) (cdr L*) (car x*) (cdr x*) ac))] - [else - (list* (cmpl (int (argc-convention (fxsub1 (length fml*)))) eax) - (jle (label L)) - (make-dispatcher #t - (car L*) (cdr L*) (car x*) (cdr x*) ac))])])]))) - (define (handle-cases x x*) - (let ([L* (map (lambda (_) (gensym)) x*)] - [L (gensym)]) - (make-dispatcher #f L L* x x* - (let f ([x x] [x* x*] [L L] [L* L*]) - (cond - [(null? x*) - (cons (label L) (Entry 'check x '()))] - [else - (cons (label L) - (Entry #f x - (f (car x*) (cdr x*) (car L*) (cdr L*))))]))))) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (list* - (fx+ disp-closure-data (fx* wordsize (length free))) - (label L) - (handle-cases (car cases) (cdr cases)))])) - (record-case x - [(codes list body) - (cons (cons 0 (Tail body '())) - (map CodeExpr list))])) - - -(define SL_nonprocedure (gensym "SL_nonprocedure")) -(define SL_invalid_args (gensym "SL_invalid_args")) -(define SL_foreign_call (gensym "SL_foreign_call")) -(define SL_continuation_code (gensym "SL_continuation_code")) -(define SL_multiple_values_error_rp (gensym "SL_multiple_values_error_rp")) -(define SL_multiple_values_ignore_rp (gensym "SL_multiple_ignore_error_rp")) -(define SL_underflow_multiple_values (gensym "SL_underflow_multiple_values")) -(define SL_underflow_handler (gensym "SL_underflow_handler")) -(define SL_scheme_exit (gensym "SL_scheme_exit")) -(define SL_apply (gensym "SL_apply")) -(define SL_values (gensym "SL_values")) -(define SL_call_with_values (gensym "SL_call_with_values")) - -(list*->code* - (list - (let ([L_cwv_done (gensym)] - [L_cwv_loop (gensym)] - [L_cwv_multi_rp (gensym)] - [L_cwv_call (gensym)] - ) - (list disp-closure-data - (label SL_call_with_values) - (cmpl (int (argc-convention 2)) eax) - (jne (label SL_invalid_args)) - (movl (mem (fx- 0 wordsize) fpr) ebx) ; producer - (movl ebx cpr) - (andl (int closure-mask) ebx) - (cmpl (int closure-tag) ebx) - (jne (label SL_nonprocedure)) - (movl (int (argc-convention 0)) eax) - (subl (int (fx* wordsize 2)) fpr) - (jmp (label L_cwv_call)) - ; MV NEW FRAME - (byte-vector '#(#b110)) - (int (fx* wordsize 3)) - '(current-frame-offset) - (label-address L_cwv_multi_rp) - (byte 0) - (byte 0) - (label L_cwv_call) - (indirect-cpr-call) - ;;; one value returned - (addl (int (fx* wordsize 2)) fpr) - (movl (mem (fx* -2 wordsize) fpr) ebx) ; consumer - (movl ebx cpr) - (movl eax (mem (fx- 0 wordsize) fpr)) - (movl (int (argc-convention 1)) eax) - (andl (int closure-mask) ebx) - (cmpl (int closure-tag) ebx) - (jne (label SL_nonprocedure)) - (tail-indirect-cpr-call) - ;;; multiple values returned - (label L_cwv_multi_rp) - ; because values does not pop the return point - ; we have to adjust fp one more word here - (addl (int (fx* wordsize 3)) fpr) - (movl (mem (fx* -2 wordsize) fpr) cpr) ; consumer - (cmpl (int (argc-convention 0)) eax) - (je (label L_cwv_done)) - (movl (int (fx* -4 wordsize)) ebx) - (addl fpr ebx) ; ebx points to first value - (movl ebx ecx) - (addl eax ecx) ; ecx points to the last value - (label L_cwv_loop) - (movl (mem 0 ebx) edx) - (movl edx (mem (fx* 3 wordsize) ebx)) - (subl (int wordsize) ebx) - (cmpl ecx ebx) - (jge (label L_cwv_loop)) - (label L_cwv_done) - (movl cpr ebx) - (andl (int closure-mask) ebx) - (cmpl (int closure-tag) ebx) - (jne (label SL_nonprocedure)) - (tail-indirect-cpr-call))) - - (let ([L_values_one_value (gensym)] - [L_values_many_values (gensym)]) - (list disp-closure-data - (label SL_values) - (cmpl (int (argc-convention 1)) eax) - (je (label L_values_one_value)) - (label L_values_many_values) - (movl (mem 0 fpr) ebx) ; return point - (jmp (mem disp-multivalue-rp ebx)) ; go - (label L_values_one_value) - (movl (mem (fx- 0 wordsize) fpr) eax) - (ret))) - - (let ([L_apply_done (gensym)] - [L_apply_loop (gensym)]) - (list 0 - (label SL_apply) - (movl (mem fpr eax) ebx) - (cmpl (int nil) ebx) - (je (label L_apply_done)) - (label L_apply_loop) - (movl (mem (fx- disp-car pair-tag) ebx) ecx) - (movl (mem (fx- disp-cdr pair-tag) ebx) ebx) - (movl ecx (mem fpr eax)) - (subl (int wordsize) eax) - (cmpl (int nil) ebx) - (jne (label L_apply_loop)) - (label L_apply_done) - (addl (int wordsize) eax) - (tail-indirect-cpr-call))) - - (list 0 - (label SL_nonprocedure) - (movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg - (movl (primref-loc '$apply-nonprocedure-error-handler) cpr) - (movl (int (argc-convention 1)) eax) - (tail-indirect-cpr-call)) - - (list 0 - (label SL_multiple_values_error_rp) - (movl (primref-loc '$multiple-values-error) cpr) - (tail-indirect-cpr-call)) - - (list 0 - (label SL_multiple_values_ignore_rp) - (ret)) - - (list 0 - (label SL_invalid_args) - ;;; - (movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg - (negl eax) - (movl eax (mem (fx- 0 (fx* 2 wordsize)) fpr)) - (movl (primref-loc '$incorrect-args-error-handler) cpr) - (movl (int (argc-convention 2)) eax) - (tail-indirect-cpr-call)) - - (let ([Lset (gensym)] [Lloop (gensym)]) - (list 0 - (label SL_foreign_call) - (movl fpr (pcb-ref 'frame-pointer)) - (movl apr (pcb-ref 'allocation-pointer)) - (movl fpr ebx) - (movl (pcb-ref 'system-stack) esp) - (pushl pcr) - (cmpl (int 0) eax) - (je (label Lset)) - (label Lloop) - (movl (mem ebx eax) ecx) - (pushl ecx) - (addl (int 4) eax) - (cmpl (int 0) eax) - (jne (label Lloop)) - (label Lset) - ; FOREIGN NEW FRAME - (call cpr) - (movl (pcb-ref 'frame-pointer) fpr) - (movl (pcb-ref 'allocation-pointer) apr) - (ret))) - - (let ([L_cont_zero_args (gensym)] - [L_cont_mult_args (gensym)] - [L_cont_one_arg (gensym)] - [L_cont_mult_move_args (gensym)] - [L_cont_mult_copy_loop (gensym)]) - (list - (fx+ disp-closure-data wordsize) - (label SL_continuation_code) - (movl (mem (fx- disp-closure-data closure-tag) cpr) ebx) ; captured-k - (movl ebx (pcb-ref 'next-continuation)) ; set - (movl (pcb-ref 'frame-base) ebx) - (cmpl (int (argc-convention 1)) eax) - (jg (label L_cont_zero_args)) - (jl (label L_cont_mult_args)) - (label L_cont_one_arg) - (movl (mem (fx- 0 wordsize) fpr) eax) - (movl ebx fpr) - (subl (int wordsize) fpr) - (ret) - (label L_cont_zero_args) - (subl (int wordsize) ebx) - (movl ebx fpr) - (movl (mem 0 ebx) ebx) ; return point - (jmp (mem disp-multivalue-rp ebx)) ; go - (label L_cont_mult_args) - (subl (int wordsize) ebx) - (cmpl ebx fpr) - (jne (label L_cont_mult_move_args)) - (movl (mem 0 ebx) ebx) - (jmp (mem disp-multivalue-rp ebx)) - (label L_cont_mult_move_args) - ; move args from fpr to ebx - (movl (int 0) ecx) - (label L_cont_mult_copy_loop) - (subl (int wordsize) ecx) - (movl (mem fpr ecx) edx) - (movl edx (mem ebx ecx)) - (cmpl ecx eax) - (jne (label L_cont_mult_copy_loop)) - (movl ebx fpr) - (movl (mem 0 ebx) ebx) - (jmp (mem disp-multivalue-rp ebx)) - )) - )) - - - -(define (compile-program original-program) - (let* (;;; - [p (expand original-program)] - [p (recordize p)] - ;[f (pretty-print (unparse p))] - [p (optimize-direct-calls p)] - [p (remove-assignments p)] - [p (convert-closures p)] - [p (lift-codes p)] - ;[p (lift-complex-constants p)] - [p (introduce-primcalls p)] - [p (simplify-operands p)] - ;[f (pretty-print (unparse p))] - [p (insert-stack-overflow-checks p)] - [p (insert-allocation-checks p)] - [p (remove-local-variables p)] - ;[f (pretty-print (unparse p))] - [ls* (generate-code p)] - [f (when (assembler-output) - (for-each - (lambda (ls) - (for-each (lambda (x) (printf " ~s\n" x)) ls)) - ls*))] - [code* (list*->code* ls*)]) - (fasl-write (car code*) (compile-port)))) - - -(define compile-expr - (lambda (expr output-file) - (let ([op (open-output-file output-file 'replace)]) - (parameterize ([compile-port op]) - (compile-program expr)) - (close-output-port op)))) - -(define compile-file - (lambda (input-file output-file) - (let ([ip (open-input-file input-file)] - [op (open-output-file output-file 'replace)]) - (parameterize ([compile-port op]) - (let f () - (let ([x (read ip)]) - (unless (eof-object? x) - (compile-program x) - (f))))) - (close-input-port ip) - (close-output-port op)))) - - -(parameterize ([assembler-output #f]) - (for-each - (lambda (x) - (printf "compiling ~a ...\n" x) - (compile-file (car x) (cadr x))) - scheme-library-files)) - -(system "rm -f ikarus.fasl") - -(for-each - (lambda (x) - (system (format "cat ~a >> ikarus.fasl" (cadr x)))) - scheme-library-files) - - - -(define replace-safe-prims-with-unsafe - (lambda (x) - (define prims - '([fx+ $fx+] [fx- $fx-] [fx* $fx*] [fxadd1 $fxadd1] [fxsub1 $fxsub1] - [fxlogand $fxlogand] [fxlogor $fxlogor] [fxlognot $fxlognot] - [fx= $fx=] [fx< $fx<] [fx<= $fx<=] [fx> $fx>] [fx>= $fx>=] - [fxzero? $fxzero?] - [fixnum->char $fixnum->char] [char->fixnum $char->fixnum] - [char= $char=] - [char< $char<] [char> $char>] [char<= $char<=] [char>= $char>=] - [car $car] [cdr $cdr] [set-car! $set-car!] [set-cdr! $set-cdr!] - [vector-length $vector-length] [vector-ref $vector-ref] - [vector-set! $vector-set!] [make-vector $make-vector] - [string-length $string-length] [string-ref $string-ref] - [string-set! $string-set!] [make-string $make-string] - )) - (define (E x) - (cond - [(pair? x) (cons (E (car x)) (E (cdr x)))] - [(symbol? x) - (cond - [(assq x prims) => cadr] - [else x])] - [else x])) - (E x))) - -(parameterize ([input-filter - (lambda (x) - `(begin (write (eval ',x)) (newline) (exit 0)))]) - (test-all)) - -(define (get-date) - (system "date +\"%F\" > build-date.tmp") - (let ([ip (open-input-file "build-date.tmp")]) - (list->string - (let f () - (let ([x (read-char ip)]) - (if (char=? x #\newline) - '() - (cons x (f)))))))) - -(compile-expr - `(begin - (display ,(format "Petite Ikarus Scheme (Build ~a)\n" (get-date))) - (display "Copyright (c) 2006 Abdulaziz Ghuloum\n\n") - (new-cafe)) - "petite-ikarus.fasl") diff --git a/src/compiler-6.3.ss b/src/compiler-6.3.ss deleted file mode 100644 index 88e1083..0000000 --- a/src/compiler-6.3.ss +++ /dev/null @@ -1,3199 +0,0 @@ - - -;;; 6.2: * side-effects now modify the dirty-vector -;;; * added bwp-object? -;;; * added pointer-value -;;; * added tcbuckets -;;; 6.1: * added case-lambda, dropped lambda -;;; 6.0: * basic compiler - -(when (eq? "" "") - (load "chez-compat.ss") - (set! primitive-ref top-level-value) - (set! primitive-set! set-top-level-value!) - (set! chez-expand sc-expand) - (printf "loading psyntax.pp ...\n") - (load "psyntax-7.1.pp") - (current-expand - (lambda (x . args) - (apply chez-expand (sc-expand x) args))) - (printf "loading psyntax.ss ...\n") - (load "psyntax-7.1.ss") - (current-expand - (lambda (x . args) - (apply chez-expand (sc-expand x) args))) - (printf "ok\n")) - -(define primitive-set! set-top-level-value!) -(load "record-case.ss") - -(load "libassembler-compat-6.0.ss") ; defines make-code etc. -(load "libintelasm-6.0.ss") ; uses make-code, etc. -(load "libfasl-6.0.ss") ; uses code? etc. - - - -(load "tests-driver.ss") -(print-gensym #f) -(gensym-prefix "L_") - - -(define assembler-output (make-parameter #t)) - -(load "set-operations.ss") -;(load "tests-5.6-req.scm") -;(load "tests-5.3-req.scm") -;(load "tests-5.2-req.scm") -;(load "tests-5.1-req.scm") -;(load "tests-4.3-req.scm") -;(load "tests-4.2-req.scm") - -;(load "tests-4.1-req.scm") -;(load "tests-3.4-req.scm") - -;(load "tests-3.3-req.scm") -;(load "tests-3.2-req.scm") -;(load "tests-3.1-req.scm") -;(load "tests-2.9-req.scm") -;(load "tests-2.8-req.scm") -;(load "tests-2.6-req.scm") -;(load "tests-2.4-req.scm") -;(load "tests-2.3-req.scm") -;(load "tests-2.2-req.scm") -;(load "tests-2.1-req.scm") -;(load "tests-1.9-req.scm") -;(load "tests-1.8-req.scm") -;(load "tests-1.7-req.scm") -;(load "tests-1.6-req.scm") -;(load "tests-1.5-req.scm") -;(load "tests-1.4-req.scm") -;(load "tests-1.3-req.scm") -;(load "tests-1.2-req.scm") -;(load "tests-1.1-req.scm") - - -(define scheme-library-files - '(["libhandlers-6.0.ss" "libhandlers.fasl"] - ["libcontrol-6.1.ss" "libcontrol.fasl"] - ["libcollect-6.1.ss" "libcollect.fasl"] - ["librecord-6.1.ss" "librecord.fasl"] - ["libcxr-6.0.ss" "libcxr.fasl"] - ["libcore-6.2.ss" "libcore.fasl"] - ["libio-6.1.ss" "libio.fasl"] - ["libwriter-6.2.ss" "libwriter.fasl"] - ["libtokenizer-6.1.ss" "libtokenizer.fasl"] - ;["libexpand-6.2.ss" "libexpand.fasl"] - ;["libcompile-6.4.ss" "libcompile.fasl"] - ["psyntax-7.1.ss" "psyntax.fasl"] - ["libinterpret-6.1.ss" "libinterpret.fasl"] - ;["libintelasm-6.0.ss" "libintelasm.fasl"] - ["libcafe-6.1.ss" "libcafe.fasl"] -; ["libtrace-5.3.ss" "libtrace-5.3.s" "libtrace" ] - ["libposix-6.0.ss" "libposix.fasl"] - ["libhash-6.2.ss" "libhash.fasl"] - ["libtoplevel-6.0.ss" "libtoplevel.fasl"] - )) - -(define primitive? - (lambda (x) - (or (assq x open-coded-primitives) - (memq x public-primitives)))) - -(define open-coded-primitives -;;; these primitives, when found in operator position with the correct -;;; number of arguments, will be open-coded by the generator. If an -;;; incorrect number of args is detected, or if they appear in non-operator -;;; position, then they cannot be open-coded, and the pcb-primitives table -;;; is consulted for a reference of the pcb slot containing the primitive. -;;; If it's not found there, an error is signalled. -;;; -;;; prim-name args - '([$constant-ref 1 value] - [$constant-set! 2 effect] - [$pcb-ref 1 value] - [$pcb-set! 2 effect] - ;;; type predicates - [fixnum? 1 pred] - [immediate? 1 pred] - [boolean? 1 pred] - [char? 1 pred] - [pair? 1 pred] - [symbol? 1 pred] - [vector? 1 pred] - [string? 1 pred] - [procedure? 1 pred] - [null? 1 pred] - [eof-object? 1 pred] - [bwp-object? 1 pred] - [$unbound-object? 1 pred] - [$forward-ptr? 1 pred] - [not 1 pred] - [pointer-value 1 value] - [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] - ;;; tcbuckets - [$make-tcbucket 4 value] - [$tcbucket-key 1 value] - [$tcbucket-val 1 value] - [$tcbucket-next 1 value] - [$set-tcbucket-val! 2 effect] - [$set-tcbucket-next! 2 effect] - [$set-tcbucket-tconc! 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] - ;;; - ;;; asm - ;;; - ;[code? 1 pred] - ;[$code-instr-size 1 value] - ;[$code-reloc-size 1 value] - ;[$code-closure-size 1 value] - ;[$code->closure 1 value] - ;[$set-code-byte! 3 effect] - ;[$set-code-word! 3 effect] - ;[$set-code-object! 4 effect] - ;[$set-code-object+offset! 5 effect] - ;[$set-code-object+offset/rel! 5 effect] - ;;; - [$make-call-with-values-procedure 0 value] - [$make-values-procedure 0 value] - [$install-underflow-handler 0 effect] - )) - -(define (primitive-context x) - (cond - [(assq x open-coded-primitives) => caddr] - [else (error 'primitive-context "unknown prim ~s" x)])) - - -;;; primitives table section -(define primitives-table - '(;;; system locations used by the C/Scheme interface - [$apply-nonprocedure-error-handler library] - [$incorrect-args-error-handler library] - [$multiple-values-error library] - [$intern library] - [do-overflow library] - [do-vararg-overflow library] - [do-stack-overflow library] - ;;; type predicates - [fixnum? public] - [immediate? public] - [boolean? public] - [char? public] - [null? public] - [pair? public] - [symbol? public] - [vector? public] - [string? public] - [procedure? public] - [eof-object? public] - [not public] - [eq? public] - [equal? public] - ;;; fixnum primitives - [fxadd1 public] - [fxsub1 public] - [fx+ public] - [fx- public] - [fx* public] - [fxsll public] - [fxsra public] - [fxlogor public] - [fxlogand public] - [fxlogxor public] - [fxlognot public] - [fxquotient public] - [fxremainder public] - [fxmodulo public] - ;;; fixnum predicates - [fxzero? public] - [fx= public] - [fx< public] - [fx<= public] - [fx> public] - [fx>= public] - ;;; characters - [char=? public] - [char? public] - [char>=? public] - [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] - [memv 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] - [primitive-set! 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] - [syntax-error public] - [current-expand public] - [expand-mode public] - [compile-file public] - [fasl-write public] - - [$sc-put-cte public] - [sc-expand public] - [$make-environment public] - [environment? public] - [interaction-environment public] - [identifier? public] - [syntax->list public] - [syntax-object->datum public] - [datum->syntax-object public] - [generate-temporaries public] - [free-identifier=? public] - [bound-identifier=? public] - [literal-identifier=? public] - [syntax-error public] - [$syntax-dispatch public] - - - - [interpret public] - [eval public] - [current-eval public] - [load public] - [new-cafe public] - [collect public] - [call/cc public] - [call/cf library] - [dynamic-wind public] - [values public] - [call-with-values public] - [make-traced-procedure library] - [trace-symbol! library] - [untrace-symbol! library] - ;;; record - [$base-rtd library] - [record? public] - [record-rtd public] - [record-name public] - [record-printer public] - [record-length public] - [record-ref public] - [record-set! public] - ;;; record rtds - [make-record-type public] - [record-constructor public] - [record-predicate public] - [record-field-accessor public] - [record-field-mutator public] - ;;; hash tables - [make-hash-table public] - [hash-table? public] - [get-hash-table public] - [put-hash-table! public] - ;;; asm - [make-code public] - [code? public] - [make-code-executable! public] - [code-instr-size public] - [code-reloc-size public] - [code-closure-size public] - [set-code-byte! public] - [set-code-word! public] - [set-code-object! public] - [set-code-foreign-object! public] - [set-code-object+offset! public] - [set-code-object+offset/rel! public] - [set-code-object/reloc/relative! public] - [code->closure public] - [list*->code* library] - ;;; - ;;; POSIX - ;;; - [fork public] - [posix-fork public] - [system public] - [$debug public] - [$underflow-misaligned-error public] - )) - -(define (primitive? x) - (cond - [(assq x primitives-table) #t] - [(assq x open-coded-primitives) #t] - [else #f])) - -(define (open-codeable? x) - (cond - [(assq x open-coded-primitives) #t] - [(assq x primitives-table) #f] - [else (error 'open-codeable "invalid primitive ~s" x)])) - -(define (open-coded-primitive-args x) - (cond - [(assq x open-coded-primitives) => cadr] - [else (error 'open-coded-primitive-args "invalid ~s" x)])) - -;;; end of primitives table section - - -(define-record constant (value)) -(define-record code-loc (label)) -(define-record foreign-label (label)) -(define-record var (name)) -(define-record cp-var (idx)) -(define-record frame-var (idx)) -(define-record new-frame (base-idx size body)) -(define-record save-cp (loc)) -(define-record eval-cp (check body)) -(define-record return (value)) -(define-record call-cp - (call-convention rp-convention base-idx arg-count live-mask)) -(define-record primcall (op arg*)) -(define-record primref (name)) -(define-record conditional (test conseq altern)) -(define-record bind (lhs* rhs* body)) -(define-record seq (e0 e1)) -(define-record function (arg* proper body)) -(define-record clambda-case (arg* proper body)) -(define-record clambda (cases)) -(define-record clambda-code (label cases free)) - -(define-record closure (code free*)) -(define-record funcall (op rand*)) -(define-record appcall (op rand*)) -(define-record forcall (op rand*)) -(define-record code-rec (arg* proper free* body)) - -(define-record codes (list body)) -(define-record assign (lhs rhs)) - -(define unique-var - (let ([counter 0]) - (lambda (x) - (let ([g (gensym (format "~a:~a" x counter))]) - (set! counter (fxadd1 counter)) - (make-var g))))) - -(define (make-bind^ lhs* rhs* body) - (if (null? lhs*) - body - (make-bind lhs* rhs* body))) - -(define (recordize x) - (define (gen-fml* fml*) - (cond - [(pair? fml*) - (cons (unique-var (car fml*)) - (gen-fml* (cdr fml*)))] - [(symbol? fml*) - (unique-var fml*)] - [else '()])) - (define (properize fml*) - (cond - [(pair? fml*) - (cons (car fml*) (properize (cdr fml*)))] - [(null? fml*) '()] - [else (list fml*)])) - (define (extend-env fml* nfml* env) - (cons (cons fml* nfml*) env)) - (define (quoted-sym x) - (if (and (list? x) - (fx= (length x) 2) - (eq? 'quote (car x)) - (symbol? (cadr x))) - (cadr x) - (error 'quoted-sym "not a quoted symbol ~s" x))) - (define (quoted-string x) - (if (and (list? x) - (fx= (length x) 2) - (eq? 'quote (car x)) - (string? (cadr x))) - (cadr x) - (error 'quoted-string "not a quoted string ~s" x))) - (define (lookup^ x lhs* rhs*) - (cond - [(pair? lhs*) - (if (eq? x (car lhs*)) - (car rhs*) - (lookup^ x (cdr lhs*) (cdr rhs*)))] - [(eq? x lhs*) rhs*] - [else #f])) - (define (lookup x env) - (cond - [(pair? env) - (or (lookup^ x (caar env) (cdar env)) - (lookup x (cdr env)))] - [else #f])) - (define (E x env) - (cond - [(pair? x) - (case (car x) - [(quote) (make-constant (cadr x))] - [(if) - (make-conditional - (E (cadr x) env) - (E (caddr x) env) - (E (cadddr x) env))] - [(set!) - (let ([lhs (cadr x)] [rhs (caddr x)]) - (make-assign - (or (lookup lhs env) - (error 'recordize "invalid assignment ~s" x)) - (E rhs env)))] - [(begin) - (let f ([a (cadr x)] [d (cddr x)]) - (cond - [(null? d) (E a env)] - [else - (make-seq - (E a env) - (f (car d) (cdr d)))]))] - [(case-lambda) - (let ([cls* - (map - (lambda (cls) - (let ([fml* (car cls)] [body (cadr cls)]) - (let ([nfml* (gen-fml* fml*)]) - (let ([body (E body (extend-env fml* nfml* env))]) - (make-clambda-case - (properize nfml*) - (list? fml*) - body))))) - (cdr x))]) - (make-clambda cls*))] - [(foreign-call) - (let ([name (quoted-string (cadr x))] [arg* (cddr x)]) - (make-forcall name - (map (lambda (x) (E x env)) arg*)))] - [(|#primitive|) - (let ([var (cadr x)]) - (if (primitive? var) - (make-primref var) - (error 'recordize "invalid primitive ~s" var)))] - [(top-level-value) - (let ([var (quoted-sym (cadr x))]) - (cond - [(primitive? var) (make-primref var)] - [else (error 'recordize "invalid top-level var ~s" var)]))] - [(memv) - (make-funcall - (make-primref 'memq) - (map (lambda (x) (E x env)) (cdr x)))] - [($apply) - (let ([proc (cadr x)] [arg* (cddr x)]) - (make-appcall - (E proc env) - (map (lambda (x) (E x env)) arg*)))] - [(void) - (make-constant (void))] - [else - (make-funcall - (E (car x) env) - (map (lambda (x) (E x env)) (cdr x)))])] - [(symbol? x) - (or (lookup x env) - (error 'recordize "invalid reference in ~s" x))] - [else (error 'recordize "invalid expression ~s" x)])) - (E x '())) - - -(define (unparse x) - (define (E-args proper x) - (if proper - (map E x) - (let f ([a (car x)] [d (cdr x)]) - (cond - [(null? d) (E a)] - [else (cons (E a) (f (car d) (cdr d)))])))) - (define (E x) - (record-case x - [(constant c) `(quote ,c)] - [(code-loc x) `(code-loc ,x)] - [(var x) (string->symbol (format "v:~a" x))] - [(primref x) x] - [(conditional test conseq altern) - `(if ,(E test) ,(E conseq) ,(E altern))] - [(primcall op arg*) `(,op . ,(map E arg*))] - [(bind lhs* rhs* body) - `(let ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*) - ,(E body))] - [(seq e0 e1) `(begin ,(E e0) ,(E e1))] - [(function args proper body) - `(lambda ,(E-args proper args) ,(E body))] - [(clambda-case args proper body) - `(clambda-case ,(E-args proper args) ,(E body))] - [(clambda cls*) - `(case-lambda . ,(map E cls*))] - [(clambda-code label clauses free) - `(code ,label . ,(map E clauses))] - [(closure code free*) - `(closure ,(E code) ,(map E free*))] - [(code-rec arg* proper free* body) - `(code-rec [arg: ,(E-args proper arg*)] - [free: ,(map E free*)] - ,(E body))] - [(codes list body) - `(codes ,(map E list) - ,(E body))] - [(funcall rator rand*) `(funcall ,(E rator) . ,(map E rand*))] - [(appcall rator rand*) `(appcall ,(E rator) . ,(map E rand*))] - [(forcall rator rand*) `(foreign-call ,rator . ,(map E rand*))] - [(assign lhs rhs) `(set! ,(E lhs) ,(E rhs))] - [(return x) `(return ,(E x))] - [(new-frame base-idx size body) - `(new-frame [base: ,base-idx] - [size: ,size] - ,(E body))] - [(frame-var idx) - (string->symbol (format "fv.~a" idx))] - [(cp-var idx) - (string->symbol (format "cp.~a" idx))] - [(save-cp expr) - `(save-cp ,(E expr))] - [(eval-cp check body) - `(eval-cp ,check ,(E body))] - [(call-cp call-convention rp-convention base-idx arg-count live-mask) - `(call-cp [conv: ,call-convention] - [rpconv: ,rp-convention] - [base-idx: ,base-idx] - [arg-count: ,arg-count] - [live-mask: ,live-mask])] - [(foreign-label x) `(foreign-label ,x)] - [else (error 'unparse "invalid record ~s" x)])) - (E x)) - -(define (optimize-direct-calls x) - (define who 'optimize-direct-calls) - (define (make-conses ls) - (cond - [(null? ls) (make-constant '())] - [else - (make-primcall 'cons - (list (car ls) (make-conses (cdr ls))))])) - (define (properize lhs* rhs*) - (cond - [(null? lhs*) (error who "improper improper")] - [(null? (cdr lhs*)) - (list (make-conses rhs*))] - [else (cons (car rhs*) (properize (cdr lhs*) (cdr rhs*)))])) - (define (inline-case cls rand*) - (record-case cls - [(clambda-case fml* proper body) - (if proper - (and (fx= (length fml*) (length rand*)) - (make-bind fml* rand* body)) - (and (fx<= (length fml*) (length rand*)) - (make-bind fml* (properize fml* rand*) body)))])) - (define (try-inline cls* rand* default) - (cond - [(null? cls*) default] - [(inline-case (car cls*) rand*)] - [else (try-inline (cdr cls*) rand* default)])) - (define (inline rator rand*) - (record-case rator - [(clambda cls*) - (try-inline cls* rand* - (make-funcall rator rand*))] -; [(function fml* proper body) -; (cond -; [proper -; (if (fx= (length fml*) (length rand*)) -; (make-bind fml* rand* body) -; (begin -; (warning 'compile "possible application error in ~s" -; (unparse (make-funcall rator rand*))) -; (make-funcall rator rand*)))] -; [else -; (if (fx<= (length fml*) (length rand*)) -; (make-bind fml* (properize fml* rand*) body) -; (begin -; (warning 'compile "possible application error in ~s" -; (unparse (make-funcall rator rand*))) -; (make-funcall rator rand*)))])] - [else (make-funcall rator rand*)])) - (define (Expr x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (make-conditional - (Expr test) - (Expr conseq) - (Expr altern))] - [(seq e0 e1) - (make-seq (Expr e0) (Expr e1))] - [(function fml* proper body) - (make-function fml* proper (Expr body))] - [(clambda cls*) - (make-clambda - (map (lambda (x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (Expr body))])) - cls*))] - [(primcall rator rand*) - (make-primcall rator (map Expr rand*))] - [(funcall rator rand*) - (inline (Expr rator) (map Expr rand*))] - [(appcall rator rand*) - (make-appcall (Expr rator) (map Expr rand*))] - [(forcall rator rand*) - (make-forcall rator (map Expr rand*))] - [(assign lhs rhs) - (make-assign lhs (Expr rhs))] - [else (error who "invalid expression ~s" (unparse x))])) - (Expr x)) - - - -(define (uncover-assigned x) - (define who 'uncover-assigned) - (define (Expr* x*) - (cond - [(null? x*) '()] - [else (union (Expr (car x*)) (Expr* (cdr x*)))])) - (define (Expr x) - (record-case x - [(constant) '()] - [(var) '()] - [(primref) '()] - [(bind lhs* rhs* body) - (union (Expr body) (Expr* rhs*))] - [(conditional test conseq altern) - (union (Expr test) (union (Expr conseq) (Expr altern)))] - [(seq e0 e1) (union (Expr e0) (Expr e1))] - [(clambda cls*) - (Expr* (map clambda-case-body cls*))] - [(function fml* proper body) (Expr body)] - [(primcall rator rand*) (Expr* rand*)] - [(funcall rator rand*) - (union (Expr rator) (Expr* rand*))] - [(appcall rator rand*) - (union (Expr rator) (Expr* rand*))] - [(forcall rator rand*) (Expr* rand*)] - [(assign lhs rhs) - (union (singleton lhs) (Expr rhs))] - [else (error who "invalid expression ~s" (unparse x))])) - (Expr x)) - -(define (rewrite-assignments assigned x) - (define who 'rewrite-assignments) - (define (fix lhs*) - (cond - [(null? lhs*) (values '() '() '())] - [else - (let ([x (car lhs*)]) - (let-values ([(lhs* a-lhs* a-rhs*) (fix (cdr lhs*))]) - (cond - [(memq x assigned) - (let ([t (make-var 'assignment-tmp)]) - (values (cons t lhs*) (cons x a-lhs*) (cons t a-rhs*)))] - [else - (values (cons x lhs*) a-lhs* a-rhs*)])))])) - (define (bind-assigned lhs* rhs* body) - (cond - [(null? lhs*) body] - [else - (make-bind lhs* - (map (lambda (rhs) (make-primcall 'vector (list rhs))) rhs*) - body)])) - (define (Expr x) - (record-case x - [(constant) x] - [(var) - (cond - [(memq x assigned) - (make-primcall '$vector-ref (list x (make-constant 0)))] - [else x])] - [(primref) x] - [(bind lhs* rhs* body) - (let-values ([(lhs* a-lhs* a-rhs*) (fix lhs*)]) - (make-bind lhs* (map Expr rhs*) - (bind-assigned a-lhs* a-rhs* (Expr body))))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (make-seq (Expr e0) (Expr e1))] - [(function fml* proper body) - (let-values ([(fml* a-lhs* a-rhs*) (fix fml*)]) - (make-function fml* proper - (bind-assigned a-lhs* a-rhs* (Expr body))))] - [(clambda cls*) - (make-clambda - (map (lambda (cls) - (record-case cls - [(clambda-case fml* proper body) - (let-values ([(fml* a-lhs* a-rhs*) (fix fml*)]) - (make-clambda-case fml* proper - (bind-assigned a-lhs* a-rhs* (Expr body))))])) - cls*))] - [(primcall op rand*) - (make-primcall op (map Expr rand*))] - [(forcall op rand*) - (make-forcall op (map Expr rand*))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(appcall rator rand*) - (make-appcall (Expr rator) (map Expr rand*))] - [(assign lhs rhs) - (unless (memq lhs assigned) - (error 'rewrite-assignments "not assigned ~s in ~s" lhs x)) - (make-primcall '$vector-set! (list lhs (make-constant 0) (Expr rhs)))] - [else (error who "invalid expression ~s" (unparse x))])) - (Expr x)) - - -(define (remove-assignments x) - (let ([assigned (uncover-assigned x)]) - (rewrite-assignments assigned x))) - - -(define (convert-closures prog) - (define who 'convert-closures) - (define (Expr* x*) - (cond - [(null? x*) (values '() '())] - [else - (let-values ([(a a-free) (Expr (car x*))] - [(d d-free) (Expr* (cdr x*))]) - (values (cons a d) (union a-free d-free)))])) - (define (Expr ex) - (record-case ex - [(constant) (values ex '())] - [(var) (values ex (singleton ex))] - [(primref) (values ex '())] - [(bind lhs* rhs* body) - (let-values ([(rhs* rhs-free) (Expr* rhs*)] - [(body body-free) (Expr body)]) - (values (make-bind lhs* rhs* body) - (union rhs-free (difference body-free lhs*))))] - [(conditional test conseq altern) - (let-values ([(test test-free) (Expr test)] - [(conseq conseq-free) (Expr conseq)] - [(altern altern-free) (Expr altern)]) - (values (make-conditional test conseq altern) - (union test-free (union conseq-free altern-free))))] - [(seq e0 e1) - (let-values ([(e0 e0-free) (Expr e0)] - [(e1 e1-free) (Expr e1)]) - (values (make-seq e0 e1) (union e0-free e1-free)))] - [(function fml* proper body) - (let-values ([(body body-free) (Expr body)]) - (let ([free (difference body-free fml*)]) - (values (make-closure (make-code-rec fml* proper free body) free) - free)))] - [(clambda cls*) - (let-values ([(cls* free) - (let f ([cls* cls*]) - (cond - [(null? cls*) (values '() '())] - [else - (record-case (car cls*) - [(clambda-case fml* proper body) - (let-values ([(body body-free) (Expr body)] - [(cls* cls*-free) (f (cdr cls*))]) - (values - (cons (make-clambda-case fml* proper body) - cls*) - (union (difference body-free fml*) - cls*-free)))])]))]) - (values (make-closure (make-clambda-code (gensym) cls* free) free) - free))] - [(primcall op rand*) - (let-values ([(rand* rand*-free) (Expr* rand*)]) - (values (make-primcall op rand*) rand*-free))] - [(forcall op rand*) - (let-values ([(rand* rand*-free) (Expr* rand*)]) - (values (make-forcall op rand*) rand*-free))] - [(funcall rator rand*) - (let-values ([(rator rat-free) (Expr rator)] - [(rand* rand*-free) (Expr* rand*)]) - (values (make-funcall rator rand*) - (union rat-free rand*-free)))] - [(appcall rator rand*) - (let-values ([(rator rat-free) (Expr rator)] - [(rand* rand*-free) (Expr* rand*)]) - (values (make-appcall rator rand*) - (union rat-free rand*-free)))] - [else (error who "invalid expression ~s" (unparse ex))])) - (let-values ([(prog free) (Expr prog)]) - (unless (null? free) - (error 'convert-closures "free vars ~s encountered in ~a" - free (unparse prog))) - prog)) - - -(define (lift-codes x) - (define who 'lift-codes) - (define all-codes '()) - (define (do-code x) - (record-case x - [(clambda-code label cls* free) - (let ([cls* (map - (lambda (x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (E body))])) - cls*)]) - (let ([g (make-code-loc label)]) - (set! all-codes - (cons (make-clambda-code label cls* free) all-codes)) - g))])) - (define (E x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(bind lhs* rhs* body) - (make-bind lhs* (map E rhs*) (E body))] - [(conditional test conseq altern) - (make-conditional (E test) (E conseq) (E altern))] - [(seq e0 e1) (make-seq (E e0) (E e1))] - [(closure c free) (make-closure (do-code c) free)] - [(primcall op rand*) (make-primcall op (map E rand*))] - [(forcall op rand*) (make-forcall op (map E rand*))] - [(funcall rator rand*) (make-funcall (E rator) (map E rand*))] - [(appcall rator rand*) (make-appcall (E rator) (map E rand*))] - [else (error who "invalid expression ~s" (unparse x))])) - (let ([x (E x)]) - (make-codes all-codes x))) - - - - -(define (syntactically-valid? op rand*) - (define (valid-arg-count? op rand*) - (let ([n (open-coded-primitive-args op)] [m (length rand*)]) - (cond - [(eq? n 'any) #t] - [(eq? n 'no-code) - (error 'syntactically-valid - "should not primcall non codable prim ~s" op)] - [(fixnum? n) - (cond - [(fx= n m) #t] - [else - (error 'compile - "Possible incorrect number of args in ~s" - (cons op (map unparse rand*))) - #f])] - [else (error 'do-primcall "BUG: what ~s" n)]))) - (define (check op pred?) - (lambda (arg) - (record-case arg - [(constant c) - (cond - [(pred? c) #t] - [else - (error 'compile "Possible argument error to primitive ~s" op) - #f])] - [(primref) - (cond - [(pred? (lambda (x) x)) #t] - [else - (error 'compile "Possible argument error to primitive ~s" op) - #f])] - [else #t]))) - (define (nonnegative-fixnum? n) - (and (fixnum? n) (fx>= n 0))) - (define (byte? n) - (and (fixnum? n) (fx<= 0 n) (fx<= n 127))) - (define (valid-arg-types? op rand*) - (case op - [(fixnum? immediate? boolean? char? vector? string? procedure? - null? pair? not cons eq? vector symbol? error eof-object eof-object? - void $unbound-object? code? $forward-ptr? bwp-object? - pointer-value) - '#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 - $make-tcbucket $tcbucket-key $tcbucket-val $tcbucket-next - $set-tcbucket-val! $set-tcbucket-next! $set-tcbucket-tconc!) - #t] - [else (error 'valid-arg-types? "unhandled op ~s" op)])) - (and (valid-arg-count? op rand*) - (or (null? rand*) - (valid-arg-types? op rand*)))) - - -;;; the output of simplify-operands differs from the input in that the -;;; operands to primcalls are all simple (variables, primrefs, or constants). -;;; funcalls to open-codable primrefs whos arguments are "ok" are converted to -;;; primcalls. - -(define (introduce-primcalls x) - (define who 'introduce-primcalls) - (define (simple? x) - (or (constant? x) (var? x) (primref? x))) - (define (Expr x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(closure) x] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (make-seq (Expr e0) (Expr e1))] - [(primcall op arg*) - (case op - ;[(values) - ; (if (fx= (length arg*) 1) - ; (Expr (car arg*)) - ; (begin - ; (warning 'compile "possible incorrect number of values") - ; (make-funcall (make-primref 'values) (map Expr arg*))))] - [else - (make-primcall op (map Expr arg*))])] - [(forcall op arg*) - (make-forcall op (map Expr arg*))] - [(funcall rator rand*) - (cond - [(and (primref? rator) - (open-codeable? (primref-name rator)) - (syntactically-valid? (primref-name rator) rand*)) - (Expr (make-primcall (primref-name rator) rand*))] - [else - (make-funcall (Expr rator) (map Expr rand*))])] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (Tail x) - (record-case x - [(constant) (make-return x)] - [(var) (make-return x)] - [(primref) (make-return x)] - [(closure) (make-return x)] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Tail body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Tail conseq) (Tail altern))] - [(seq e0 e1) (make-seq (Expr e0) (Tail e1))] - [(primcall op arg*) - (case op - ;[(values) - ; (if (fx= (length arg*) 1) - ; (make-return (Expr (car arg*))) - ; (make-return* (map Expr arg*)))] - [else - (make-return (make-primcall op (map Expr arg*)))])] - [(forcall op arg*) - (make-return (make-forcall op (map Expr arg*)))] - [(funcall rator rand*) - (cond - [(and (primref? rator) - (open-codeable? (primref-name rator)) - (syntactically-valid? (primref-name rator) rand*)) - (Tail (make-primcall (primref-name rator) rand*))] - [else - (make-funcall (Expr rator) (map Expr rand*))])] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (CaseExpr x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (Tail body))])) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (make-clambda-code L (map CaseExpr cases) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) (Tail body))])) - (CodesExpr x)) - - -(define (simplify-operands x) - (define who 'simplify-operands) - (define (simple? x) - (or (constant? x) (var? x) (primref? x))) - (define (simplify arg lhs* rhs* k) - (if (simple? arg) - (k arg lhs* rhs*) - (let ([v (unique-var 'tmp)]) - (k v (cons v lhs*) (cons (Expr arg) rhs*))))) - (define (simplify* arg* lhs* rhs* k) - (cond - [(null? arg*) (k '() lhs* rhs*)] - [else - (simplify (car arg*) lhs* rhs* - (lambda (a lhs* rhs*) - (simplify* (cdr arg*) lhs* rhs* - (lambda (d lhs* rhs*) - (k (cons a d) lhs* rhs*)))))])) - (define (Expr x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(closure) x] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (make-seq (Expr e0) (Expr e1))] - [(primcall op arg*) - (simplify* arg* '() '() - (lambda (arg* lhs* rhs*) - (make-bind^ lhs* rhs* - (make-primcall op arg*))))] - [(forcall op arg*) - (make-forcall op (map Expr arg*))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (Tail x) - (record-case x - [(return v) (make-return (Expr v))] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Tail body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Tail conseq) (Tail altern))] - [(seq e0 e1) (make-seq (Expr e0) (Tail e1))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (CaseExpr x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (Tail body))])) - (define (CodeExpr x) - (record-case x - [(clambda-code L clauses free) - (make-clambda-code L (map CaseExpr clauses) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) (Tail body))])) - (CodesExpr x)) - - -(define (insert-stack-overflow-checks x) - (define who 'insert-stack-overflow-checks) - (define (insert-check body) - (make-seq - (make-conditional - (make-primcall '$fp-overflow '()) - (make-funcall (make-primref 'do-stack-overflow) '()) - (make-primcall 'void '())) - body)) - (define (Expr x) - (record-case x - [(constant) #f] - [(var) #f] - [(primref) #f] - [(closure code free*) #f] - [(bind lhs* rhs* body) - (or (ormap Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (or (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (or (Expr e0) (Expr e1))] - [(primcall op arg*) (ormap Expr arg*)] - [(forcall op arg*) (ormap Expr arg*)] - [(funcall rator arg*) #t] - [(appcall rator arg*) #t] - [else (error who "invalid expression ~s" (unparse x))])) - (define (Tail x) - (record-case x - [(return v) (Expr v)] - [(bind lhs* rhs* body) - (or (ormap Expr rhs*) (Tail body))] - [(conditional test conseq altern) - (or (Expr test) (Tail conseq) (Tail altern))] - [(seq e0 e1) (or (Expr e0) (Tail e1))] - [(funcall rator arg*) (or (Expr rator) (ormap Expr arg*))] - [(appcall rator arg*) (or (Expr rator) (ormap Expr arg*))] - [else (error who "invalid tail expression ~s" (unparse x))])) - (define (CaseExpr x) - (record-case x - [(clambda-case fml* proper body) - (if (Tail body) - (make-clambda-case fml* proper (insert-check body)) - x)])) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (make-clambda-code L (map CaseExpr cases) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) - (if (Tail body) - (insert-check body) - body))])) - (CodesExpr x)) - - -(define (insert-allocation-checks x) - (define who 'insert-allocation-checks) - (define (check-bytes n var body) - (make-seq - (make-conditional - (make-primcall '$ap-check-bytes - (list (make-constant n) var)) - (make-funcall (make-primref 'do-overflow) - (list - (make-primcall '$fx+ - (list (make-constant n) var)))) - (make-primcall 'void '())) - body)) - (define (check-words n var body) - (make-seq - (make-conditional - (make-primcall '$ap-check-words - (list (make-constant n) var)) - (make-funcall (make-primref 'do-overflow-words) - (list - (make-primcall '$fx+ - (list (make-constant n) var)))) - (make-primcall 'void '())) - body)) - (define (check-const n body) - (make-seq - (make-conditional - (make-primcall '$ap-check-const - (list (make-constant n))) - (make-funcall (make-primref 'do-overflow) - (list (make-constant n))) - (make-primcall 'void '())) - body)) - (define (Expr x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(closure code free*) - (check-const (fx+ disp-closure-data (fx* (length free*) wordsize)) x)] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (make-seq (Expr e0) (Expr e1))] - [(primcall op arg*) - (let ([x (make-primcall op (map Expr arg*))]) - (case op - [(cons) (check-const pair-size x)] - [($make-symbol) (check-const symbol-size x)] - [($make-tcbucket) (check-const tcbucket-size x)] - [($frame->continuation $code->closure) - (check-const (fx+ disp-closure-data (fx* (length arg*) wordsize)) x)] - [($make-string) - (record-case (car arg*) - [(constant i) - (check-const (fx+ i (fx+ disp-string-data 1)) x)] - [else - (check-bytes (fxadd1 disp-string-data) (car arg*) x)])] - [($string) - (check-const (fx+ (length arg*) (fx+ disp-string-data 1)) x)] - [($make-vector) - (record-case (car arg*) - [(constant i) - (check-const (fx+ (fx* i wordsize) disp-vector-data) x)] - [else - (check-words (fxadd1 disp-vector-data) (car arg*) x)])] - [($make-record) - (record-case (cadr arg*) - [(constant i) - (check-const (fx+ (fx* i wordsize) disp-record-data) x)] - [else - (check-words (fxadd1 disp-record-data) (cadr arg*) x)])] - [(vector) - (check-const (fx+ (fx* (length arg*) wordsize) disp-vector-data) x)] - [else x]))] - [(forcall op arg*) - (make-forcall op (map Expr arg*))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (Tail x) - (record-case x - [(return v) (make-return (Expr v))] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Tail body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Tail conseq) (Tail altern))] - [(seq e0 e1) (make-seq (Expr e0) (Tail e1))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (CaseExpr x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (Tail body))])) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (make-clambda-code L (map CaseExpr cases) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) (Tail body))])) - (CodesExpr x)) - - -(define (remove-local-variables x) - (define who 'remove-local-variables) - (define (simple* x* r) - (map (lambda (x) - (cond - [(assq x r) => cdr] - [else - (when (var? x) (error who "unbound var ~s" x)) - x])) - x*)) - (define (env->mask r sz) - (let ([s (make-vector (fxsra (fx+ sz 7) 3) 0)]) - (for-each - (lambda (idx) - (let ([q (fxsra idx 3)] - [r (fxlogand idx 7)]) - (vector-set! s q - (fxlogor (vector-ref s q) (fxsll 1 r))))) - r) - s)) - (define (do-new-frame op rand* si r call-convention rp-convention orig-live) - (make-new-frame (fxadd1 si) (fx+ (length rand*) 2) - (let f ([r* rand*] [nsi (fx+ si 2)] [live orig-live]) - (cond - [(null? r*) - (make-seq - (make-seq - (make-save-cp (make-frame-var si)) - (case call-convention - [(normal apply) - (make-eval-cp #t (Expr op nsi r (cons si live)))] - [(foreign) - (make-eval-cp #f (make-foreign-label op))] - [else (error who "invalid convention ~s" convention)])) - (make-call-cp call-convention - rp-convention - (fxadd1 si) ; frame size - (length rand*) ; argc - (env->mask (cons si orig-live) ; cp and everything before it - (fxadd1 si))))] ; mask-size ~~ frame size - [else - (make-seq - (make-assign (make-frame-var nsi) - (Expr (car r*) nsi r live)) - (f (cdr r*) (fxadd1 nsi) (cons nsi live)))])))) - (define (nop) (make-primcall 'void '())) - (define (do-bind lhs* rhs* body si r live k) - (let f ([lhs* lhs*] [rhs* rhs*] [si si] [nr r] [live live]) - (cond - [(null? lhs*) (k body si nr live)] - [else - (let ([v (make-frame-var si)]) - (make-seq - (make-assign v (Expr (car rhs*) si r live)) - (f (cdr lhs*) (cdr rhs*) (fxadd1 si) - (cons (cons (car lhs*) v) nr) - (cons si live))))]))) - (define (Tail x si r live) - (record-case x - [(return v) (make-return (Expr v si r live))] - [(bind lhs* rhs* body) - (do-bind lhs* rhs* body si r live Tail)] - [(conditional test conseq altern) - (make-conditional - (Expr test si r live) - (Tail conseq si r live) - (Tail altern si r live))] - [(seq e0 e1) (make-seq (Effect e0 si r live) (Tail e1 si r live))] - [(primcall op arg*) - (case op -; [(values) (make-primcall op (simple* arg* r))] - [else (make-return (make-primcall op (simple* arg* r)))])] - [(funcall op rand*) - (do-new-frame op rand* si r 'normal 'tail live)] - [(appcall op rand*) - (do-new-frame op rand* si r 'apply 'tail live)] - [else (error who "invalid expression ~s" (unparse x))])) - (define (Effect x si r live) - (record-case x - [(constant) (nop)] - [(var) (nop)] - [(primref) (nop)] - [(closure code free*) (nop)] - [(bind lhs* rhs* body) - (do-bind lhs* rhs* body si r live Effect)] - [(conditional test conseq altern) - (make-conditional - (Expr test si r live) - (Effect conseq si r live) - (Effect altern si r live))] - [(seq e0 e1) (make-seq (Effect e0 si r live) (Effect e1 si r live))] - [(primcall op arg*) - (make-primcall op (simple* arg* r))] - [(forcall op rand*) - (do-new-frame op rand* si r 'foreign 'effect live)] - [(funcall op rand*) - (do-new-frame op rand* si r 'normal 'effect live)] - [(appcall op rand*) - (do-new-frame op rand* si r 'apply 'effect live)] - [else (error who "invalid effect expression ~s" (unparse x))])) - (define (Expr x si r live) - (record-case x - [(constant) x] - [(var) - (cond - [(assq x r) => cdr] - [else (error who "unbound var ~s" x)])] - [(primref) x] - [(closure code free*) - (make-closure code (simple* free* r))] - [(bind lhs* rhs* body) - (do-bind lhs* rhs* body si r live Expr)] - [(conditional test conseq altern) - (make-conditional - (Expr test si r live) - (Expr conseq si r live) - (Expr altern si r live))] - [(seq e0 e1) (make-seq (Effect e0 si r live) (Expr e1 si r live))] - [(primcall op arg*) - (make-primcall op (simple* arg* r))] - [(forcall op rand*) - (do-new-frame op rand* si r 'foreign 'value live)] - [(funcall op rand*) - (do-new-frame op rand* si r 'normal 'value live)] - [(appcall op rand*) - (do-new-frame op rand* si r 'apply 'value live)] - [else (error who "invalid expression ~s" (unparse x))])) - (define (bind-fml* fml* r) - (let f ([si 1] [fml* fml*]) - (cond - [(null? fml*) (values '() si r '())] - [else - (let-values ([(nfml* nsi r live) (f (fxadd1 si) (cdr fml*))]) - (let ([v (make-frame-var si)]) - (values (cons v nfml*) - nsi - (cons (cons (car fml*) v) r) - (cons si live))))]))) - (define (bind-free* free*) - (let f ([free* free*] [idx 0] [r '()]) - (cond - [(null? free*) r] - [else - (f (cdr free*) (fxadd1 idx) - (cons (cons (car free*) (make-cp-var idx)) r))]))) - (define CaseExpr - (lambda (r) - (lambda (x) - (record-case x - [(clambda-case fml* proper body) - (let-values ([(fml* si r live) (bind-fml* fml* r)]) - (make-clambda-case fml* proper (Tail body si r live)))])))) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (let ([r (bind-free* free)]) - (make-clambda-code L (map (CaseExpr r) cases) free))])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) - (Tail body 1 '() '()))])) - (CodesExpr x)) - - -(begin - (define fx-shift 2) - (define fx-mask #x03) - (define fx-tag 0) - (define bool-f #x2F) - (define bool-t #x3F) - (define bool-mask #xEF) - (define bool-tag bool-f) - (define bool-shift 4) - (define nil #x4F) - (define eof #x5F) ; double check - (define unbound #x6F) ; double check - (define void-object #x7F) ; double check - (define bwp-object #x8F) ; double check - (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 pagesize 4096) - (define pageshift 12) - (define wordsize 4) - (define wordshift 2) - - (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 disp-tcbucket-tconc 0) - (define disp-tcbucket-key 4) - (define disp-tcbucket-val 8) - (define disp-tcbucket-next 12) - (define tcbucket-size 16) - - (define record-ptag vector-tag) - (define record-pmask vector-mask) - (define disp-record-rtd 0) - (define disp-record-data 4) - (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) - (define dirty-word -1)) - -(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)] - [(dirty-vector) (mem 28 pcr)] - [else (error 'pcb-ref "invalid arg ~s" x)]))) - -(define (primref-loc op) - (unless (symbol? op) (error 'primref-loc "not a symbol ~s" op)) - (mem (fx- disp-symbol-system-value symbol-tag) - (obj op))) - -(define (generate-code x) - (define who 'generate-code) - (define (rp-label x) - (case x - [(value) (label-address SL_multiple_values_error_rp)] - [(effect) (label-address SL_multiple_values_ignore_rp)] - [else (error who "invalid rp-convention ~s" x)])) - (define (align n) - (fxsll (fxsra (fx+ n (fxsub1 object-alignment)) align-shift) align-shift)) - (define unique-label - (lambda () - (label (gensym)))) - (define (constant-val x) - (cond - [(fixnum? x) (obj x)] - [(boolean? x) (int (if x bool-t bool-f))] - [(null? x) (int nil)] - [(char? x) (int (fx+ (fxsll (char->integer x) char-shift) char-tag))] - [(eq? x (void)) (int void-object)] - [else (obj x)])) - (define (cond-branch op Lt Lf ac) - (define (opposite x) - (cadr (assq x '([je jne] [jl jge] [jle jg] [jg jle] [jge jl])))) - (unless (or Lt Lf) - (error 'cond-branch "no labels")) - (cond - [(not Lf) (cons (list op Lt) ac)] - [(not Lt) (cons (list (opposite op) Lf) ac)] - [else (list* (list op Lt) (jmp Lf) ac)])) - (define (indirect-type-pred pri-mask pri-tag sec-mask sec-tag rand* Lt Lf ac) - (cond - [(and Lt Lf) - (list* (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int pri-mask) ebx) - (cmpl (int pri-tag) ebx) - (jne Lf) - (movl (mem (fx- 0 pri-tag) eax) ebx) - (if sec-mask - (andl (int sec-mask) ebx) - '(nop)) - (cmpl (int sec-tag) ebx) - (jne Lf) - (jmp Lt) - ac)] - [Lf - (list* (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int pri-mask) ebx) - (cmpl (int pri-tag) ebx) - (jne Lf) - (movl (mem (fx- 0 pri-tag) eax) ebx) - (if sec-mask - (andl (int sec-mask) ebx) - '(nop)) - (cmpl (int sec-tag) ebx) - (jne Lf) - ac)] - [Lt - (let ([L_END (unique-label)]) - (list* (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int pri-mask) ebx) - (cmpl (int pri-tag) ebx) - (jne L_END) - (movl (mem (fx- 0 pri-tag) eax) ebx) - (if sec-mask - (andl (int sec-mask) ebx) - '(nop)) - (cmpl (int sec-tag) ebx) - (je Lt) - L_END - ac))] - [else ac])) - (define (type-pred mask tag rand* Lt Lf ac) - (cond - [mask - (list* - (movl (Simple (car rand*)) eax) - (andl (int mask) eax) - (cmpl (int tag) eax) - (cond-branch 'je Lt Lf ac))] - [else - (let ([v (Simple (car rand*))]) - (cond - [(memq (car v) '(mem register)) - (list* - (cmpl (int tag) (Simple (car rand*))) - (cond-branch 'je Lt Lf ac))] - [else - (list* - (movl (Simple (car rand*)) eax) - (cmpl (int tag) eax) - (cond-branch 'je Lt Lf ac))]))])) - (define (compare-and-branch op rand* Lt Lf ac) - (define (opposite x) - (cadr (assq x '([je je] [jl jg] [jle jge] [jg jl] [jge jle])))) - (cond - [(and (constant? (car rand*)) (constant? (cadr rand*))) - (list* - (movl (Simple (car rand*)) eax) - (cmpl (Simple (cadr rand*)) eax) - (cond-branch op Lt Lf ac))] - [(constant? (cadr rand*)) - (list* - (cmpl (Simple (cadr rand*)) (Simple (car rand*))) - (cond-branch op Lt Lf ac))] - [(constant? (car rand*)) - (list* - (cmpl (Simple (car rand*)) (Simple (cadr rand*))) - (cond-branch (opposite op) Lt Lf ac))] - [else - (list* - (movl (Simple (car rand*)) eax) - (cmpl (Simple (cadr rand*)) eax) - (cond-branch op Lt Lf ac))])) - (define (do-pred-prim op rand* Lt Lf ac) - (case op - [(fixnum?) (type-pred fx-mask fx-tag rand* Lt Lf ac)] - [(pair?) (type-pred pair-mask pair-tag rand* Lt Lf ac)] - [(char?) (type-pred char-mask char-tag rand* Lt Lf ac)] - [(string?) (type-pred string-mask string-tag rand* Lt Lf ac)] - [(symbol?) (type-pred symbol-mask symbol-tag rand* Lt Lf ac)] - [(procedure?) (type-pred closure-mask closure-tag rand* Lt Lf ac)] - [(boolean?) (type-pred bool-mask bool-tag rand* Lt Lf ac)] - [(null?) (type-pred #f nil rand* Lt Lf ac)] - [($unbound-object?) (type-pred #f unbound rand* Lt Lf ac)] - [($forward-ptr?) (type-pred #f -1 rand* Lt Lf ac)] - [(not) (type-pred #f bool-f rand* Lt Lf ac)] - [(eof-object?) (type-pred #f eof rand* Lt Lf ac)] - [(bwp-object?) (type-pred #f bwp-object 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)] - [(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)] - [($tcbucket-key) - (indirect-ref arg* (fx- disp-tcbucket-key vector-tag) ac)] - [($tcbucket-val) - (indirect-ref arg* (fx- disp-tcbucket-val vector-tag) ac)] - [($tcbucket-next) - (indirect-ref arg* (fx- disp-tcbucket-next vector-tag) ac)] - [(pointer-value) - (list* - (movl (Simple (car arg*)) eax) - (sarl (int fx-shift) eax) - (sall (int fx-shift) eax) - ac)] - [($symbol-plist) - (indirect-ref arg* (fx- disp-symbol-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-tcbucket) - (list* (movl (Simple (car arg*)) eax) - (movl eax (mem disp-tcbucket-tconc apr)) - (movl (Simple (cadr arg*)) eax) - (movl eax (mem disp-tcbucket-key apr)) - (movl (Simple (caddr arg*)) eax) - (movl eax (mem disp-tcbucket-val apr)) - (movl (Simple (cadddr arg*)) eax) - (movl eax (mem disp-tcbucket-next apr)) - (movl apr eax) - (addl (int vector-tag) eax) - (addl (int (align tcbucket-size)) apr) - ac)] - [(vector) - (let f ([arg* arg*] [idx disp-vector-data]) - (cond - [(null? arg*) - (list* (movl apr eax) - (addl (int vector-tag) eax) - (movl (int (fx- idx disp-vector-data)) - (mem disp-vector-length apr)) - (addl (int (align idx)) apr) - ac)] - [else - (list* (movl (Simple (car arg*)) eax) - (movl eax (mem idx apr)) - (f (cdr arg*) (fx+ idx wordsize)))]))] - [($string) - (let f ([arg* arg*] [idx disp-string-data]) - (cond - [(null? arg*) - (list* (movb (int 0) (mem idx apr)) - (movl apr eax) - (addl (int string-tag) eax) - (movl (int (fx* (fx- idx disp-string-data) wordsize)) - (mem disp-string-length apr)) - (addl (int (align (fxadd1 idx))) apr) - ac)] - [else - (record-case (car arg*) - [(constant c) - (unless (char? c) (error who "invalid arg to string ~s" x)) - (list* (movb (int (char->integer c)) (mem idx apr)) - (f (cdr arg*) (fxadd1 idx)))] - [else - (list* (movl (Simple (car arg*)) ebx) - (movb bh (mem idx apr)) - (f (cdr arg*) (fxadd1 idx)))])]))] - [($current-frame) - (list* (movl (pcb-ref 'next-continuation) eax) - ac)] - [($seal-frame-and-call) - (list* (movl (Simple (car arg*)) cpr) ; proc - (movl (pcb-ref 'frame-base) eax) - ; eax=baseofstack - (movl (mem (fx- 0 wordsize) eax) ebx) ; underflow handler - (movl ebx (mem (fx- 0 wordsize) fpr)) ; set - ; create a new cont record - (movl (int continuation-tag) (mem 0 apr)) - (movl fpr (mem disp-continuation-top apr)) - ; compute the size of the captured frame - (movl eax ebx) - (subl fpr ebx) - (subl (int wordsize) ebx) - ; and store it - (movl ebx (mem disp-continuation-size apr)) - ; load next cont - (movl (pcb-ref 'next-continuation) ebx) - ; and store it - (movl ebx (mem disp-continuation-next apr)) - ; adjust ap - (movl apr eax) - (addl (int vector-tag) eax) - (addl (int continuation-size) apr) - ; store new cont in current-cont - (movl eax (pcb-ref 'next-continuation)) - ; adjust fp - (movl fpr (pcb-ref 'frame-base)) - (subl (int wordsize) fpr) - ; tail-call f - (movl eax (mem (fx- 0 wordsize) fpr)) - (movl (int (argc-convention 1)) eax) - (tail-indirect-cpr-call) - ac)] - [($code-instr-size) - (indirect-ref arg* (fx- disp-code-instrsize vector-tag) - (cons (sall (int fx-shift) eax) ac))] - [($code-reloc-size) - (indirect-ref arg* (fx- disp-code-relocsize vector-tag) ac)] - [($code-closure-size) - (indirect-ref arg* (fx- disp-code-closuresize vector-tag) ac)] - [($set-car! $set-cdr! $vector-set! $string-set! $exit - $set-symbol-value! $set-symbol-plist! - $set-code-byte! $set-code-word! primitive-set! - $set-code-object! $set-code-object+offset! $set-code-object+offset/rel! - $record-set!) - (do-effect-prim op arg* - (cons (movl (int void-object) eax) ac))] - [(fixnum? immediate? $fxzero? boolean? char? pair? vector? string? symbol? - procedure? null? not eof-object? $fx= $fx< $fx<= $fx> $fx>= eq? - $char= $char< $char<= $char> $char>= $unbound-object? code? - $record? bwp-object?) - (do-pred->value-prim op arg* ac)] - [($code->closure) - (list* - (movl (Simple (car arg*)) eax) - (addl (int (fx- disp-code-data vector-tag)) eax) - (movl eax (mem 0 apr)) - (movl apr eax) - (addl (int closure-tag) eax) - (addl (int (align disp-closure-data)) apr) - ac)] - [($frame->continuation) - (NonTail - (make-closure (make-code-loc SL_continuation_code) arg*) - ac)] - [($make-call-with-values-procedure) - (NonTail - (make-closure (make-code-loc SL_call_with_values) arg*) - ac)] - [($make-values-procedure) - (NonTail - (make-closure (make-code-loc SL_values) arg*) - ac)] - [else - (error 'value-prim "unhandled ~s" op)])) - (define (indirect-assignment arg* offset ac) - (list* - (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem offset eax)) - ;;; record side effect - (addl (int offset) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)) - (define (do-effect-prim op arg* ac) - (case op - [($vector-set!) - (list* (movl (Simple (car arg*)) ebx) - (addl (Simple (cadr arg*)) ebx) - (addl (int (fx- disp-vector-data vector-tag)) ebx) - (movl (Simple (caddr arg*)) eax) - (movl eax (mem 0 ebx)) - ;;; record side effect - (shrl (int pageshift) ebx) - (sall (int wordshift) ebx) - (addl (pcb-ref 'dirty-vector) ebx) - (movl (int dirty-word) (mem 0 ebx)) - ac)] - [($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-car!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-car pair-tag) eax)) - ;;; record side effect - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-cdr!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-cdr pair-tag) eax)) - ;;; record side effect - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-tcbucket-key!) - (indirect-assignment arg* (fx- disp-tcbucket-key vector-tag) ac)] - [($set-tcbucket-val!) - (indirect-assignment arg* (fx- disp-tcbucket-val vector-tag) ac)] - [($set-tcbucket-next!) - (indirect-assignment arg* (fx- disp-tcbucket-next vector-tag) ac)] - [($set-tcbucket-tconc!) - (indirect-assignment arg* (fx- disp-tcbucket-tconc vector-tag) ac)] - - [($set-symbol-value!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-value symbol-tag) eax)) - ;;; record side effect - (addl (int (fx- disp-symbol-value symbol-tag)) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 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)) - ;;; record side effect - (addl (int (fx- disp-symbol-system-value symbol-tag)) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-symbol-plist!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-plist symbol-tag) eax)) - ;;; record side effect - (addl (int (fx- disp-symbol-plist symbol-tag)) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-symbol-unique-string!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-unique-string symbol-tag) eax)) - ;;; record side effect - (addl (int (fx- disp-symbol-unique-string symbol-tag)) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-symbol-string!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-string symbol-tag) eax)) - ;;; record side effect - (addl (int (fx- disp-symbol-string symbol-tag)) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($record-set!) - (list* (movl (Simple (car arg*)) ebx) - (addl (Simple (cadr arg*)) ebx) - (movl (Simple (caddr arg*)) eax) - (addl (int (fx- disp-record-data record-ptag)) ebx) - (movl eax (mem 0 ebx)) - ;;; record side effect - (shrl (int pageshift) ebx) - (sall (int wordshift) ebx) - (addl (pcb-ref 'dirty-vector) ebx) - (movl (int dirty-word) (mem 0 ebx)) - ac)] - [(cons void $fxadd1 $fxsub1) - (let f ([arg* arg*]) - (cond - [(null? arg*) ac] - [else - (Effect (car arg*) (f (cdr arg*)))]))] - [else - (error 'do-effect-prim "unhandled op ~s" op)])) - (define (do-simple-test x Lt Lf ac) - (unless (or Lt Lf) - (error 'Pred "no labels")) - (cond - [(not Lt) - (list* (cmpl (int bool-f) x) (je Lf) ac)] - [(not Lf) - (list* (cmpl (int bool-f) x) (jne Lt) ac)] - [else - (list* (cmpl (int bool-f) x) (je Lf) (jmp Lt) ac)])) - (define (Simple x) - (record-case x - [(cp-var i) - (mem (fx+ (fx* i wordsize) (fx- disp-closure-data closure-tag)) cpr)] - [(frame-var i) (mem (fx* i (fx- 0 wordsize)) fpr)] - [(constant c) (constant-val c)] - [(code-loc label) (label-address label)] - [(primref op) (primref-loc op)] - [else (error 'Simple "what ~s" x)])) - (define (frame-adjustment offset) - (fx* (fxsub1 offset) (fx- 0 wordsize))) - (define (NonTail x ac) - (record-case x - [(constant c) - (cons (movl (constant-val c) eax) ac)] - [(frame-var) - (cons (movl (Simple x) eax) ac)] - [(cp-var) - (cons (movl (Simple x) eax) ac)] - [(foreign-label L) - (cons (movl (list 'foreign-label L) eax) ac)] - [(primref c) - (cons (movl (primref-loc c) eax) ac)] - [(closure label arg*) - (let f ([arg* arg*] [off disp-closure-data]) - (cond - [(null? arg*) - (list* (movl (Simple label) (mem 0 apr)) - (movl apr eax) - (addl (int (align off)) apr) - (addl (int closure-tag) eax) - ac)] - [else - (list* (movl (Simple (car arg*)) eax) - (movl eax (mem off apr)) - (f (cdr arg*) (fx+ off wordsize)))]))] - [(conditional test conseq altern) - (let ([Lj (unique-label)] [Lf (unique-label)]) - (Pred test #f Lf - (NonTail conseq - (list* (jmp Lj) Lf (NonTail altern (cons Lj ac))))))] - [(seq e0 e1) - (Effect e0 (NonTail e1 ac))] - [(primcall op rand*) - (do-value-prim op rand* ac)] - [(new-frame base-idx size body) - (NonTail body ac)] - [(call-cp call-convention rp-convention offset size mask) - (let ([L_CALL (unique-label)]) - (case call-convention - [(normal) - (list* (addl (int (frame-adjustment offset)) fpr) - (movl (int (argc-convention size)) eax) - (jmp L_CALL) - ; NEW FRAME - `(byte-vector ,mask) - `(int ,(fx* offset wordsize)) - `(current-frame-offset) - (rp-label rp-convention) - `(byte 0) ; padding for indirect calls only - `(byte 0) ; direct calls are ok - L_CALL - (indirect-cpr-call) - (movl (mem 0 fpr) cpr) - (subl (int (frame-adjustment offset)) fpr) - ac)] - [(apply) are-we-ever-here? - (list* (addl (int (frame-adjustment offset)) fpr) - (movl (int (argc-convention size)) eax) - (jmp L_CALL) - ; NEW FRAME - (byte-vector mask) - `(int ,(fx* offset wordsize)) - `(current-frame-offset) - (rp-label rp-convention) - L_CALL - (call (label SL_apply)) - (movl (mem 0 fpr) cpr) - (subl (int (frame-adjustment offset)) fpr) - ac)] - [(foreign) - (list* (addl (int (frame-adjustment offset)) fpr) - (movl (int (argc-convention size)) eax) - (movl '(foreign-label "ik_foreign_call") ebx) - (jmp L_CALL) - ; NEW FRAME - (byte-vector mask) - `(int ,(fx* offset wordsize)) - `(current-frame-offset) - (rp-label rp-convention) ; should be 0, since C has 1 rv - '(byte 0) - '(byte 0) - '(byte 0) - L_CALL - (call ebx) - (movl (mem 0 fpr) cpr) - (subl (int (frame-adjustment offset)) fpr) - ac)] - [else (error who "invalid convention ~s for call-cp" convention)]))] - [else (error 'NonTail "invalid expression ~s" x)])) - (define (Pred x Lt Lf ac) - (record-case x - [(frame-var i) - (do-simple-test (idx->frame-loc i) Lt Lf ac)] - [(cp-var i) - (do-simple-test (Simple x) Lt Lf ac)] - [(constant c) - (if c - (if Lt (cons (jmp Lt) ac) ac) - (if Lf (cons (jmp Lf) ac) ac))] - [(primcall op rand*) - (do-pred-prim op rand* Lt Lf ac)] - [(conditional test conseq altern) - (cond - [(not Lt) - (let ([Lj^ (unique-label)] [Lf^ (unique-label)]) - (Pred test #f Lf^ - (Pred conseq Lj^ Lf - (cons Lf^ - (Pred altern #f Lf - (cons Lj^ ac))))))] - [(not Lf) - (let ([Lj^ (unique-label)] [Lf^ (unique-label)]) - (Pred test #f Lf^ - (Pred conseq Lt Lj^ - (cons Lf^ - (Pred altern Lt #f - (cons Lj^ ac))))))] - [else - (let ([Lf^ (unique-label)]) - (Pred test #f Lf^ - (Pred conseq Lt Lf - (cons Lf^ - (Pred altern Lt Lf ac)))))])] - [(seq e0 e1) - (Effect e0 (Pred e1 Lt Lf ac))] - [(new-frame) - (NonTail x (do-simple-test eax Lt Lf ac))] - [else (error 'Pred "invalid expression ~s" x)])) - (define (idx->frame-loc i) - (mem (fx* i (fx- 0 wordsize)) fpr)) - (define (Effect x ac) - (record-case x - [(constant) ac] - [(primcall op rand*) - (do-effect-prim op rand* ac)] - [(conditional test conseq altern) - (let ([Lf (unique-label)] [Ljoin (unique-label)]) - (Pred test #f Lf - (Effect conseq - (list* (jmp Ljoin) Lf (Effect altern (cons Ljoin ac))))))] - [(seq e0 e1) - (Effect e0 (Effect e1 ac))] - [(assign loc val) - (record-case loc - [(frame-var i) - (NonTail val - (cons (movl eax (idx->frame-loc i)) ac))] - [else (error who "invalid assign loc ~s" loc)])] - [(eval-cp check body) - (NonTail body - (cond - [check - (list* - (movl eax cpr) - (andl (int closure-mask) eax) - (cmpl (int closure-tag) eax) - (jne (label SL_nonprocedure)) - ac)] - [else - (list* - (movl eax cpr) - ac)]))] - [(save-cp loc) - (record-case loc - [(frame-var i) - (cons (movl cpr (idx->frame-loc i)) ac)] - [else (error who "invalid cpr loc ~s" x)])] - [(new-frame) (NonTail x ac)] - [(frame-var) ac] - [else (error 'Effect "invalid expression ~s" x)])) - (define (Tail x ac) - (record-case x - [(return x) - (NonTail x (cons (ret) ac))] - [(conditional test conseq altern) - (let ([L (unique-label)]) - (Pred test #f L - (Tail conseq - (cons L (Tail altern ac)))))] - [(seq e0 e1) - (Effect e0 (Tail e1 ac))] - [(new-frame idx size body) - (Tail body ac)] - [(call-cp call-convention rp-convention idx argc mask) - (unless (eq? rp-convention 'tail) - (error who "nontail rp (~s) in tail context" rp-convention)) - (let f ([i 0]) - (cond - [(fx= i argc) - (case call-convention - [(normal) - (list* - (movl (int (argc-convention argc)) eax) - (tail-indirect-cpr-call) - ac)] - [(apply) - (list* - (movl (int (argc-convention argc)) eax) - (jmp (label SL_apply)) - ac)] - [else (error who "invalid conv ~s in tail call-cpr" convention)])] - [else - (list* (movl (mem (fx* (fx+ idx (fxadd1 i)) - (fx- 0 wordsize)) fpr) - eax) - (movl eax (mem (fx* (fx+ i 1) (fx- 0 wordsize)) fpr)) - (f (fxadd1 i)))]))] - [else (error 'Tail "invalid expression ~s" x)])) - (define (handle-vararg fml-count ac) - (define CONTINUE_LABEL (unique-label)) - (define DONE_LABEL (unique-label)) - (define CONS_LABEL (unique-label)) - (define LOOP_HEAD (unique-label)) - (define L_CALL (unique-label)) - (list* (cmpl (int (argc-convention (fxsub1 fml-count))) eax) - (jg (label SL_invalid_args)) - (jl CONS_LABEL) - (movl (int nil) ebx) - (jmp DONE_LABEL) - CONS_LABEL - (movl (pcb-ref 'allocation-redline) ebx) - (addl eax ebx) - (addl eax ebx) - (cmpl ebx apr) - (jle LOOP_HEAD) - ; overflow - (addl eax esp) ; advance esp to cover args - (pushl cpr) ; push current cp - (pushl eax) ; push argc - (negl eax) ; make argc positive - (addl (int (fx* 4 wordsize)) eax) ; add 4 words to adjust frame size - (pushl eax) ; push frame size - (addl eax eax) ; double the number of args - (movl eax (mem (fx* -2 wordsize) fpr)) ; pass it as first arg - (movl (int (argc-convention 1)) eax) ; setup argc - (movl (primref-loc 'do-vararg-overflow) cpr) ; load handler - (jmp L_CALL) ; go to overflow handler - ; NEW FRAME - (int 0) ; if the framesize=0, then the framesize is dynamic - '(current-frame-offset) - (int 0) ; multiarg rp - (byte 0) - (byte 0) - L_CALL - (indirect-cpr-call) - (popl eax) ; pop framesize and drop it - (popl eax) ; reload argc - (popl cpr) ; reload cp - (subl eax fpr) ; readjust fp - LOOP_HEAD - (movl (int nil) ebx) - CONTINUE_LABEL - (movl ebx (mem disp-cdr apr)) - (movl (mem fpr eax) ebx) - (movl ebx (mem disp-car apr)) - (movl apr ebx) - (addl (int pair-tag) ebx) - (addl (int pair-size) apr) - (addl (int (fxsll 1 fx-shift)) eax) - (cmpl (int (fx- 0 (fxsll fml-count fx-shift))) eax) - (jle CONTINUE_LABEL) - DONE_LABEL - (movl ebx (mem (fx- 0 (fxsll fml-count fx-shift)) fpr)) - ac)) - (define (Entry check? x ac) - (record-case x - [(clambda-case fml* proper body) - (let ([ac (Tail body ac)]) - (cond - [(and proper check?) - (list* (cmpl (int (argc-convention (length fml*))) eax) - (jne (label SL_invalid_args)) - ac)] - [proper ac] - [else - (handle-vararg (length fml*) ac)]))])) - (define make-dispatcher - (lambda (j? L L* x x* ac) - (cond - [(null? L*) (if j? (cons (jmp (label L)) ac) ac)] - [else - (record-case x - [(clambda-case fml* proper _) - (cond - [proper - (list* (cmpl (int (argc-convention (length fml*))) eax) - (je (label L)) - (make-dispatcher #t - (car L*) (cdr L*) (car x*) (cdr x*) ac))] - [else - (list* (cmpl (int (argc-convention (fxsub1 (length fml*)))) eax) - (jle (label L)) - (make-dispatcher #t - (car L*) (cdr L*) (car x*) (cdr x*) ac))])])]))) - (define (handle-cases x x*) - (let ([L* (map (lambda (_) (gensym)) x*)] - [L (gensym)]) - (make-dispatcher #f L L* x x* - (let f ([x x] [x* x*] [L L] [L* L*]) - (cond - [(null? x*) - (cons (label L) (Entry 'check x '()))] - [else - (cons (label L) - (Entry #f x - (f (car x*) (cdr x*) (car L*) (cdr L*))))]))))) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (list* - (fx+ disp-closure-data (fx* wordsize (length free))) - (label L) - (handle-cases (car cases) (cdr cases)))])) - (record-case x - [(codes list body) - (cons (cons 0 (Tail body '())) - (map CodeExpr list))])) - - -(define SL_nonprocedure (gensym "SL_nonprocedure")) -(define SL_invalid_args (gensym "SL_invalid_args")) -(define SL_foreign_call (gensym "SL_foreign_call")) -(define SL_continuation_code (gensym "SL_continuation_code")) -(define SL_multiple_values_error_rp (gensym "SL_multiple_values_error_rp")) -(define SL_multiple_values_ignore_rp (gensym "SL_multiple_ignore_error_rp")) -(define SL_underflow_multiple_values (gensym "SL_underflow_multiple_values")) -(define SL_underflow_handler (gensym "SL_underflow_handler")) -(define SL_scheme_exit (gensym "SL_scheme_exit")) -(define SL_apply (gensym "SL_apply")) -(define SL_values (gensym "SL_values")) -(define SL_call_with_values (gensym "SL_call_with_values")) - -(list*->code* - (list - (let ([L_cwv_done (gensym)] - [L_cwv_loop (gensym)] - [L_cwv_multi_rp (gensym)] - [L_cwv_call (gensym)]) - (list disp-closure-data - (label SL_call_with_values) - (cmpl (int (argc-convention 2)) eax) - (jne (label SL_invalid_args)) - (movl (mem (fx- 0 wordsize) fpr) ebx) ; producer - (movl ebx cpr) - (andl (int closure-mask) ebx) - (cmpl (int closure-tag) ebx) - (jne (label SL_nonprocedure)) - (movl (int (argc-convention 0)) eax) - (subl (int (fx* wordsize 2)) fpr) - (jmp (label L_cwv_call)) - ; MV NEW FRAME - (byte-vector '#(#b110)) - (int (fx* wordsize 3)) - '(current-frame-offset) - (label-address L_cwv_multi_rp) - (byte 0) - (byte 0) - (label L_cwv_call) - (indirect-cpr-call) - ;;; one value returned - (addl (int (fx* wordsize 2)) fpr) - (movl (mem (fx* -2 wordsize) fpr) ebx) ; consumer - (movl ebx cpr) - (movl eax (mem (fx- 0 wordsize) fpr)) - (movl (int (argc-convention 1)) eax) - (andl (int closure-mask) ebx) - (cmpl (int closure-tag) ebx) - (jne (label SL_nonprocedure)) - (tail-indirect-cpr-call) - ;;; multiple values returned - (label L_cwv_multi_rp) - ; because values does not pop the return point - ; we have to adjust fp one more word here - (addl (int (fx* wordsize 3)) fpr) - (movl (mem (fx* -2 wordsize) fpr) cpr) ; consumer - (cmpl (int (argc-convention 0)) eax) - (je (label L_cwv_done)) - (movl (int (fx* -4 wordsize)) ebx) - (addl fpr ebx) ; ebx points to first value - (movl ebx ecx) - (addl eax ecx) ; ecx points to the last value - (label L_cwv_loop) - (movl (mem 0 ebx) edx) - (movl edx (mem (fx* 3 wordsize) ebx)) - (subl (int wordsize) ebx) - (cmpl ecx ebx) - (jge (label L_cwv_loop)) - (label L_cwv_done) - (movl cpr ebx) - (andl (int closure-mask) ebx) - (cmpl (int closure-tag) ebx) - (jne (label SL_nonprocedure)) - (tail-indirect-cpr-call))) - - (let ([L_values_one_value (gensym)] - [L_values_many_values (gensym)]) - (list disp-closure-data - (label SL_values) - (cmpl (int (argc-convention 1)) eax) - (je (label L_values_one_value)) - (label L_values_many_values) - (movl (mem 0 fpr) ebx) ; return point - (jmp (mem disp-multivalue-rp ebx)) ; go - (label L_values_one_value) - (movl (mem (fx- 0 wordsize) fpr) eax) - (ret))) - - (let ([L_apply_done (gensym)] - [L_apply_loop (gensym)]) - (list 0 - (label SL_apply) - (movl (mem fpr eax) ebx) - (cmpl (int nil) ebx) - (je (label L_apply_done)) - (label L_apply_loop) - (movl (mem (fx- disp-car pair-tag) ebx) ecx) - (movl (mem (fx- disp-cdr pair-tag) ebx) ebx) - (movl ecx (mem fpr eax)) - (subl (int wordsize) eax) - (cmpl (int nil) ebx) - (jne (label L_apply_loop)) - (label L_apply_done) - (addl (int wordsize) eax) - (tail-indirect-cpr-call))) - - (list 0 - (label SL_nonprocedure) - (movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg - (movl (primref-loc '$apply-nonprocedure-error-handler) cpr) - (movl (int (argc-convention 1)) eax) - (tail-indirect-cpr-call)) - - (list 0 - (label SL_multiple_values_error_rp) - (movl (primref-loc '$multiple-values-error) cpr) - (tail-indirect-cpr-call)) - - (list 0 - (label SL_multiple_values_ignore_rp) - (ret)) - - (list 0 - (label SL_invalid_args) - ;;; - (movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg - (negl eax) - (movl eax (mem (fx- 0 (fx* 2 wordsize)) fpr)) - (movl (primref-loc '$incorrect-args-error-handler) cpr) - (movl (int (argc-convention 2)) eax) - (tail-indirect-cpr-call)) - - (let ([Lset (gensym)] [Lloop (gensym)]) - (list 0 - (label SL_foreign_call) - (movl fpr (pcb-ref 'frame-pointer)) - (movl apr (pcb-ref 'allocation-pointer)) - (movl fpr ebx) - (movl (pcb-ref 'system-stack) esp) - (pushl pcr) - (cmpl (int 0) eax) - (je (label Lset)) - (label Lloop) - (movl (mem ebx eax) ecx) - (pushl ecx) - (addl (int 4) eax) - (cmpl (int 0) eax) - (jne (label Lloop)) - (label Lset) - ; FOREIGN NEW FRAME - (call cpr) - (movl (pcb-ref 'frame-pointer) fpr) - (movl (pcb-ref 'allocation-pointer) apr) - (ret))) - - (let ([L_cont_zero_args (gensym)] - [L_cont_mult_args (gensym)] - [L_cont_one_arg (gensym)] - [L_cont_mult_move_args (gensym)] - [L_cont_mult_copy_loop (gensym)]) - (list - (fx+ disp-closure-data wordsize) - (label SL_continuation_code) - (movl (mem (fx- disp-closure-data closure-tag) cpr) ebx) ; captured-k - (movl ebx (pcb-ref 'next-continuation)) ; set - (movl (pcb-ref 'frame-base) ebx) - (cmpl (int (argc-convention 1)) eax) - (jg (label L_cont_zero_args)) - (jl (label L_cont_mult_args)) - (label L_cont_one_arg) - (movl (mem (fx- 0 wordsize) fpr) eax) - (movl ebx fpr) - (subl (int wordsize) fpr) - (ret) - (label L_cont_zero_args) - (subl (int wordsize) ebx) - (movl ebx fpr) - (movl (mem 0 ebx) ebx) ; return point - (jmp (mem disp-multivalue-rp ebx)) ; go - (label L_cont_mult_args) - (subl (int wordsize) ebx) - (cmpl ebx fpr) - (jne (label L_cont_mult_move_args)) - (movl (mem 0 ebx) ebx) - (jmp (mem disp-multivalue-rp ebx)) - (label L_cont_mult_move_args) - ; move args from fpr to ebx - (movl (int 0) ecx) - (label L_cont_mult_copy_loop) - (subl (int wordsize) ecx) - (movl (mem fpr ecx) edx) - (movl edx (mem ebx ecx)) - (cmpl ecx eax) - (jne (label L_cont_mult_copy_loop)) - (movl ebx fpr) - (movl (mem 0 ebx) ebx) - (jmp (mem disp-multivalue-rp ebx)) - )) - )) - - - -(define (compile-program original-program) - (let* (;;; - [p (sc-expand original-program)] - [p (recordize p)] - ;[f (pretty-print (unparse p))] - [p (optimize-direct-calls p)] - [p (remove-assignments p)] - [p (convert-closures p)] - [p (lift-codes p)] - ;[p (lift-complex-constants p)] - [p (introduce-primcalls p)] - [p (simplify-operands p)] - ;[f (pretty-print (unparse p))] - [p (insert-stack-overflow-checks p)] - [p (insert-allocation-checks p)] - [p (remove-local-variables p)] - ;[f (pretty-print (unparse p))] - [ls* (generate-code p)] - [f (when (assembler-output) - (for-each - (lambda (ls) - (for-each (lambda (x) (printf " ~s\n" x)) ls)) - ls*))] - [code* (list*->code* ls*)]) - (fasl-write (car code*) (compile-port)))) - - -(define compile-expr - (lambda (expr output-file) - (let ([op (open-output-file output-file 'replace)]) - (parameterize ([compile-port op]) - (compile-program expr)) - (close-output-port op)))) - -(define compile-file - (lambda (input-file output-file) - (let ([ip (open-input-file input-file)] - [op (open-output-file output-file 'replace)]) - (parameterize ([compile-port op] - [expand-mode 'bootstrap]) - (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") diff --git a/src/compiler-6.4.ss b/src/compiler-6.4.ss deleted file mode 100644 index da0089c..0000000 --- a/src/compiler-6.4.ss +++ /dev/null @@ -1,98 +0,0 @@ - - -;;; 6.2: * side-effects now modify the dirty-vector -;;; * added bwp-object? -;;; * added pointer-value -;;; * added tcbuckets -;;; 6.1: * added case-lambda, dropped lambda -;;; 6.0: * basic compiler - -(when (eq? "" "") - (load "chez-compat.ss") - (set! primitive-ref top-level-value) - (set! primitive-set! set-top-level-value!) - (set! chez-expand sc-expand) - (set! chez-current-expand current-expand) - (set! $base-rtd (eval '#%$base-rtd)) -; (set! $base-rtd #%$base-rtd) - (printf "loading psyntax.pp ...\n") - (load "psyntax-7.1.pp") - (chez-current-expand - (lambda (x . args) - (apply chez-expand (sc-expand x) args))) - (printf "loading psyntax.ss ...\n") - (load "psyntax-7.1.ss") - (chez-current-expand - (lambda (x . args) - (apply chez-expand (sc-expand x) args))) - (printf "ok\n") - (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 "libcompile-6.4.ss") ; uses fasl-write -) - - -(define scheme-library-files - '(["libhandlers-6.0.ss" "libhandlers.fasl"] - ["libcontrol-6.1.ss" "libcontrol.fasl"] - ["libcollect-6.1.ss" "libcollect.fasl"] - ["librecord-6.4.ss" "librecord.fasl"] - ["libcxr-6.0.ss" "libcxr.fasl"] - ["libcore-6.2.ss" "libcore.fasl"] - ["libio-6.1.ss" "libio.fasl"] - ["libwriter-6.2.ss" "libwriter.fasl"] - ["libtokenizer-6.1.ss" "libtokenizer.fasl"] - ["libassembler-compat-6.0.ss" "libassembler-compat.ss"] - ["libintelasm-6.4.ss" "libintelasm.fasl"] - ["libfasl-6.0.ss" "libfasl.fasl"] - ["libcompile-6.4.ss" "libcompile.fasl"] - ["psyntax-7.1.ss" "psyntax.fasl"] - ["libinterpret-6.1.ss" "libinterpret.fasl"] - ["libcafe-6.1.ss" "libcafe.fasl"] -; ["libtrace-5.3.ss" "libtrace-5.3.s" "libtrace" ] - ["libposix-6.0.ss" "libposix.fasl"] - ["libhash-6.2.ss" "libhash.fasl"] - ["libtoplevel-6.0.ss" "libtoplevel.fasl"] - )) - - - -(define (compile-library ifile ofile) - (parameterize ([assembler-output #f] [expand-mode 'bootstrap]) - (printf "compiling ~a ...\n" ifile) - (compile-file ifile ofile 'replace))) - -(for-each - (lambda (x) - (compile-library (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 (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)))))))) - -(with-output-to-file "petite-ikarus.ss" - (lambda () - (write - `(begin - (display ,(format "Petite Ikarus Scheme (Build ~a)\n" (get-date))) - (display "Copyright (c) 2006 Abdulaziz Ghuloum\n\n") - (new-cafe)))) - 'replace) - -(compile-library "petite-ikarus.ss" "petite-ikarus.fasl") diff --git a/src/compiler-6.5.ss b/src/compiler-6.5.ss deleted file mode 100644 index f4dc5e2..0000000 --- a/src/compiler-6.5.ss +++ /dev/null @@ -1,96 +0,0 @@ - - -;;; 6.2: * side-effects now modify the dirty-vector -;;; * added bwp-object? -;;; * added pointer-value -;;; * added tcbuckets -;;; 6.1: * added case-lambda, dropped lambda -;;; 6.0: * basic compiler - -(when (eq? "" "") - (load "chez-compat.ss") - (set! primitive-ref top-level-value) - (set! primitive-set! set-top-level-value!) - (set! chez-expand sc-expand) - (set! chez-current-expand current-expand) - (printf "loading psyntax.pp ...\n") - (load "psyntax-7.1.pp") - (chez-current-expand - (lambda (x . args) - (apply chez-expand (sc-expand x) args))) - (printf "loading psyntax.ss ...\n") - (load "psyntax-7.1-6.5.ss") - (chez-current-expand - (lambda (x . args) - (apply chez-expand (sc-expand x) args))) - (printf "ok\n") - (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 "libcompile-6.5.ss") ; uses fasl-write -) - - -(define scheme-library-files - '(["libhandlers-6.0.ss" "libhandlers.fasl"] - ["libcontrol-6.1.ss" "libcontrol.fasl"] - ["libcollect-6.1.ss" "libcollect.fasl"] - ["librecord-6.4.ss" "librecord.fasl"] - ["libcxr-6.0.ss" "libcxr.fasl"] - ["libcore-6.2.ss" "libcore.fasl"] - ["libio-6.1.ss" "libio.fasl"] - ["libwriter-6.2.ss" "libwriter.fasl"] - ["libtokenizer-6.1.ss" "libtokenizer.fasl"] - ["libassembler-compat-6.0.ss" "libassembler-compat.ss"] - ["libintelasm-6.4.ss" "libintelasm.fasl"] - ["libfasl-6.0.ss" "libfasl.fasl"] - ["libcompile-6.5.ss" "libcompile.fasl"] - ["psyntax-7.1-6.5.ss" "psyntax.fasl"] - ["libinterpret-6.5.ss" "libinterpret.fasl"] - ["libcafe-6.1.ss" "libcafe.fasl"] -; ["libtrace-5.3.ss" "libtrace-5.3.s" "libtrace" ] - ["libposix-6.0.ss" "libposix.fasl"] - ["libhash-6.2.ss" "libhash.fasl"] - ["libtoplevel-6.0.ss" "libtoplevel.fasl"] - )) - - - -(define (compile-library ifile ofile) - (parameterize ([assembler-output #f] [expand-mode 'bootstrap]) - (printf "compiling ~a ...\n" ifile) - (compile-file ifile ofile 'replace))) - -(for-each - (lambda (x) - (compile-library (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 (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)))))))) - -(with-output-to-file "petite-ikarus.ss" - (lambda () - (write - `(begin - (display ,(format "Petite Ikarus Scheme (Build ~a)\n" (get-date))) - (display "Copyright (c) 2006 Abdulaziz Ghuloum\n\n") - (new-cafe)))) - 'replace) - -(compile-library "petite-ikarus.ss" "petite-ikarus.fasl") diff --git a/src/compiler-6.6.ss b/src/compiler-6.6.ss deleted file mode 100644 index b83900e..0000000 --- a/src/compiler-6.6.ss +++ /dev/null @@ -1,97 +0,0 @@ - - -;;; 6.2: * side-effects now modify the dirty-vector -;;; * added bwp-object? -;;; * added pointer-value -;;; * added tcbuckets -;;; 6.1: * added case-lambda, dropped lambda -;;; 6.0: * basic compiler - -(when (eq? "" "") - (load "chez-compat.ss") - (set! primitive-ref top-level-value) - (set! primitive-set! set-top-level-value!) - (set! chez-expand sc-expand) - (set! chez-current-expand current-expand) - (printf "loading psyntax.pp ...\n") - (load "psyntax-7.1.pp") - (chez-current-expand - (lambda (x . args) - (apply chez-expand (sc-expand x) args))) - (printf "loading psyntax.ss ...\n") - (load "psyntax-7.1-6.5.ss") - (chez-current-expand - (lambda (x . args) - (apply chez-expand (sc-expand x) args))) - (printf "ok\n") - (load "libassembler-compat-6.6.ss") ; defines make-code etc. - (load "libintelasm-6.6.ss") ; uses make-code, etc. - (load "libfasl-6.6.ss") ; uses code? etc. - (load "libcompile-6.6.ss") ; uses fasl-write -) - - - -(define scheme-library-files - '(["libhandlers-6.0.ss" "libhandlers.fasl"] - ["libcontrol-6.1.ss" "libcontrol.fasl"] - ["libcollect-6.1.ss" "libcollect.fasl"] - ["librecord-6.4.ss" "librecord.fasl"] - ["libcxr-6.0.ss" "libcxr.fasl"] - ["libcore-6.2.ss" "libcore.fasl"] - ["libio-6.1.ss" "libio.fasl"] - ["libwriter-6.2.ss" "libwriter.fasl"] - ["libtokenizer-6.1.ss" "libtokenizer.fasl"] - ["libassembler-compat-6.6.ss" "libassembler-compat.ss"] - ["libintelasm-6.6.ss" "libintelasm.fasl"] - ["libfasl-6.6.ss" "libfasl.fasl"] - ["libcompile-6.6.ss" "libcompile.fasl"] - ["psyntax-7.1-6.5.ss" "psyntax.fasl"] - ["libinterpret-6.5.ss" "libinterpret.fasl"] - ["libcafe-6.1.ss" "libcafe.fasl"] -; ["libtrace-5.3.ss" "libtrace-5.3.s" "libtrace" ] - ["libposix-6.0.ss" "libposix.fasl"] - ["libhash-6.2.ss" "libhash.fasl"] - ["libtoplevel-6.0.ss" "libtoplevel.fasl"] - )) - - - -(define (compile-library ifile ofile) - (parameterize ([assembler-output #f] [expand-mode 'bootstrap]) - (printf "compiling ~a ...\n" ifile) - (compile-file ifile ofile 'replace))) - -(for-each - (lambda (x) - (compile-library (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 (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)))))))) - -(with-output-to-file "petite-ikarus.ss" - (lambda () - (write - `(begin - (display ,(format "Petite Ikarus Scheme (Build ~a)\n" (get-date))) - (display "Copyright (c) 2006 Abdulaziz Ghuloum\n\n") - (new-cafe)))) - 'replace) - -(compile-library "petite-ikarus.ss" "petite-ikarus.fasl") diff --git a/src/compiler-6.7.ss b/src/compiler-6.7.ss deleted file mode 100644 index b19d43f..0000000 --- a/src/compiler-6.7.ss +++ /dev/null @@ -1,98 +0,0 @@ - - -;;; 6.2: * side-effects now modify the dirty-vector -;;; * added bwp-object? -;;; * added pointer-value -;;; * added tcbuckets -;;; 6.1: * added case-lambda, dropped lambda -;;; 6.0: * basic compiler - -(when (eq? "" "") - (load "chez-compat.ss") - (set! primitive-ref top-level-value) - (set! primitive-set! set-top-level-value!) - (set! chez-expand sc-expand) - (set! chez-current-expand current-expand) - (printf "loading psyntax.pp ...\n") - (load "psyntax-7.1.pp") - (chez-current-expand - (lambda (x . args) - (apply chez-expand (sc-expand x) args))) - (printf "loading psyntax.ss ...\n") - (load "psyntax-7.1-6.5.ss") - (chez-current-expand - (lambda (x . args) - (apply chez-expand (sc-expand x) args))) - (printf "ok\n") - (load "libassembler-compat-6.7.ss") ; defines make-code etc. - (load "libintelasm-6.6.ss") ; uses make-code, etc. - (load "libfasl-6.7.ss") ; uses code? etc. - (load "libcompile-6.7.ss") ; uses fasl-write -) - - - -(define scheme-library-files - '(["libhandlers-6.0.ss" "libhandlers.fasl"] - ["libcontrol-6.1.ss" "libcontrol.fasl"] - ["libcollect-6.1.ss" "libcollect.fasl"] - ["librecord-6.4.ss" "librecord.fasl"] - ["libcxr-6.0.ss" "libcxr.fasl"] - ["libcore-6.2.ss" "libcore.fasl"] - ["libio-6.1.ss" "libio.fasl"] - ["libwriter-6.2.ss" "libwriter.fasl"] - ["libtokenizer-6.1.ss" "libtokenizer.fasl"] - ["libassembler-6.7.ss" "libassembler.ss"] - ["libintelasm-6.6.ss" "libintelasm.fasl"] - ["libfasl-6.7.ss" "libfasl.fasl"] - ["libcompile-6.7.ss" "libcompile.fasl"] - ["psyntax-7.1-6.5.ss" "psyntax.fasl"] - ["libinterpret-6.5.ss" "libinterpret.fasl"] - ["libcafe-6.1.ss" "libcafe.fasl"] -; ["libtrace-5.3.ss" "libtrace-5.3.s" "libtrace" ] - ["libposix-6.0.ss" "libposix.fasl"] - ["libhash-6.2.ss" "libhash.fasl"] - ["libtoplevel-6.0.ss" "libtoplevel.fasl"] - )) - - - -(define (compile-library ifile ofile) - (parameterize ([assembler-output #f] - [expand-mode 'bootstrap]) - (printf "compiling ~a ...\n" ifile) - (compile-file ifile ofile 'replace))) - -(for-each - (lambda (x) - (compile-library (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 (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)))))))) - -(with-output-to-file "petite-ikarus.ss" - (lambda () - (write - `(begin - (display ,(format "Petite Ikarus Scheme (Build ~a)\n" (get-date))) - (display "Copyright (c) 2006 Abdulaziz Ghuloum\n\n") - (new-cafe)))) - 'replace) - -(compile-library "petite-ikarus.ss" "petite-ikarus.fasl") diff --git a/src/compiler-6.8.ss b/src/compiler-6.8.ss deleted file mode 100644 index e12cfaa..0000000 --- a/src/compiler-6.8.ss +++ /dev/null @@ -1,98 +0,0 @@ - - -;;; 6.2: * side-effects now modify the dirty-vector -;;; * added bwp-object? -;;; * added pointer-value -;;; * added tcbuckets -;;; 6.1: * added case-lambda, dropped lambda -;;; 6.0: * basic compiler - -(when (eq? "" "") - (load "chez-compat.ss") - (set! primitive-ref top-level-value) - (set! primitive-set! set-top-level-value!) - (set! chez-expand sc-expand) - (set! chez-current-expand current-expand) - (printf "loading psyntax.pp ...\n") - (load "psyntax-7.1.pp") - (chez-current-expand - (lambda (x . args) - (apply chez-expand (sc-expand x) args))) - (printf "loading psyntax.ss ...\n") - (load "psyntax-7.1-6.5.ss") - (chez-current-expand - (lambda (x . args) - (apply chez-expand (sc-expand x) args))) - (printf "ok\n") - (load "libassembler-compat-6.7.ss") ; defines make-code etc. - (load "libintelasm-6.6.ss") ; uses make-code, etc. - (load "libfasl-6.7.ss") ; uses code? etc. - (load "libcompile-6.7.ss") ; uses fasl-write -) - - - -(define scheme-library-files - '(["libhandlers-6.0.ss" "libhandlers.fasl"] - ["libcontrol-6.1.ss" "libcontrol.fasl"] - ["libcollect-6.1.ss" "libcollect.fasl"] - ["librecord-6.4.ss" "librecord.fasl"] - ["libcxr-6.0.ss" "libcxr.fasl"] - ["libcore-6.2.ss" "libcore.fasl"] - ["libio-6.1.ss" "libio.fasl"] - ["libwriter-6.2.ss" "libwriter.fasl"] - ["libtokenizer-6.1.ss" "libtokenizer.fasl"] - ["libassembler-6.7.ss" "libassembler.ss"] - ["libintelasm-6.6.ss" "libintelasm.fasl"] - ["libfasl-6.7.ss" "libfasl.fasl"] - ["libcompile-6.7.ss" "libcompile.fasl"] - ["psyntax-7.1-6.8.ss" "psyntax.fasl"] - ["libinterpret-6.5.ss" "libinterpret.fasl"] - ["libcafe-6.1.ss" "libcafe.fasl"] -; ["libtrace-5.3.ss" "libtrace-5.3.s" "libtrace" ] - ["libposix-6.0.ss" "libposix.fasl"] - ["libhash-6.2.ss" "libhash.fasl"] - ["libtoplevel-6.0.ss" "libtoplevel.fasl"] - )) - - - -(define (compile-library ifile ofile) - (parameterize ([assembler-output #f] - [expand-mode 'bootstrap]) - (printf "compiling ~a ...\n" ifile) - (compile-file ifile ofile 'replace))) - -(for-each - (lambda (x) - (compile-library (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 (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)))))))) - -(with-output-to-file "petite-ikarus.ss" - (lambda () - (write - `(begin - (display ,(format "Petite Ikarus Scheme (Build ~a)\n" (get-date))) - (display "Copyright (c) 2006 Abdulaziz Ghuloum\n\n") - (new-cafe)))) - 'replace) - -(compile-library "petite-ikarus.ss" "petite-ikarus.fasl") diff --git a/src/compiler-8.1.ss b/src/compiler-8.1.ss index 9480512..1cee6fc 100644 --- a/src/compiler-8.1.ss +++ b/src/compiler-8.1.ss @@ -100,11 +100,11 @@ console-input-port current-input-port standard-output-port standard-error-port console-output-port current-output-port - open-output-file + open-output-file open-input-file open-output-string get-output-string with-output-to-file call-with-output-file with-input-from-file call-with-input-file - + date-string )) @@ -137,11 +137,13 @@ $make-tcbucket $tcbucket-next $tcbucket-key $tcbucket-val $set-tcbucket-next! $set-tcbucket-val! $set-tcbucket-tconc! call/cf trace-symbol! untrace-symbol! make-traced-procedure - fixnum->string date-string + fixnum->string vector-memq vector-memv ;;; must open-code - $make-port + $make-port/input + $make-port/output + $make-port/both $make-input-port $make-output-port $make-input/output-port $port-handler $port-input-buffer $port-input-index $port-input-size @@ -179,7 +181,7 @@ `(begin (define-syntax compile-time-date-string (lambda (x) - #'(quote ,(#%date-string)))) + #'(quote ,(date-string)))) (define-syntax public-primitives (lambda (x) #'(quote ,public-primitives))) @@ -220,7 +222,7 @@ (whack-system-env #t) (printf "ok\n") (load "libassembler-compat-6.7.ss") ; defines make-code etc. - (load "libintelasm-6.6.ss") ; uses make-code, etc. + (load "libintelasm-6.9.ss") ; uses make-code, etc. (load "libfasl-6.7.ss") ; uses code? etc. (load "libcompile-8.1.ss") ; uses fasl-write ) @@ -258,8 +260,7 @@ [expand-mode 'bootstrap] [interaction-environment system-env]) (printf "compiling ~a ...\n" ifile) - (compile-file ifile ofile 'replace) - (printf "done\n"))) + (compile-file ifile ofile 'replace))) (for-each (lambda (x) diff --git a/src/compiler-6.9.ss b/src/compiler-9.0.ss similarity index 70% rename from src/compiler-6.9.ss rename to src/compiler-9.0.ss index 2a10256..f3ab9c7 100644 --- a/src/compiler-6.9.ss +++ b/src/compiler-9.0.ss @@ -1,6 +1,6 @@ -;;; +;;; 8.1: * using chez-style io ports ;;; 6.9: * creating a *system* environment ;;; 6.8: * creating a core-primitive form in the expander ;;; 6.2: * side-effects now modify the dirty-vector @@ -63,16 +63,7 @@ gensym->unique-string call-with-values values make-parameter dynamic-wind - output-port? current-output-port standard-output-port console-output-port - open-output-file close-output-port flush-output-port output-port-name - with-output-to-file with-input-from-file - input-port? current-input-port standard-input-port console-input-port - reset-input-port! - open-input-file close-input-port input-port-name - standard-error-port - open-output-string get-output-string - newline write-char peek-char read-char unread-char - display write fasl-write printf format print-error + display write print-graph fasl-write printf format print-error read-token read error exit call/cc current-error-handler @@ -93,6 +84,28 @@ assembler-output $make-environment features + + port? input-port? output-port? + make-input-port make-output-port make-input/output-port + port-handler + port-input-buffer port-input-index port-input-size + port-output-buffer port-output-index port-output-size + set-port-input-index! set-port-input-size! + set-port-output-index! set-port-output-size! + port-name input-port-name output-port-name + write-char read-char unread-char peek-char + newline + reset-input-port! flush-output-port + close-input-port close-output-port + console-input-port current-input-port + standard-output-port standard-error-port + console-output-port current-output-port + open-output-file open-input-file + open-output-string get-output-string + with-output-to-file call-with-output-file + with-input-from-file call-with-input-file + date-string + )) (define system-primitives @@ -124,8 +137,28 @@ $make-tcbucket $tcbucket-next $tcbucket-key $tcbucket-val $set-tcbucket-next! $set-tcbucket-val! $set-tcbucket-tconc! call/cf trace-symbol! untrace-symbol! make-traced-procedure - fixnum->string date-string + fixnum->string vector-memq vector-memv + + ;;; must open-code + $make-port/input + $make-port/output + $make-port/both + $make-input-port $make-output-port $make-input/output-port + $port-handler + $port-input-buffer $port-input-index $port-input-size + $port-output-buffer $port-output-index $port-output-size + $set-port-input-index! $set-port-input-size! + $set-port-output-index! $set-port-output-size! + + ;;; better open-code + $write-char $read-char $peek-char $unread-char + + ;;; never open-code + $reset-input-port! $close-input-port + $close-output-port $flush-output-port + *standard-output-port* *standard-error-port* *current-output-port* + *standard-input-port* *current-input-port* )) @@ -148,7 +181,7 @@ `(begin (define-syntax compile-time-date-string (lambda (x) - #'(quote ,(#%date-string)))) + #'(quote ,(date-string)))) (define-syntax public-primitives (lambda (x) #'(quote ,public-primitives))) @@ -189,35 +222,35 @@ (whack-system-env #t) (printf "ok\n") (load "libassembler-compat-6.7.ss") ; defines make-code etc. - (load "libintelasm-6.6.ss") ; uses make-code, etc. + (load "libintelasm-6.9.ss") ; uses make-code, etc. (load "libfasl-6.7.ss") ; uses code? etc. - (load "libcompile-6.7.ss") ; uses fasl-write + (load "libcompile-8.1.ss") ; uses fasl-write ) (whack-system-env #t) (define scheme-library-files - '(["libhandlers-6.9.ss" "libhandlers.fasl"] - ["libcontrol-6.1.ss" "libcontrol.fasl"] - ["libcollect-6.1.ss" "libcollect.fasl"] - ["librecord-6.4.ss" "librecord.fasl"] - ["libcxr-6.0.ss" "libcxr.fasl"] - ["libcore-6.9.ss" "libcore.fasl"] - ["libio-6.9.ss" "libio.fasl"] - ["libwriter-6.2.ss" "libwriter.fasl"] - ["libtokenizer-6.1.ss" "libtokenizer.fasl"] - ["libassembler-6.7.ss" "libassembler.ss"] - ["libintelasm-6.9.ss" "libintelasm.fasl"] - ["libfasl-6.7.ss" "libfasl.fasl"] - ["libcompile-6.7.ss" "libcompile.fasl"] - ["psyntax-7.1-6.9.ss" "psyntax.fasl"] - ["libinterpret-6.5.ss" "libinterpret.fasl"] - ["libcafe-6.1.ss" "libcafe.fasl"] - ["libtrace-6.9.ss" "libtrace.fasl"] - ["libposix-6.0.ss" "libposix.fasl"] - ["libhash-6.2.ss" "libhash.fasl"] - ["libtoplevel-6.9.ss" "libtoplevel.fasl"] + '(["libhandlers-6.9.ss" #t "libhandlers.fasl"] + ["libcontrol-6.1.ss" #t "libcontrol.fasl"] + ["libcollect-6.1.ss" #t "libcollect.fasl"] + ["librecord-6.4.ss" #t "librecord.fasl"] + ["libcxr-6.0.ss" #t "libcxr.fasl"] + ["libcore-6.9.ss" #t "libcore.fasl"] + ["libchezio-8.1.ss" #t "libchezio.fasl"] + ["libhash-6.2.ss" #t "libhash.fasl"] + ["libwriter-9.0.ss" #t "libwriter.fasl"] + ["libtokenizer-9.0.ss" #t "libtokenizer.fasl"] + ["libassembler-6.7.ss" #t "libassembler.ss"] + ["libintelasm-6.9.ss" #t "libintelasm.fasl"] + ["libfasl-6.7.ss" #t "libfasl.fasl"] + ["libcompile-9.0.ss" #t "libcompile.fasl"] + ["psyntax-7.1-9.0.ss" #t "psyntax.fasl"] + ["libinterpret-6.5.ss" #t "libinterpret.fasl"] + ["libcafe-6.1.ss" #t "libcafe.fasl"] + ["libtrace-6.9.ss" #t "libtrace.fasl"] + ["libposix-6.0.ss" #t "libposix.fasl"] + ["libtoplevel-6.9.ss" #t "libtoplevel.fasl"] )) @@ -231,7 +264,8 @@ (for-each (lambda (x) - (compile-library (car x) (cadr x))) + (when (cadr x) + (compile-library (car x) (caddr x)))) scheme-library-files) @@ -253,4 +287,4 @@ (system (format "cat ~a > ikarus.fasl" - (join " " (map cadr scheme-library-files)))) + (join " " (map caddr scheme-library-files)))) diff --git a/src/compiler-8.0.ss b/src/compiler-9.1.ss similarity index 68% rename from src/compiler-8.0.ss rename to src/compiler-9.1.ss index bb1a651..160f2e1 100644 --- a/src/compiler-8.0.ss +++ b/src/compiler-9.1.ss @@ -1,6 +1,9 @@ -;;; +;;; 9.1: * starting with libnumerics +;;; 9.0: * graph marks for both reader and writer +;;; * circularity detection during read +;;; 8.1: * using chez-style io ports ;;; 6.9: * creating a *system* environment ;;; 6.8: * creating a core-primitive form in the expander ;;; 6.2: * side-effects now modify the dirty-vector @@ -63,16 +66,7 @@ gensym->unique-string call-with-values values make-parameter dynamic-wind - output-port? current-output-port standard-output-port console-output-port - open-output-file close-output-port flush-output-port output-port-name - with-output-to-file with-input-from-file - input-port? current-input-port standard-input-port console-input-port - reset-input-port! - open-input-file close-input-port input-port-name - standard-error-port - open-output-string get-output-string - newline write-char peek-char read-char unread-char - display write fasl-write printf format print-error + display write print-graph fasl-write printf format print-error read-token read error exit call/cc current-error-handler @@ -93,6 +87,31 @@ assembler-output $make-environment features + + port? input-port? output-port? + make-input-port make-output-port make-input/output-port + port-handler + port-input-buffer port-input-index port-input-size + port-output-buffer port-output-index port-output-size + set-port-input-index! set-port-input-size! + set-port-output-index! set-port-output-size! + port-name input-port-name output-port-name + write-char read-char unread-char peek-char + newline + reset-input-port! flush-output-port + close-input-port close-output-port + console-input-port current-input-port + standard-output-port standard-error-port + console-output-port current-output-port + open-output-file open-input-file + open-output-string get-output-string + with-output-to-file call-with-output-file + with-input-from-file call-with-input-file + date-string + + + - add1 sub1 * expt number? positive? negative? zero? number->string + logand + = < > <= >= )) (define system-primitives @@ -124,13 +143,28 @@ $make-tcbucket $tcbucket-next $tcbucket-key $tcbucket-val $set-tcbucket-next! $set-tcbucket-val! $set-tcbucket-tconc! call/cf trace-symbol! untrace-symbol! make-traced-procedure - fixnum->string date-string + fixnum->string vector-memq vector-memv + ;;; must open-code + $make-port/input + $make-port/output + $make-port/both + $make-input-port $make-output-port $make-input/output-port + $port-handler + $port-input-buffer $port-input-index $port-input-size + $port-output-buffer $port-output-index $port-output-size + $set-port-input-index! $set-port-input-size! + $set-port-output-index! $set-port-output-size! + ;;; better open-code + $write-char $read-char $peek-char $unread-char -port? input-port? output-port? $make-input-port make-input-port $make-output-port make-output-port $make-input/output-port make-input/output-port $port-handler port-handler $port-input-buffer port-input-buffer $port-input-index port-input-index $port-input-size port-input-size $port-output-buffer port-output-buffer $port-output-index port-output-index $port-output-size port-output-size $set-port-input-index! set-port-input-index! $set-port-input-size! set-port-input-size! $set-port-output-index! set-port-output-index! $set-port-output-size! set-port-output-size! $write-char write-char newline port-name input-port-name output-port-name $read-char read-char $unread-char unread-char $peek-char peek-char $unread-char $reset-input-port! reset-input-port! $close-input-port close-input-port $close-output-port close-output-port $flush-output-port flush-output-port *standard-input-port* console-input-port *current-input-port* current-input-port *standard-output-port* *current-output-port* *standard-error-port* standard-output-port standard-error-port console-output-port current-output-port *current-output-port* open-output-file open-output-string get-output-string with-output-to-file call-with-output-file with-input-from-file call-with-input-file - + ;;; never open-code + $reset-input-port! $close-input-port + $close-output-port $flush-output-port + *standard-output-port* *standard-error-port* *current-output-port* + *standard-input-port* *current-input-port* )) @@ -153,7 +187,7 @@ port? input-port? output-port? $make-input-port make-input-port $make-output- `(begin (define-syntax compile-time-date-string (lambda (x) - #'(quote ,(#%date-string)))) + #'(quote ,(date-string)))) (define-syntax public-primitives (lambda (x) #'(quote ,public-primitives))) @@ -194,35 +228,36 @@ port? input-port? output-port? $make-input-port make-input-port $make-output- (whack-system-env #t) (printf "ok\n") (load "libassembler-compat-6.7.ss") ; defines make-code etc. - (load "libintelasm-6.6.ss") ; uses make-code, etc. + (load "libintelasm-6.9.ss") ; uses make-code, etc. (load "libfasl-6.7.ss") ; uses code? etc. - (load "libcompile-6.7.ss") ; uses fasl-write + (load "libcompile-8.1.ss") ; uses fasl-write ) (whack-system-env #t) (define scheme-library-files - '(["libhandlers-6.9.ss" "libhandlers.fasl"] - ["libcontrol-6.1.ss" "libcontrol.fasl"] - ["libcollect-6.1.ss" "libcollect.fasl"] - ["librecord-6.4.ss" "librecord.fasl"] - ["libcxr-6.0.ss" "libcxr.fasl"] - ["libcore-6.9.ss" "libcore.fasl"] - ["libio-6.9.ss" "libio.fasl"] - ["libwriter-6.2.ss" "libwriter.fasl"] - ["libtokenizer-6.1.ss" "libtokenizer.fasl"] - ["libassembler-6.7.ss" "libassembler.ss"] - ["libintelasm-6.9.ss" "libintelasm.fasl"] - ["libfasl-6.7.ss" "libfasl.fasl"] - ["libcompile-6.7.ss" "libcompile.fasl"] - ["psyntax-7.1-6.9.ss" "psyntax.fasl"] - ["libinterpret-6.5.ss" "libinterpret.fasl"] - ["libcafe-6.1.ss" "libcafe.fasl"] - ["libtrace-6.9.ss" "libtrace.fasl"] - ["libposix-6.0.ss" "libposix.fasl"] - ["libhash-6.2.ss" "libhash.fasl"] - ["libtoplevel-6.9.ss" "libtoplevel.fasl"] + '(["libhandlers-6.9.ss" #t "libhandlers.fasl"] + ["libcontrol-6.1.ss" #t "libcontrol.fasl"] + ["libcollect-6.1.ss" #t "libcollect.fasl"] + ["librecord-6.4.ss" #t "librecord.fasl"] + ["libcxr-6.0.ss" #t "libcxr.fasl"] + ["libnumerics-9.1.ss" #t "libnumerics.fasl"] + ["libcore-6.9.ss" #t "libcore.fasl"] + ["libchezio-8.1.ss" #t "libchezio.fasl"] + ["libhash-6.2.ss" #t "libhash.fasl"] + ["libwriter-9.1.ss" #t "libwriter.fasl"] + ["libtokenizer-9.1.ss" #t "libtokenizer.fasl"] + ["libassembler-6.7.ss" #t "libassembler.ss"] + ["libintelasm-6.9.ss" #t "libintelasm.fasl"] + ["libfasl-6.7.ss" #t "libfasl.fasl"] + ["libcompile-9.1.ss" #t "libcompile.fasl"] + ["psyntax-7.1-9.1.ss" #t "psyntax.fasl"] + ["libinterpret-6.5.ss" #t "libinterpret.fasl"] + ["libcafe-6.1.ss" #t "libcafe.fasl"] + ["libtrace-6.9.ss" #t "libtrace.fasl"] + ["libposix-6.0.ss" #t "libposix.fasl"] + ["libtoplevel-6.9.ss" #t "libtoplevel.fasl"] )) @@ -236,7 +271,8 @@ port? input-port? output-port? $make-input-port make-input-port $make-output- (for-each (lambda (x) - (compile-library (car x) (cadr x))) + (when (cadr x) + (compile-library (car x) (caddr x)))) scheme-library-files) @@ -258,4 +294,4 @@ port? input-port? output-port? $make-input-port make-input-port $make-output- (system (format "cat ~a > ikarus.fasl" - (join " " (map cadr scheme-library-files)))) + (join " " (map caddr scheme-library-files)))) diff --git a/src/compiler-9.2.ss b/src/compiler-9.2.ss new file mode 100644 index 0000000..086d32e --- /dev/null +++ b/src/compiler-9.2.ss @@ -0,0 +1,301 @@ + + +;;; 9.1: * starting with libnumerics +;;; 9.0: * graph marks for both reader and writer +;;; * circularity detection during read +;;; 8.1: * using chez-style io ports +;;; 6.9: * creating a *system* environment +;;; 6.8: * creating a core-primitive form in the expander +;;; 6.2: * side-effects now modify the dirty-vector +;;; * added bwp-object? +;;; * added pointer-value +;;; * added tcbuckets +;;; 6.1: * added case-lambda, dropped lambda +;;; 6.0: * basic compiler + + + + +(define macros + '(|#primitive| lambda case-lambda set! quote begin define if letrec + foreign-call $apply + quasiquote unquote unquote-splicing + define-syntax identifier-syntax let-syntax letrec-syntax + fluid-let-syntax alias meta eval-when with-implicit with-syntax + type-descriptor + syntax-case syntax-rules module $module import $import import-only + syntax quasisyntax unsyntax unsyntax-splicing datum + let let* let-values cond case define-record or and when unless do + include parameterize trace untrace trace-lambda)) + + + +(define public-primitives + '(null? pair? char? fixnum? symbol? gensym? string? vector? list? + boolean? procedure? + not + eof-object eof-object? bwp-object? + void + fx= fx< fx<= fx> fx>= fxzero? + fx+ fx- fx* fxadd1 fxsub1 fxquotient fxremainder fxmodulo + fxsll fxsra fxlognot fxlogor fxlogand fxlogxor + integer->char char->integer + char=? char? char>=? + cons car cdr set-car! set-cdr! + caar cadr cdar cddr + caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + list list* make-list length list-ref + append + make-vector vector-ref vector-set! vector-length vector + vector->list list->vector + make-string string-ref string-set! string-length string list->string + uuid + string-append substring + string=? string? string>=? + remprop putprop getprop property-list + apply + map for-each andmap ormap + memq memv assq + eq? equal? + reverse + string->symbol symbol->string oblist + top-level-value set-top-level-value! top-level-bound? + gensym gensym-count gensym-prefix print-gensym + gensym->unique-string + call-with-values values + make-parameter dynamic-wind + display write print-graph fasl-write printf format print-error + read-token read + error exit call/cc + current-error-handler + eval current-eval interpret compile compile-file new-cafe load + system + expand sc-expand current-expand expand-mode + environment? interaction-environment + identifier? free-identifier=? bound-identifier=? literal-identifier=? + datum->syntax-object syntax-object->datum syntax-error + syntax->list + generate-temporaries + record? record-set! record-ref record-length + record-type-descriptor make-record-type + record-printer record-name record-field-accessor + record-field-mutator record-predicate record-constructor + record-type-name record-type-symbol record-type-field-names + hash-table? make-hash-table get-hash-table put-hash-table! + assembler-output + $make-environment + features + + port? input-port? output-port? + make-input-port make-output-port make-input/output-port + port-handler + port-input-buffer port-input-index port-input-size + port-output-buffer port-output-index port-output-size + set-port-input-index! set-port-input-size! + set-port-output-index! set-port-output-size! + port-name input-port-name output-port-name + write-char read-char unread-char peek-char + newline + reset-input-port! flush-output-port + close-input-port close-output-port + console-input-port current-input-port + standard-output-port standard-error-port + console-output-port current-output-port + open-output-file open-input-file + open-output-string get-output-string + with-output-to-file call-with-output-file + with-input-from-file call-with-input-file + date-string + + + - add1 sub1 * expt number? positive? negative? zero? number->string + logand + = < > <= >= + )) + +(define system-primitives + '(immediate? $unbound-object? $forward-ptr? + pointer-value + primitive-ref primitive-set! + $fx= $fx< $fx<= $fx> $fx>= $fxzero? + $fx+ $fx- $fx* $fxadd1 $fxsub1 $fxquotient $fxremainder $fxmodulo + $fxsll $fxsra $fxlognot $fxlogor $fxlogand $fxlogxor + $fixnum->char $char->fixnum + $char= $char< $char<= $char> $char>= + $car $cdr $set-car! $set-cdr! + $make-vector $vector-ref $vector-set! $vector-length + $make-string $string-ref $string-set! $string-length $string + $symbol-string $symbol-unique-string $symbol-value + $set-symbol-string! $set-symbol-unique-string! $set-symbol-value! + $make-symbol $set-symbol-plist! $symbol-plist + $sc-put-cte + $record? $record/rtd? $record-set! $record-ref $record-rtd + $make-record $record + $base-rtd + $code? $code-reloc-vector $code-freevars $code-size $code-ref $code-set! + $code->closure list*->code* + make-code code? set-code-reloc-vector! code-reloc-vector code-freevars + code-size code-ref code-set! + $frame->continuation $fp-at-base $current-frame $seal-frame-and-call + $make-call-with-values-procedure $make-values-procedure + do-overflow collect + $make-tcbucket $tcbucket-next $tcbucket-key $tcbucket-val + $set-tcbucket-next! $set-tcbucket-val! $set-tcbucket-tconc! + $tcbucket-dlink-prev + $tcbucket-dlink-next + $set-tcbucket-dlink-prev! + $set-tcbucket-dlink-next! + call/cf trace-symbol! untrace-symbol! make-traced-procedure + fixnum->string + vector-memq vector-memv + + ;;; must open-code + $make-port/input + $make-port/output + $make-port/both + $make-input-port $make-output-port $make-input/output-port + $port-handler + $port-input-buffer $port-input-index $port-input-size + $port-output-buffer $port-output-index $port-output-size + $set-port-input-index! $set-port-input-size! + $set-port-output-index! $set-port-output-size! + + ;;; better open-code + $write-char $read-char $peek-char $unread-char + + ;;; never open-code + $reset-input-port! $close-input-port + $close-output-port $flush-output-port + *standard-output-port* *standard-error-port* *current-output-port* + *standard-input-port* *current-input-port* + )) + + + +(define (whack-system-env setenv?) + (define add-prim + (lambda (x) + (let ([g (gensym (symbol->string x))]) + (putprop x '|#system| g) + (putprop g '*sc-expander* (cons 'core-primitive x))))) + (define add-macro + (lambda (x) + (let ([g (gensym (symbol->string x))] + [e (getprop x '*sc-expander*)]) + (when e + (putprop x '|#system| g) + (putprop g '*sc-expander* e))))) + (define (foo) + (eval + `(begin + (define-syntax compile-time-date-string + (lambda (x) + #'(quote ,(date-string)))) + (define-syntax public-primitives + (lambda (x) + #'(quote ,public-primitives))) + (define-syntax system-primitives + (lambda (x) + #'(quote ,system-primitives))) + (define-syntax macros + (lambda (x) + #'(quote ,macros)))))) + (set! system-env ($make-environment '|#system| #t)) + (for-each add-macro macros) + (for-each add-prim public-primitives) + (for-each add-prim system-primitives) + (if setenv? + (parameterize ([interaction-environment system-env]) + (foo)) + (foo))) + + + +(when (eq? "" "") + (load "chez-compat.ss") + (set! primitive-ref top-level-value) + (set! primitive-set! set-top-level-value!) + (set! chez-expand sc-expand) + (set! chez-current-expand current-expand) + (printf "loading psyntax.pp ...\n") + (load "psyntax-7.1.pp") + (chez-current-expand + (lambda (x . args) + (apply chez-expand (sc-expand x) args))) + (whack-system-env #f) + (printf "loading psyntax.ss ...\n") + (load "psyntax-7.1-6.9.ss") + (chez-current-expand + (lambda (x . args) + (apply chez-expand (sc-expand x) args))) + (whack-system-env #t) + (printf "ok\n") + (load "libassembler-compat-6.7.ss") ; defines make-code etc. + (load "libintelasm-6.9.ss") ; uses make-code, etc. + (load "libfasl-6.7.ss") ; uses code? etc. + (load "libcompile-8.1.ss") ; uses fasl-write +) + + +(whack-system-env #t) + +(define scheme-library-files + '(["libhandlers-6.9.ss" #t "libhandlers.fasl"] + ["libcontrol-6.1.ss" #t "libcontrol.fasl"] + ["libcollect-6.1.ss" #t "libcollect.fasl"] + ["librecord-6.4.ss" #t "librecord.fasl"] + ["libcxr-6.0.ss" #t "libcxr.fasl"] + ["libnumerics-9.1.ss" #t "libnumerics.fasl"] + ["libcore-6.9.ss" #t "libcore.fasl"] + ["libchezio-8.1.ss" #t "libchezio.fasl"] + ["libhash-9.2.ss" #t "libhash.fasl"] + ["libwriter-9.1.ss" #t "libwriter.fasl"] + ["libtokenizer-9.1.ss" #t "libtokenizer.fasl"] + ["libassembler-6.7.ss" #t "libassembler.ss"] + ["libintelasm-6.9.ss" #t "libintelasm.fasl"] + ["libfasl-6.7.ss" #t "libfasl.fasl"] + ["libcompile-9.1.ss" #t "libcompile.fasl"] + ["psyntax-7.1-9.1.ss" #t "psyntax.fasl"] + ["libinterpret-6.5.ss" #t "libinterpret.fasl"] + ["libcafe-6.1.ss" #t "libcafe.fasl"] + ["libtrace-6.9.ss" #t "libtrace.fasl"] + ["libposix-6.0.ss" #t "libposix.fasl"] + ["libtoplevel-6.9.ss" #t "libtoplevel.fasl"] + )) + + + +(define (compile-library ifile ofile) + (parameterize ([assembler-output #f] + [expand-mode 'bootstrap] + [interaction-environment system-env]) + (printf "compiling ~a ...\n" ifile) + (compile-file ifile ofile 'replace))) + +(for-each + (lambda (x) + (when (cadr x) + (compile-library (car x) (caddr x)))) + scheme-library-files) + + +(define (join s ls) + (cond + [(null? ls) ""] + [else + (let ([str (open-output-string)]) + (let f ([a (car ls)] [d (cdr ls)]) + (cond + [(null? d) + (display a str) + (get-output-string str)] + [else + (display a str) + (display s str) + (f (car d) (cdr d))])))])) + + +(system + (format "cat ~a > ikarus.fasl" + (join " " (map caddr scheme-library-files)))) diff --git a/src/fact.ss b/src/fact.ss new file mode 100644 index 0000000..9ddb8df --- /dev/null +++ b/src/fact.ss @@ -0,0 +1,6 @@ + +(define (fact n ac) + (if (zero? n) + ac + (fact (- n 1) (* n ac)))) +(begin (fact 10000 1) #f) diff --git a/src/generate-cxr.ss b/src/generate-cxr.ss deleted file mode 100644 index 48e0621..0000000 --- a/src/generate-cxr.ss +++ /dev/null @@ -1,52 +0,0 @@ - -(define generate-cxr-definitions - (lambda () - (define gen-body - (lambda (name arg ls) - (cond - [(null? (cdr ls)) - `(if (pair? ,arg) - (,(car ls) ,arg) - (err ',name orig))] - [else - (let ([a (car ls)]) - `(if (pair? ,arg) - (let ([x (,a ,arg)]) - ,(gen-body name 'x (cdr ls))) - (err ',name orig)))]))) - (define gen-cxr - (lambda (name ls) - `(primitive-set! ',name (lambda (orig) ,(gen-body name 'orig ls))))) - (define gen-names-n - (lambda (n) - (cond - [(fx= n 0) '(())] - [else - (let ([ls (gen-names-n (fx- n 1))]) - (append - (map (lambda (x) (cons #\a x)) ls) - (map (lambda (x) (cons #\d x)) ls)))]))) - (define gen-names - (lambda (n) - (cond - [(fx= n 0) '()] - [else (append (gen-names (fx- n 1)) (gen-names-n n))]))) - (define ls->name - (lambda (ls) - (string->symbol (list->string (append '(#\c) ls '(#\r)))))) - (define ls->functions - (lambda (ls) - (reverse - (map (lambda (c) (string->symbol (format "$c~ar" c))) ls)))) - `(let ([err - (lambda (who x) - (error who "invalid list structure ~s" x))]) - ,@(map - (lambda (ls) (gen-cxr (ls->name ls) (ls->functions ls))) - (gen-names 4))))) - -(with-output-to-file "libcxr-6.0.ss" - (lambda () - (pretty-print (generate-cxr-definitions))) - 'replace) - diff --git a/src/geninstr/gen.pl b/src/geninstr/gen.pl index 188e773..13b6515 100755 --- a/src/geninstr/gen.pl +++ b/src/geninstr/gen.pl @@ -48,10 +48,8 @@ sub gen3{ } } -gen1 "movl \$0x1234, r1\n"; - -#gen1 "movl \$27, 4(r1)\n"; -#gen1 "movl \$27, 4000(r1)\n"; +gen1 "movl \$27, 4(r1)\n"; +gen1 "movl \$27, 4000(r1)\n"; #gen1 "movb \$0, 4(r1)\n"; #gen1 "movb -2(r1), %ah\n"; diff --git a/src/geninstr/tmp.dump b/src/geninstr/tmp.dump index d0c65b1..821d007 100644 --- a/src/geninstr/tmp.dump +++ b/src/geninstr/tmp.dump @@ -4,11 +4,28 @@ tmp.o: file format elf32-i386 Disassembly of section .text: 00000000 <.text>: - 0: b8 34 12 00 00 mov $0x1234,%eax - 5: b9 34 12 00 00 mov $0x1234,%ecx - a: ba 34 12 00 00 mov $0x1234,%edx - f: bb 34 12 00 00 mov $0x1234,%ebx - 14: bc 34 12 00 00 mov $0x1234,%esp - 19: bd 34 12 00 00 mov $0x1234,%ebp - 1e: be 34 12 00 00 mov $0x1234,%esi - 23: bf 34 12 00 00 mov $0x1234,%edi + 0: c7 40 04 1b 00 00 00 movl $0x1b,0x4(%eax) + 7: c7 41 04 1b 00 00 00 movl $0x1b,0x4(%ecx) + e: c7 42 04 1b 00 00 00 movl $0x1b,0x4(%edx) + 15: c7 43 04 1b 00 00 00 movl $0x1b,0x4(%ebx) + 1c: c7 44 24 04 1b 00 00 movl $0x1b,0x4(%esp) + 23: 00 + 24: c7 45 04 1b 00 00 00 movl $0x1b,0x4(%ebp) + 2b: c7 46 04 1b 00 00 00 movl $0x1b,0x4(%esi) + 32: c7 47 04 1b 00 00 00 movl $0x1b,0x4(%edi) + 39: c7 80 a0 0f 00 00 1b movl $0x1b,0xfa0(%eax) + 40: 00 00 00 + 43: c7 81 a0 0f 00 00 1b movl $0x1b,0xfa0(%ecx) + 4a: 00 00 00 + 4d: c7 82 a0 0f 00 00 1b movl $0x1b,0xfa0(%edx) + 54: 00 00 00 + 57: c7 83 a0 0f 00 00 1b movl $0x1b,0xfa0(%ebx) + 5e: 00 00 00 + 61: c7 84 24 a0 0f 00 00 movl $0x1b,0xfa0(%esp) + 68: 1b 00 00 00 + 6c: c7 85 a0 0f 00 00 1b movl $0x1b,0xfa0(%ebp) + 73: 00 00 00 + 76: c7 86 a0 0f 00 00 1b movl $0x1b,0xfa0(%esi) + 7d: 00 00 00 + 80: c7 87 a0 0f 00 00 1b movl $0x1b,0xfa0(%edi) + 87: 00 00 00 diff --git a/src/geninstr/tmp.s b/src/geninstr/tmp.s index 2bc8fb8..ea423d1 100644 --- a/src/geninstr/tmp.s +++ b/src/geninstr/tmp.s @@ -1,9 +1,17 @@ .text -movl $0x1234, %eax -movl $0x1234, %ecx -movl $0x1234, %edx -movl $0x1234, %ebx -movl $0x1234, %esp -movl $0x1234, %ebp -movl $0x1234, %esi -movl $0x1234, %edi +movl $27, 4(%eax) +movl $27, 4(%ecx) +movl $27, 4(%edx) +movl $27, 4(%ebx) +movl $27, 4(%esp) +movl $27, 4(%ebp) +movl $27, 4(%esi) +movl $27, 4(%edi) +movl $27, 4000(%eax) +movl $27, 4000(%ecx) +movl $27, 4000(%edx) +movl $27, 4000(%ebx) +movl $27, 4000(%esp) +movl $27, 4000(%ebp) +movl $27, 4000(%esi) +movl $27, 4000(%edi) diff --git a/src/ikarus.fasl b/src/ikarus.fasl index 4fad35e..417845b 100644 Binary files a/src/ikarus.fasl and b/src/ikarus.fasl differ diff --git a/src/libassembler-compat-6.0.ss b/src/libassembler-compat-6.0.ss deleted file mode 100644 index 2056db0..0000000 --- a/src/libassembler-compat-6.0.ss +++ /dev/null @@ -1,67 +0,0 @@ - -(let () - (define-record code (closure-size code-vec reloc-vec)) - - (define make-code^ - (lambda (code-size reloc-size closure-size) - (let ([code-size (fxsll (fxsra (fx+ code-size 3) 2) 2)]) - (make-code - closure-size - (make-string code-size (integer->char 0)) - (make-vector (fxsra reloc-size 2)))))) - - (define set-code-byte! - (lambda (code idx byte) - (string-set! (code-code-vec code) idx (integer->char byte)))) - - (define set-code-word! - (lambda (code idx x) - (cond - [(fixnum? x) - (set-code-byte! code (fx+ idx 0) (fxsll (fxlogand x #x3F) 2)) - (set-code-byte! code (fx+ idx 1) (fxlogand (fxsra x 6) #xFF)) - (set-code-byte! code (fx+ idx 2) (fxlogand (fxsra x 14) #xFF)) - (set-code-byte! code (fx+ idx 3) (fxlogand (fxsra x 22) #xFF))] - [else (error 'set-code-word! "unhandled ~s" x)]))) - - (define set-code-object! - (lambda (code obj code-idx reloc-idx) - (let ([v (code-reloc-vec code)]) - (vector-set! v reloc-idx (list 'object code-idx obj))))) - - (define set-code-foreign-object! - (lambda (code obj code-idx reloc-idx) - (let ([v (code-reloc-vec code)]) - (vector-set! v reloc-idx (list 'foreign code-idx obj)) - (vector-set! v (fxadd1 reloc-idx) '(skip))))) - - (define set-code-object+offset/rel! - (lambda (code obj code-idx obj-idx reloc-idx) - (let ([v (code-reloc-vec code)]) - (vector-set! v reloc-idx - (list 'object+off/rel code-idx obj obj-idx)) - (vector-set! v (fxadd1 reloc-idx) '(skip))))) - - (define set-code-object+offset! - (lambda (code obj code-idx obj-idx reloc-idx) - (let ([v (code-reloc-vec code)]) - (vector-set! v reloc-idx - (list 'object+off code-idx obj obj-idx)) - (vector-set! v (fxadd1 reloc-idx) '(skip))))) - - (define make-code-executable! - (lambda (x) (void))) - - (primitive-set! 'make-code make-code^) - (primitive-set! 'code? code?) - (primitive-set! 'code-code-vec code-code-vec) - (primitive-set! 'code-reloc-vec code-reloc-vec) - (primitive-set! 'code-closure-size code-closure-size) - (primitive-set! 'set-code-byte! set-code-byte!) - (primitive-set! 'set-code-word! set-code-word!) - (primitive-set! 'set-code-object! set-code-object!) - (primitive-set! 'set-code-foreign-object! set-code-foreign-object!) - (primitive-set! 'set-code-object+offset/rel! set-code-object+offset/rel!) - (primitive-set! 'set-code-object+offset! set-code-object+offset!) - (primitive-set! 'make-code-executable! make-code-executable!)) - diff --git a/src/libassembler-compat-6.6.ss b/src/libassembler-compat-6.6.ss deleted file mode 100644 index 3dfffec..0000000 --- a/src/libassembler-compat-6.6.ss +++ /dev/null @@ -1,32 +0,0 @@ - -(let () - (define-record code (closure-size code-string reloc-vector)) - - (define make-code^ - (lambda (code-size closure-size) - (let ([code-size (fxsll (fxsra (fx+ code-size 3) 2) 2)]) - (make-code - closure-size - (make-string code-size) - #f)))) - - (define code-set! - (lambda (code idx byte) - (string-set! (code-code-string code) idx (integer->char byte)))) - - (define code-ref - (lambda (code idx) - (char->integer (string-ref (code-code-string code) idx)))) - - (define (code-size code) - (string-length (code-code-string code))) - - (primitive-set! 'make-code make-code^) - (primitive-set! 'code? code?) - (primitive-set! 'code-reloc-vector code-reloc-vector) - (primitive-set! 'code-closure-size code-closure-size) - (primitive-set! 'code-size code-size) - (primitive-set! 'code-set! code-set!) - (primitive-set! 'code-ref code-ref) - (primitive-set! 'set-code-reloc-vector! set-code-reloc-vector!)) - diff --git a/src/libassembler-compat-6.7.ss b/src/libassembler-compat-6.7.ss deleted file mode 100644 index dd34e27..0000000 --- a/src/libassembler-compat-6.7.ss +++ /dev/null @@ -1,32 +0,0 @@ - -(let () - (define-record code (freevars code-string reloc-vector)) - - (define make-code^ - (lambda (code-size freevars) - (let ([code-size (fxsll (fxsra (fx+ code-size 3) 2) 2)]) - (make-code - freevars - (make-string code-size) - #f)))) - - (define code-set! - (lambda (code idx byte) - (string-set! (code-code-string code) idx (integer->char byte)))) - - (define code-ref - (lambda (code idx) - (char->integer (string-ref (code-code-string code) idx)))) - - (define (code-size code) - (string-length (code-code-string code))) - - (primitive-set! 'make-code make-code^) - (primitive-set! 'code? code?) - (primitive-set! 'code-reloc-vector code-reloc-vector) - (primitive-set! 'code-freevars code-freevars) - (primitive-set! 'code-size code-size) - (primitive-set! 'code-set! code-set!) - (primitive-set! 'code-ref code-ref) - (primitive-set! 'set-code-reloc-vector! set-code-reloc-vector!)) - diff --git a/src/libassembler-compat.ss b/src/libassembler-compat.ss deleted file mode 100644 index 12406b2..0000000 Binary files a/src/libassembler-compat.ss and /dev/null differ diff --git a/src/libassembler.ss b/src/libassembler.ss index b748820..ada0aa2 100644 Binary files a/src/libassembler.ss and b/src/libassembler.ss differ diff --git a/src/libcafe-6.0.ss b/src/libcafe-6.0.ss deleted file mode 100644 index 8968cef..0000000 --- a/src/libcafe-6.0.ss +++ /dev/null @@ -1,72 +0,0 @@ -(let () - (define with-error-handler - (lambda (p thunk) - (let ([old-error-handler (current-error-handler)]) - (dynamic-wind - (lambda () - (current-error-handler - (lambda args - (current-error-handler old-error-handler) - (apply p args) - (apply error args)))) - thunk - (lambda () - (current-error-handler old-error-handler)))))) - - (define eval-depth 0) - - (define display-prompt - (lambda (i) - (if (fx= i eval-depth) - (display " " (console-output-port)) - (begin - (display ">" (console-output-port)) - (display-prompt (fx+ i 1)))))) - - (define wait - (lambda (eval escape-k) - (call/cc - (lambda (k) - (with-error-handler - (lambda args - (reset-input-port! (console-input-port)) - (apply print-error args) - (k (void))) - (lambda () - (display-prompt 0) - (let ([x (read (console-input-port))]) - (cond - [(eof-object? x) - (newline (console-output-port)) - (escape-k (void))] - [else - (call-with-values - (lambda () (eval x)) - (lambda v* - (unless (andmap (lambda (v) (eq? v (void))) v*) - (for-each - (lambda (v) - (write v (console-output-port)) - (newline (console-output-port))) - v*))))])))))) - (wait eval escape-k))) - - (primitive-set! 'new-cafe - (lambda args - (let ([eval - (if (null? args) - (current-eval) - (if (null? (cdr args)) - (let ([f (car args)]) - (if (procedure? f) - f - (error 'new-cafe "not a procedure ~s" f))) - (error 'new-cafe "too many arguments")))]) - (dynamic-wind - (lambda () (set! eval-depth (fxadd1 eval-depth))) - (lambda () - (call/cc - (lambda (k) - (wait eval k)))) - (lambda () (set! eval-depth (fxsub1 eval-depth)))))))) - diff --git a/src/libcafe-6.1.ss b/src/libcafe-6.1.ss index 34cae3c..53f07bc 100644 --- a/src/libcafe-6.1.ss +++ b/src/libcafe-6.1.ss @@ -30,6 +30,7 @@ (with-error-handler (lambda args (reset-input-port! (console-input-port)) + ;(display "repl catch\n" (console-output-port)) (apply print-error args) (k (void))) (lambda () diff --git a/src/libcafe.fasl b/src/libcafe.fasl index b36efff..379812f 100644 Binary files a/src/libcafe.fasl and b/src/libcafe.fasl differ diff --git a/src/libchezio-8.1.ss b/src/libchezio-8.1.ss index 3f577c7..c66a5b6 100644 --- a/src/libchezio-8.1.ss +++ b/src/libchezio-8.1.ss @@ -26,27 +26,30 @@ ;;; (port-output-size port) ;;; ;;; * Mutators: + ;;; (set-port-handler! port proc) + ;;; (set-port-input-buffer! port string) ;;; (set-port-input-index! port fixnum) ;;; (set-port-input-size! port fixnum) + ;;; (set-port-output-buffer! port string) ;;; (set-port-output-index! port fixnum) ;;; (set-port-output-size! port fixnum) ;;; - ;;; (begin - ;;; ;;; uncomment this form to use the compiler's definition - ;;; ;;; of ports; otherwise, ports are represented as vanilla - ;;; ;;; records. - ;;; ($define-record-syntax port - ;;; (handler input-buffer input-index input-size - ;;; output-buffer output-index output-size)) - ;;; (define-syntax port? (identifier-syntax $port?)) - ;;; (define-syntax input-port? - ;;; (syntax-rules () - ;;; [(_ x) (identifier? #'x) - ;;; (and ($port? x) (string? ($port-input-buffer x)))])) - ;;; (define-syntax output-port? - ;;; (syntax-rules () - ;;; [(_ x) (identifier? #'x) - ;;; (and ($port? x) (string? ($port-output-buffer x)))]))) + #;(begin + ;;; uncomment this form to use the compiler's definition + ;;; of ports; otherwise, ports are represented as vanilla + ;;; records. + ($define-record-syntax port + (handler input-buffer input-index input-size + output-buffer output-index output-size)) + (define-syntax port? (identifier-syntax $port?)) + (define-syntax input-port? + (syntax-rules () + [(_ x) (identifier? #'x) + (and ($port? x) (string? ($port-input-buffer x)))])) + (define-syntax output-port? + (syntax-rules () + [(_ x) (identifier? #'x) + (and ($port? x) (string? ($port-output-buffer x)))]))) ;;; (primitive-set! 'port? (lambda (x) (port? x))) @@ -59,7 +62,7 @@ ;;; (primitive-set! '$make-input-port (lambda (handler buffer) - ($make-port handler buffer 0 ($string-length buffer) #f 0 0))) + ($make-port/input handler buffer 0 ($string-length buffer) #f 0 0))) ;;; (primitive-set! 'make-input-port (lambda (handler buffer) @@ -71,7 +74,7 @@ ;;; (primitive-set! '$make-output-port (lambda (handler buffer) - ($make-port handler #f 0 0 buffer 0 ($string-length buffer)))) + ($make-port/output handler #f 0 0 buffer 0 ($string-length buffer)))) ;;; (primitive-set! 'make-output-port (lambda (handler buffer) @@ -83,7 +86,7 @@ ;;; (primitive-set! '$make-input/output-port (lambda (handler input-buffer output-buffer) - ($make-port handler + ($make-port/both handler input-buffer 0 ($string-length input-buffer) output-buffer 0 ($string-length output-buffer)))) (primitive-set! 'make-input/output-port @@ -235,7 +238,7 @@ ;;; (primitive-set! '$write-char (lambda (c p) - (let ([idx ($port-output-index p)]) + (let ([idx (port-output-index p)]) (if ($fx< idx ($port-output-size p)) (begin ($string-set! ($port-output-buffer p) idx c) @@ -286,7 +289,7 @@ ;;; (primitive-set! 'read-char (case-lambda - [() ($read-char (current-input-port))] + [() ($read-char *current-input-port*)] [(p) (if (input-port? p) ($read-char p) diff --git a/src/libcollect-6.0.ss b/src/libcollect-6.0.ss deleted file mode 100644 index 86ef942..0000000 --- a/src/libcollect-6.0.ss +++ /dev/null @@ -1,28 +0,0 @@ - -;(primitive-set! 'do-overflow -; (lambda () -; ($do-overflow 4096))) - -(primitive-set! 'do-overflow - (lambda (n) - (foreign-call "ik_collect" n) - (void))) - -(primitive-set! 'do-overflow-words - (lambda (n) - (foreign-call "ik_collect" ($fxsll n 2)) - (void))) - -(primitive-set! 'do-vararg-overflow - (lambda (n) - (foreign-call "ik_collect_vararg" n) - (void))) - -(primitive-set! 'collect - (lambda () - (do-overflow 4096))) - -(primitive-set! 'do-stack-overflow - (lambda () - (foreign-call "ik_stack_overflow"))) - diff --git a/src/libcollect.fasl b/src/libcollect.fasl index 3491553..0a42a3e 100644 Binary files a/src/libcollect.fasl and b/src/libcollect.fasl differ diff --git a/src/libcompile-6.4.ss b/src/libcompile-6.4.ss deleted file mode 100644 index 2bb199a..0000000 --- a/src/libcompile-6.4.ss +++ /dev/null @@ -1,3035 +0,0 @@ - - -;;; 6.2: * side-effects now modify the dirty-vector -;;; * added bwp-object? -;;; * added pointer-value -;;; * added tcbuckets -;;; 6.1: * added case-lambda, dropped lambda -;;; 6.0: * basic compiler - -(let () - -(include "record-case.ss") - - -(include "set-operations.ss") - - -(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] - [bwp-object? 1 pred] - [$unbound-object? 1 pred] - [$forward-ptr? 1 pred] - [not 1 pred] - [pointer-value 1 value] - [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] - ;;; tcbuckets - [$make-tcbucket 4 value] - [$tcbucket-key 1 value] - [$tcbucket-val 1 value] - [$tcbucket-next 1 value] - [$set-tcbucket-val! 2 effect] - [$set-tcbucket-next! 2 effect] - [$set-tcbucket-tconc! 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] - ;;; - ;;; asm - ;;; - ;[code? 1 pred] - ;[$code-instr-size 1 value] - ;[$code-reloc-size 1 value] - ;[$code-closure-size 1 value] - ;[$code->closure 1 value] - ;[$set-code-byte! 3 effect] - ;[$set-code-word! 3 effect] - ;[$set-code-object! 4 effect] - ;[$set-code-object+offset! 5 effect] - ;[$set-code-object+offset/rel! 5 effect] - ;;; - [$make-call-with-values-procedure 0 value] - [$make-values-procedure 0 value] - [$install-underflow-handler 0 effect] - )) - -(define (primitive-context x) - (cond - [(assq x open-coded-primitives) => caddr] - [else (error 'primitive-context "unknown prim ~s" x)])) - - -;;; primitives table section -(define primitives-table - '(;;; system locations used by the C/Scheme interface - [$apply-nonprocedure-error-handler library] - [$incorrect-args-error-handler library] - [$multiple-values-error library] - [$intern library] - [do-overflow library] - [do-vararg-overflow library] - [do-stack-overflow library] - ;;; type predicates - [fixnum? public] - [immediate? public] - [boolean? public] - [char? public] - [null? public] - [pair? public] - [symbol? public] - [vector? public] - [string? public] - [procedure? public] - [eof-object? public] - [not public] - [eq? public] - [equal? public] - ;;; fixnum primitives - [fxadd1 public] - [fxsub1 public] - [fx+ public] - [fx- public] - [fx* public] - [fxsll public] - [fxsra public] - [fxlogor public] - [fxlogand public] - [fxlogxor public] - [fxlognot public] - [fxquotient public] - [fxremainder public] - [fxmodulo public] - ;;; fixnum predicates - [fxzero? public] - [fx= public] - [fx< public] - [fx<= public] - [fx> public] - [fx>= public] - ;;; characters - [char=? public] - [char? public] - [char>=? public] - [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] - [memv 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] - [primitive-set! 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] - [syntax-error public] - [current-expand public] - [expand-mode public] - [assembler-output public] - [compile-file public] - [fasl-write public] - - [$sc-put-cte public] - [sc-expand public] - [$make-environment public] - [environment? public] - [interaction-environment public] - [identifier? public] - [syntax->list public] - [syntax-object->datum public] - [datum->syntax-object public] - [generate-temporaries public] - [free-identifier=? public] - [bound-identifier=? public] - [literal-identifier=? public] - [syntax-error public] - [$syntax-dispatch public] - - - - [interpret public] - [eval public] - [current-eval public] - [load public] - [new-cafe public] - [collect public] - [call/cc public] - [call/cf library] - [dynamic-wind public] - [values public] - [call-with-values public] - [make-traced-procedure library] - [trace-symbol! library] - [untrace-symbol! library] - ;;; record - [$base-rtd library] - [record? public] - [record-rtd public] - [record-name public] - [record-printer public] - [record-length public] - [record-ref public] - [record-set! public] - ;;; record rtds - [make-record-type public] - [record-type-name public] - [record-type-descriptor public] - [record-type-symbol public] - [record-type-field-names public] - [record-constructor public] - [record-predicate public] - [record-field-accessor public] - [record-field-mutator public] - ;;; hash tables - [make-hash-table public] - [hash-table? public] - [get-hash-table public] - [put-hash-table! 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-reloc-vec public] - [code-code-vec public] - [code->closure public] - [list*->code* library] - ;;; - ;;; POSIX - ;;; - [fork public] - [posix-fork public] - [system public] - [$debug public] - [$underflow-misaligned-error public] - )) - - -(define (primitive? x) - (cond - [(assq x primitives-table) #t] - [(assq x open-coded-primitives) #t] - [else #f])) - -(define (open-codeable? x) - (cond - [(assq x open-coded-primitives) #t] - [(assq x primitives-table) #f] - [else (error 'open-codeable "invalid primitive ~s" x)])) - -(define (open-coded-primitive-args x) - (cond - [(assq x open-coded-primitives) => cadr] - [else (error 'open-coded-primitive-args "invalid ~s" x)])) - -;;; end of primitives table section - - -(define-record constant (value)) -(define-record code-loc (label)) -(define-record foreign-label (label)) -(define-record var (name)) -(define-record cp-var (idx)) -(define-record frame-var (idx)) -(define-record new-frame (base-idx size body)) -(define-record save-cp (loc)) -(define-record eval-cp (check body)) -(define-record return (value)) -(define-record call-cp - (call-convention rp-convention base-idx arg-count live-mask)) -(define-record primcall (op arg*)) -(define-record primref (name)) -(define-record conditional (test conseq altern)) -(define-record bind (lhs* rhs* body)) -(define-record seq (e0 e1)) -(define-record function (arg* proper body)) -(define-record clambda-case (arg* proper body)) -(define-record clambda (cases)) -(define-record clambda-code (label cases free)) - -(define-record closure (code free*)) -(define-record funcall (op rand*)) -(define-record appcall (op rand*)) -(define-record forcall (op rand*)) -(define-record code-rec (arg* proper free* body)) - -(define-record codes (list body)) -(define-record assign (lhs rhs)) - -(define unique-var - (let ([counter 0]) - (lambda (x) - (let ([g (gensym (format "~a:~a" x counter))]) - (set! counter (fxadd1 counter)) - (make-var g))))) - -(define (make-bind^ lhs* rhs* body) - (if (null? lhs*) - body - (make-bind lhs* rhs* body))) - -(define (recordize x) - (define (gen-fml* fml*) - (cond - [(pair? fml*) - (cons (unique-var (car fml*)) - (gen-fml* (cdr fml*)))] - [(symbol? fml*) - (unique-var fml*)] - [else '()])) - (define (properize fml*) - (cond - [(pair? fml*) - (cons (car fml*) (properize (cdr fml*)))] - [(null? fml*) '()] - [else (list fml*)])) - (define (extend-env fml* nfml* env) - (cons (cons fml* nfml*) env)) - (define (quoted-sym x) - (if (and (list? x) - (fx= (length x) 2) - (eq? 'quote (car x)) - (symbol? (cadr x))) - (cadr x) - (error 'quoted-sym "not a quoted symbol ~s" x))) - (define (quoted-string x) - (if (and (list? x) - (fx= (length x) 2) - (eq? 'quote (car x)) - (string? (cadr x))) - (cadr x) - (error 'quoted-string "not a quoted string ~s" x))) - (define (lookup^ x lhs* rhs*) - (cond - [(pair? lhs*) - (if (eq? x (car lhs*)) - (car rhs*) - (lookup^ x (cdr lhs*) (cdr rhs*)))] - [(eq? x lhs*) rhs*] - [else #f])) - (define (lookup x env) - (cond - [(pair? env) - (or (lookup^ x (caar env) (cdar env)) - (lookup x (cdr env)))] - [else #f])) - (define (E x env) - (cond - [(pair? x) - (case (car x) - [(quote) (make-constant (cadr x))] - [(if) - (make-conditional - (E (cadr x) env) - (E (caddr x) env) - (E (cadddr x) env))] - [(set!) - (let ([lhs (cadr x)] [rhs (caddr x)]) - (make-assign - (or (lookup lhs env) - (error 'recordize "invalid assignment ~s" x)) - (E rhs env)))] - [(begin) - (let f ([a (cadr x)] [d (cddr x)]) - (cond - [(null? d) (E a env)] - [else - (make-seq - (E a env) - (f (car d) (cdr d)))]))] - [(case-lambda) - (let ([cls* - (map - (lambda (cls) - (let ([fml* (car cls)] [body (cadr cls)]) - (let ([nfml* (gen-fml* fml*)]) - (let ([body (E body (extend-env fml* nfml* env))]) - (make-clambda-case - (properize nfml*) - (list? fml*) - body))))) - (cdr x))]) - (make-clambda cls*))] - [(foreign-call) - (let ([name (quoted-string (cadr x))] [arg* (cddr x)]) - (make-forcall name - (map (lambda (x) (E x env)) arg*)))] - [(|#primitive|) - (let ([var (cadr x)]) - (if (primitive? var) - (make-primref var) - (error 'recordize "invalid primitive ~s" var)))] - [(top-level-value) - (let ([var (quoted-sym (cadr x))]) - (cond - [(primitive? var) (make-primref var)] - [else (error 'recordize "invalid top-level var ~s" var)]))] - [(memv) - (make-funcall - (make-primref 'memq) - (map (lambda (x) (E x env)) (cdr x)))] - [($apply) - (let ([proc (cadr x)] [arg* (cddr x)]) - (make-appcall - (E proc env) - (map (lambda (x) (E x env)) arg*)))] - [(void) - (make-constant (void))] - [else - (make-funcall - (E (car x) env) - (map (lambda (x) (E x env)) (cdr x)))])] - [(symbol? x) - (or (lookup x env) - (error 'recordize "invalid reference in ~s" x))] - [else (error 'recordize "invalid expression ~s" x)])) - (E x '())) - - -(define (unparse x) - (define (E-args proper x) - (if proper - (map E x) - (let f ([a (car x)] [d (cdr x)]) - (cond - [(null? d) (E a)] - [else (cons (E a) (f (car d) (cdr d)))])))) - (define (E x) - (record-case x - [(constant c) `(quote ,c)] - [(code-loc x) `(code-loc ,x)] - [(var x) (string->symbol (format "v:~a" x))] - [(primref x) x] - [(conditional test conseq altern) - `(if ,(E test) ,(E conseq) ,(E altern))] - [(primcall op arg*) `(,op . ,(map E arg*))] - [(bind lhs* rhs* body) - `(let ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*) - ,(E body))] - [(seq e0 e1) `(begin ,(E e0) ,(E e1))] - [(function args proper body) - `(lambda ,(E-args proper args) ,(E body))] - [(clambda-case args proper body) - `(clambda-case ,(E-args proper args) ,(E body))] - [(clambda cls*) - `(case-lambda . ,(map E cls*))] - [(clambda-code label clauses free) - `(code ,label . ,(map E clauses))] - [(closure code free*) - `(closure ,(E code) ,(map E free*))] - [(code-rec arg* proper free* body) - `(code-rec [arg: ,(E-args proper arg*)] - [free: ,(map E free*)] - ,(E body))] - [(codes list body) - `(codes ,(map E list) - ,(E body))] - [(funcall rator rand*) `(funcall ,(E rator) . ,(map E rand*))] - [(appcall rator rand*) `(appcall ,(E rator) . ,(map E rand*))] - [(forcall rator rand*) `(foreign-call ,rator . ,(map E rand*))] - [(assign lhs rhs) `(set! ,(E lhs) ,(E rhs))] - [(return x) `(return ,(E x))] - [(new-frame base-idx size body) - `(new-frame [base: ,base-idx] - [size: ,size] - ,(E body))] - [(frame-var idx) - (string->symbol (format "fv.~a" idx))] - [(cp-var idx) - (string->symbol (format "cp.~a" idx))] - [(save-cp expr) - `(save-cp ,(E expr))] - [(eval-cp check body) - `(eval-cp ,check ,(E body))] - [(call-cp call-convention rp-convention base-idx arg-count live-mask) - `(call-cp [conv: ,call-convention] - [rpconv: ,rp-convention] - [base-idx: ,base-idx] - [arg-count: ,arg-count] - [live-mask: ,live-mask])] - [(foreign-label x) `(foreign-label ,x)] - [else (error 'unparse "invalid record ~s" x)])) - (E x)) - -(define (optimize-direct-calls x) - (define who 'optimize-direct-calls) - (define (make-conses ls) - (cond - [(null? ls) (make-constant '())] - [else - (make-primcall 'cons - (list (car ls) (make-conses (cdr ls))))])) - (define (properize lhs* rhs*) - (cond - [(null? lhs*) (error who "improper improper")] - [(null? (cdr lhs*)) - (list (make-conses rhs*))] - [else (cons (car rhs*) (properize (cdr lhs*) (cdr rhs*)))])) - (define (inline-case cls rand*) - (record-case cls - [(clambda-case fml* proper body) - (if proper - (and (fx= (length fml*) (length rand*)) - (make-bind fml* rand* body)) - (and (fx<= (length fml*) (length rand*)) - (make-bind fml* (properize fml* rand*) body)))])) - (define (try-inline cls* rand* default) - (cond - [(null? cls*) default] - [(inline-case (car cls*) rand*)] - [else (try-inline (cdr cls*) rand* default)])) - (define (inline rator rand*) - (record-case rator - [(clambda cls*) - (try-inline cls* rand* - (make-funcall rator rand*))] -; [(function fml* proper body) -; (cond -; [proper -; (if (fx= (length fml*) (length rand*)) -; (make-bind fml* rand* body) -; (begin -; (warning 'compile "possible application error in ~s" -; (unparse (make-funcall rator rand*))) -; (make-funcall rator rand*)))] -; [else -; (if (fx<= (length fml*) (length rand*)) -; (make-bind fml* (properize fml* rand*) body) -; (begin -; (warning 'compile "possible application error in ~s" -; (unparse (make-funcall rator rand*))) -; (make-funcall rator rand*)))])] - [else (make-funcall rator rand*)])) - (define (Expr x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (make-conditional - (Expr test) - (Expr conseq) - (Expr altern))] - [(seq e0 e1) - (make-seq (Expr e0) (Expr e1))] - [(function fml* proper body) - (make-function fml* proper (Expr body))] - [(clambda cls*) - (make-clambda - (map (lambda (x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (Expr body))])) - cls*))] - [(primcall rator rand*) - (make-primcall rator (map Expr rand*))] - [(funcall rator rand*) - (inline (Expr rator) (map Expr rand*))] - [(appcall rator rand*) - (make-appcall (Expr rator) (map Expr rand*))] - [(forcall rator rand*) - (make-forcall rator (map Expr rand*))] - [(assign lhs rhs) - (make-assign lhs (Expr rhs))] - [else (error who "invalid expression ~s" (unparse x))])) - (Expr x)) - - - -(define (uncover-assigned x) - (define who 'uncover-assigned) - (define (Expr* x*) - (cond - [(null? x*) '()] - [else (union (Expr (car x*)) (Expr* (cdr x*)))])) - (define (Expr x) - (record-case x - [(constant) '()] - [(var) '()] - [(primref) '()] - [(bind lhs* rhs* body) - (union (Expr body) (Expr* rhs*))] - [(conditional test conseq altern) - (union (Expr test) (union (Expr conseq) (Expr altern)))] - [(seq e0 e1) (union (Expr e0) (Expr e1))] - [(clambda cls*) - (Expr* (map clambda-case-body cls*))] - [(function fml* proper body) (Expr body)] - [(primcall rator rand*) (Expr* rand*)] - [(funcall rator rand*) - (union (Expr rator) (Expr* rand*))] - [(appcall rator rand*) - (union (Expr rator) (Expr* rand*))] - [(forcall rator rand*) (Expr* rand*)] - [(assign lhs rhs) - (union (singleton lhs) (Expr rhs))] - [else (error who "invalid expression ~s" (unparse x))])) - (Expr x)) - -(define (rewrite-assignments assigned x) - (define who 'rewrite-assignments) - (define (fix lhs*) - (cond - [(null? lhs*) (values '() '() '())] - [else - (let ([x (car lhs*)]) - (let-values ([(lhs* a-lhs* a-rhs*) (fix (cdr lhs*))]) - (cond - [(memq x assigned) - (let ([t (make-var 'assignment-tmp)]) - (values (cons t lhs*) (cons x a-lhs*) (cons t a-rhs*)))] - [else - (values (cons x lhs*) a-lhs* a-rhs*)])))])) - (define (bind-assigned lhs* rhs* body) - (cond - [(null? lhs*) body] - [else - (make-bind lhs* - (map (lambda (rhs) (make-primcall 'vector (list rhs))) rhs*) - body)])) - (define (Expr x) - (record-case x - [(constant) x] - [(var) - (cond - [(memq x assigned) - (make-primcall '$vector-ref (list x (make-constant 0)))] - [else x])] - [(primref) x] - [(bind lhs* rhs* body) - (let-values ([(lhs* a-lhs* a-rhs*) (fix lhs*)]) - (make-bind lhs* (map Expr rhs*) - (bind-assigned a-lhs* a-rhs* (Expr body))))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (make-seq (Expr e0) (Expr e1))] - [(function fml* proper body) - (let-values ([(fml* a-lhs* a-rhs*) (fix fml*)]) - (make-function fml* proper - (bind-assigned a-lhs* a-rhs* (Expr body))))] - [(clambda cls*) - (make-clambda - (map (lambda (cls) - (record-case cls - [(clambda-case fml* proper body) - (let-values ([(fml* a-lhs* a-rhs*) (fix fml*)]) - (make-clambda-case fml* proper - (bind-assigned a-lhs* a-rhs* (Expr body))))])) - cls*))] - [(primcall op rand*) - (make-primcall op (map Expr rand*))] - [(forcall op rand*) - (make-forcall op (map Expr rand*))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(appcall rator rand*) - (make-appcall (Expr rator) (map Expr rand*))] - [(assign lhs rhs) - (unless (memq lhs assigned) - (error 'rewrite-assignments "not assigned ~s in ~s" lhs x)) - (make-primcall '$vector-set! (list lhs (make-constant 0) (Expr rhs)))] - [else (error who "invalid expression ~s" (unparse x))])) - (Expr x)) - - -(define (remove-assignments x) - (let ([assigned (uncover-assigned x)]) - (rewrite-assignments assigned x))) - - -(define (convert-closures prog) - (define who 'convert-closures) - (define (Expr* x*) - (cond - [(null? x*) (values '() '())] - [else - (let-values ([(a a-free) (Expr (car x*))] - [(d d-free) (Expr* (cdr x*))]) - (values (cons a d) (union a-free d-free)))])) - (define (Expr ex) - (record-case ex - [(constant) (values ex '())] - [(var) (values ex (singleton ex))] - [(primref) (values ex '())] - [(bind lhs* rhs* body) - (let-values ([(rhs* rhs-free) (Expr* rhs*)] - [(body body-free) (Expr body)]) - (values (make-bind lhs* rhs* body) - (union rhs-free (difference body-free lhs*))))] - [(conditional test conseq altern) - (let-values ([(test test-free) (Expr test)] - [(conseq conseq-free) (Expr conseq)] - [(altern altern-free) (Expr altern)]) - (values (make-conditional test conseq altern) - (union test-free (union conseq-free altern-free))))] - [(seq e0 e1) - (let-values ([(e0 e0-free) (Expr e0)] - [(e1 e1-free) (Expr e1)]) - (values (make-seq e0 e1) (union e0-free e1-free)))] - [(function fml* proper body) - (let-values ([(body body-free) (Expr body)]) - (let ([free (difference body-free fml*)]) - (values (make-closure (make-code-rec fml* proper free body) free) - free)))] - [(clambda cls*) - (let-values ([(cls* free) - (let f ([cls* cls*]) - (cond - [(null? cls*) (values '() '())] - [else - (record-case (car cls*) - [(clambda-case fml* proper body) - (let-values ([(body body-free) (Expr body)] - [(cls* cls*-free) (f (cdr cls*))]) - (values - (cons (make-clambda-case fml* proper body) - cls*) - (union (difference body-free fml*) - cls*-free)))])]))]) - (values (make-closure (make-clambda-code (gensym) cls* free) free) - free))] - [(primcall op rand*) - (let-values ([(rand* rand*-free) (Expr* rand*)]) - (values (make-primcall op rand*) rand*-free))] - [(forcall op rand*) - (let-values ([(rand* rand*-free) (Expr* rand*)]) - (values (make-forcall op rand*) rand*-free))] - [(funcall rator rand*) - (let-values ([(rator rat-free) (Expr rator)] - [(rand* rand*-free) (Expr* rand*)]) - (values (make-funcall rator rand*) - (union rat-free rand*-free)))] - [(appcall rator rand*) - (let-values ([(rator rat-free) (Expr rator)] - [(rand* rand*-free) (Expr* rand*)]) - (values (make-appcall rator rand*) - (union rat-free rand*-free)))] - [else (error who "invalid expression ~s" (unparse ex))])) - (let-values ([(prog free) (Expr prog)]) - (unless (null? free) - (error 'convert-closures "free vars ~s encountered in ~a" - free (unparse prog))) - prog)) - - -(define (lift-codes x) - (define who 'lift-codes) - (define all-codes '()) - (define (do-code x) - (record-case x - [(clambda-code label cls* free) - (let ([cls* (map - (lambda (x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (E body))])) - cls*)]) - (let ([g (make-code-loc label)]) - (set! all-codes - (cons (make-clambda-code label cls* free) all-codes)) - g))])) - (define (E x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(bind lhs* rhs* body) - (make-bind lhs* (map E rhs*) (E body))] - [(conditional test conseq altern) - (make-conditional (E test) (E conseq) (E altern))] - [(seq e0 e1) (make-seq (E e0) (E e1))] - [(closure c free) (make-closure (do-code c) free)] - [(primcall op rand*) (make-primcall op (map E rand*))] - [(forcall op rand*) (make-forcall op (map E rand*))] - [(funcall rator rand*) (make-funcall (E rator) (map E rand*))] - [(appcall rator rand*) (make-appcall (E rator) (map E rand*))] - [else (error who "invalid expression ~s" (unparse x))])) - (let ([x (E x)]) - (make-codes all-codes x))) - - - - -(define (syntactically-valid? op rand*) - (define (valid-arg-count? op rand*) - (let ([n (open-coded-primitive-args op)] [m (length rand*)]) - (cond - [(eq? n 'any) #t] - [(eq? n 'no-code) - (error 'syntactically-valid - "should not primcall non codable prim ~s" op)] - [(fixnum? n) - (cond - [(fx= n m) #t] - [else - (error 'compile - "Possible incorrect number of args in ~s" - (cons op (map unparse rand*))) - #f])] - [else (error 'do-primcall "BUG: what ~s" n)]))) - (define (check op pred?) - (lambda (arg) - (record-case arg - [(constant c) - (cond - [(pred? c) #t] - [else - (error 'compile "Possible argument error to primitive ~s" op) - #f])] - [(primref) - (cond - [(pred? (lambda (x) x)) #t] - [else - (error 'compile "Possible argument error to primitive ~s" op) - #f])] - [else #t]))) - (define (nonnegative-fixnum? n) - (and (fixnum? n) (fx>= n 0))) - (define (byte? n) - (and (fixnum? n) (fx<= 0 n) (fx<= n 127))) - (define (valid-arg-types? op rand*) - (case op - [(fixnum? immediate? boolean? char? vector? string? procedure? - null? pair? not cons eq? vector symbol? error eof-object eof-object? - void $unbound-object? code? $forward-ptr? bwp-object? - pointer-value) - '#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 - $make-tcbucket $tcbucket-key $tcbucket-val $tcbucket-next - $set-tcbucket-val! $set-tcbucket-next! $set-tcbucket-tconc!) - #t] - [else (error 'valid-arg-types? "unhandled op ~s" op)])) - (and (valid-arg-count? op rand*) - (or (null? rand*) - (valid-arg-types? op rand*)))) - - -;;; the output of simplify-operands differs from the input in that the -;;; operands to primcalls are all simple (variables, primrefs, or constants). -;;; funcalls to open-codable primrefs whos arguments are "ok" are converted to -;;; primcalls. - -(define (introduce-primcalls x) - (define who 'introduce-primcalls) - (define (simple? x) - (or (constant? x) (var? x) (primref? x))) - (define (Expr x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(closure) x] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (make-seq (Expr e0) (Expr e1))] - [(primcall op arg*) - (case op - ;[(values) - ; (if (fx= (length arg*) 1) - ; (Expr (car arg*)) - ; (begin - ; (warning 'compile "possible incorrect number of values") - ; (make-funcall (make-primref 'values) (map Expr arg*))))] - [else - (make-primcall op (map Expr arg*))])] - [(forcall op arg*) - (make-forcall op (map Expr arg*))] - [(funcall rator rand*) - (cond - [(and (primref? rator) - (open-codeable? (primref-name rator)) - (syntactically-valid? (primref-name rator) rand*)) - (Expr (make-primcall (primref-name rator) rand*))] - [else - (make-funcall (Expr rator) (map Expr rand*))])] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (Tail x) - (record-case x - [(constant) (make-return x)] - [(var) (make-return x)] - [(primref) (make-return x)] - [(closure) (make-return x)] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Tail body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Tail conseq) (Tail altern))] - [(seq e0 e1) (make-seq (Expr e0) (Tail e1))] - [(primcall op arg*) - (case op - ;[(values) - ; (if (fx= (length arg*) 1) - ; (make-return (Expr (car arg*))) - ; (make-return* (map Expr arg*)))] - [else - (make-return (make-primcall op (map Expr arg*)))])] - [(forcall op arg*) - (make-return (make-forcall op (map Expr arg*)))] - [(funcall rator rand*) - (cond - [(and (primref? rator) - (open-codeable? (primref-name rator)) - (syntactically-valid? (primref-name rator) rand*)) - (Tail (make-primcall (primref-name rator) rand*))] - [else - (make-funcall (Expr rator) (map Expr rand*))])] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (CaseExpr x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (Tail body))])) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (make-clambda-code L (map CaseExpr cases) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) (Tail body))])) - (CodesExpr x)) - - -(define (simplify-operands x) - (define who 'simplify-operands) - (define (simple? x) - (or (constant? x) (var? x) (primref? x))) - (define (simplify arg lhs* rhs* k) - (if (simple? arg) - (k arg lhs* rhs*) - (let ([v (unique-var 'tmp)]) - (k v (cons v lhs*) (cons (Expr arg) rhs*))))) - (define (simplify* arg* lhs* rhs* k) - (cond - [(null? arg*) (k '() lhs* rhs*)] - [else - (simplify (car arg*) lhs* rhs* - (lambda (a lhs* rhs*) - (simplify* (cdr arg*) lhs* rhs* - (lambda (d lhs* rhs*) - (k (cons a d) lhs* rhs*)))))])) - (define (Expr x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(closure) x] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (make-seq (Expr e0) (Expr e1))] - [(primcall op arg*) - (simplify* arg* '() '() - (lambda (arg* lhs* rhs*) - (make-bind^ lhs* rhs* - (make-primcall op arg*))))] - [(forcall op arg*) - (make-forcall op (map Expr arg*))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (Tail x) - (record-case x - [(return v) (make-return (Expr v))] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Tail body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Tail conseq) (Tail altern))] - [(seq e0 e1) (make-seq (Expr e0) (Tail e1))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (CaseExpr x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (Tail body))])) - (define (CodeExpr x) - (record-case x - [(clambda-code L clauses free) - (make-clambda-code L (map CaseExpr clauses) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) (Tail body))])) - (CodesExpr x)) - - -(define (insert-stack-overflow-checks x) - (define who 'insert-stack-overflow-checks) - (define (insert-check body) - (make-seq - (make-conditional - (make-primcall '$fp-overflow '()) - (make-funcall (make-primref 'do-stack-overflow) '()) - (make-primcall 'void '())) - body)) - (define (Expr x) - (record-case x - [(constant) #f] - [(var) #f] - [(primref) #f] - [(closure code free*) #f] - [(bind lhs* rhs* body) - (or (ormap Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (or (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (or (Expr e0) (Expr e1))] - [(primcall op arg*) (ormap Expr arg*)] - [(forcall op arg*) (ormap Expr arg*)] - [(funcall rator arg*) #t] - [(appcall rator arg*) #t] - [else (error who "invalid expression ~s" (unparse x))])) - (define (Tail x) - (record-case x - [(return v) (Expr v)] - [(bind lhs* rhs* body) - (or (ormap Expr rhs*) (Tail body))] - [(conditional test conseq altern) - (or (Expr test) (Tail conseq) (Tail altern))] - [(seq e0 e1) (or (Expr e0) (Tail e1))] - [(funcall rator arg*) (or (Expr rator) (ormap Expr arg*))] - [(appcall rator arg*) (or (Expr rator) (ormap Expr arg*))] - [else (error who "invalid tail expression ~s" (unparse x))])) - (define (CaseExpr x) - (record-case x - [(clambda-case fml* proper body) - (if (Tail body) - (make-clambda-case fml* proper (insert-check body)) - x)])) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (make-clambda-code L (map CaseExpr cases) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) - (if (Tail body) - (insert-check body) - body))])) - (CodesExpr x)) - - -(define (insert-allocation-checks x) - (define who 'insert-allocation-checks) - (define (check-bytes n var body) - (make-seq - (make-conditional - (make-primcall '$ap-check-bytes - (list (make-constant n) var)) - (make-funcall (make-primref 'do-overflow) - (list - (make-primcall '$fx+ - (list (make-constant n) var)))) - (make-primcall 'void '())) - body)) - (define (check-words n var body) - (make-seq - (make-conditional - (make-primcall '$ap-check-words - (list (make-constant n) var)) - (make-funcall (make-primref 'do-overflow-words) - (list - (make-primcall '$fx+ - (list (make-constant n) var)))) - (make-primcall 'void '())) - body)) - (define (check-const n body) - (make-seq - (make-conditional - (make-primcall '$ap-check-const - (list (make-constant n))) - (make-funcall (make-primref 'do-overflow) - (list (make-constant n))) - (make-primcall 'void '())) - body)) - (define (Expr x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(closure code free*) - (check-const (fx+ disp-closure-data (fx* (length free*) wordsize)) x)] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (make-seq (Expr e0) (Expr e1))] - [(primcall op arg*) - (let ([x (make-primcall op (map Expr arg*))]) - (case op - [(cons) (check-const pair-size x)] - [($make-symbol) (check-const symbol-size x)] - [($make-tcbucket) (check-const tcbucket-size x)] - [($frame->continuation $code->closure) - (check-const (fx+ disp-closure-data (fx* (length arg*) wordsize)) x)] - [($make-string) - (record-case (car arg*) - [(constant i) - (check-const (fx+ i (fx+ disp-string-data 1)) x)] - [else - (check-bytes (fxadd1 disp-string-data) (car arg*) x)])] - [($string) - (check-const (fx+ (length arg*) (fx+ disp-string-data 1)) x)] - [($make-vector) - (record-case (car arg*) - [(constant i) - (check-const (fx+ (fx* i wordsize) disp-vector-data) x)] - [else - (check-words (fxadd1 disp-vector-data) (car arg*) x)])] - [($make-record) - (record-case (cadr arg*) - [(constant i) - (check-const (fx+ (fx* i wordsize) disp-record-data) x)] - [else - (check-words (fxadd1 disp-record-data) (cadr arg*) x)])] - [(vector) - (check-const (fx+ (fx* (length arg*) wordsize) disp-vector-data) x)] - [else x]))] - [(forcall op arg*) - (make-forcall op (map Expr arg*))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (Tail x) - (record-case x - [(return v) (make-return (Expr v))] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Tail body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Tail conseq) (Tail altern))] - [(seq e0 e1) (make-seq (Expr e0) (Tail e1))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (CaseExpr x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (Tail body))])) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (make-clambda-code L (map CaseExpr cases) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) (Tail body))])) - (CodesExpr x)) - - -(define (remove-local-variables x) - (define who 'remove-local-variables) - (define (simple* x* r) - (map (lambda (x) - (cond - [(assq x r) => cdr] - [else - (when (var? x) (error who "unbound var ~s" x)) - x])) - x*)) - (define (env->mask r sz) - (let ([s (make-vector (fxsra (fx+ sz 7) 3) 0)]) - (for-each - (lambda (idx) - (let ([q (fxsra idx 3)] - [r (fxlogand idx 7)]) - (vector-set! s q - (fxlogor (vector-ref s q) (fxsll 1 r))))) - r) - s)) - (define (do-new-frame op rand* si r call-convention rp-convention orig-live) - (make-new-frame (fxadd1 si) (fx+ (length rand*) 2) - (let f ([r* rand*] [nsi (fx+ si 2)] [live orig-live]) - (cond - [(null? r*) - (make-seq - (make-seq - (make-save-cp (make-frame-var si)) - (case call-convention - [(normal apply) - (make-eval-cp #t (Expr op nsi r (cons si live)))] - [(foreign) - (make-eval-cp #f (make-foreign-label op))] - [else (error who "invalid convention ~s" call-convention)])) - (make-call-cp call-convention - rp-convention - (fxadd1 si) ; frame size - (length rand*) ; argc - (env->mask (cons si orig-live) ; cp and everything before it - (fxadd1 si))))] ; mask-size ~~ frame size - [else - (make-seq - (make-assign (make-frame-var nsi) - (Expr (car r*) nsi r live)) - (f (cdr r*) (fxadd1 nsi) (cons nsi live)))])))) - (define (nop) (make-primcall 'void '())) - (define (do-bind lhs* rhs* body si r live k) - (let f ([lhs* lhs*] [rhs* rhs*] [si si] [nr r] [live live]) - (cond - [(null? lhs*) (k body si nr live)] - [else - (let ([v (make-frame-var si)]) - (make-seq - (make-assign v (Expr (car rhs*) si r live)) - (f (cdr lhs*) (cdr rhs*) (fxadd1 si) - (cons (cons (car lhs*) v) nr) - (cons si live))))]))) - (define (Tail x si r live) - (record-case x - [(return v) (make-return (Expr v si r live))] - [(bind lhs* rhs* body) - (do-bind lhs* rhs* body si r live Tail)] - [(conditional test conseq altern) - (make-conditional - (Expr test si r live) - (Tail conseq si r live) - (Tail altern si r live))] - [(seq e0 e1) (make-seq (Effect e0 si r live) (Tail e1 si r live))] - [(primcall op arg*) - (case op -; [(values) (make-primcall op (simple* arg* r))] - [else (make-return (make-primcall op (simple* arg* r)))])] - [(funcall op rand*) - (do-new-frame op rand* si r 'normal 'tail live)] - [(appcall op rand*) - (do-new-frame op rand* si r 'apply 'tail live)] - [else (error who "invalid expression ~s" (unparse x))])) - (define (Effect x si r live) - (record-case x - [(constant) (nop)] - [(var) (nop)] - [(primref) (nop)] - [(closure code free*) (nop)] - [(bind lhs* rhs* body) - (do-bind lhs* rhs* body si r live Effect)] - [(conditional test conseq altern) - (make-conditional - (Expr test si r live) - (Effect conseq si r live) - (Effect altern si r live))] - [(seq e0 e1) (make-seq (Effect e0 si r live) (Effect e1 si r live))] - [(primcall op arg*) - (make-primcall op (simple* arg* r))] - [(forcall op rand*) - (do-new-frame op rand* si r 'foreign 'effect live)] - [(funcall op rand*) - (do-new-frame op rand* si r 'normal 'effect live)] - [(appcall op rand*) - (do-new-frame op rand* si r 'apply 'effect live)] - [else (error who "invalid effect expression ~s" (unparse x))])) - (define (Expr x si r live) - (record-case x - [(constant) x] - [(var) - (cond - [(assq x r) => cdr] - [else (error who "unbound var ~s" x)])] - [(primref) x] - [(closure code free*) - (make-closure code (simple* free* r))] - [(bind lhs* rhs* body) - (do-bind lhs* rhs* body si r live Expr)] - [(conditional test conseq altern) - (make-conditional - (Expr test si r live) - (Expr conseq si r live) - (Expr altern si r live))] - [(seq e0 e1) (make-seq (Effect e0 si r live) (Expr e1 si r live))] - [(primcall op arg*) - (make-primcall op (simple* arg* r))] - [(forcall op rand*) - (do-new-frame op rand* si r 'foreign 'value live)] - [(funcall op rand*) - (do-new-frame op rand* si r 'normal 'value live)] - [(appcall op rand*) - (do-new-frame op rand* si r 'apply 'value live)] - [else (error who "invalid expression ~s" (unparse x))])) - (define (bind-fml* fml* r) - (let f ([si 1] [fml* fml*]) - (cond - [(null? fml*) (values '() si r '())] - [else - (let-values ([(nfml* nsi r live) (f (fxadd1 si) (cdr fml*))]) - (let ([v (make-frame-var si)]) - (values (cons v nfml*) - nsi - (cons (cons (car fml*) v) r) - (cons si live))))]))) - (define (bind-free* free*) - (let f ([free* free*] [idx 0] [r '()]) - (cond - [(null? free*) r] - [else - (f (cdr free*) (fxadd1 idx) - (cons (cons (car free*) (make-cp-var idx)) r))]))) - (define CaseExpr - (lambda (r) - (lambda (x) - (record-case x - [(clambda-case fml* proper body) - (let-values ([(fml* si r live) (bind-fml* fml* r)]) - (make-clambda-case fml* proper (Tail body si r live)))])))) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (let ([r (bind-free* free)]) - (make-clambda-code L (map (CaseExpr r) cases) free))])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) - (Tail body 1 '() '()))])) - (CodesExpr x)) - - -(begin - (define fx-shift 2) - (define fx-mask #x03) - (define fx-tag 0) - (define bool-f #x2F) - (define bool-t #x3F) - (define bool-mask #xEF) - (define bool-tag #x2F) - (define bool-shift 4) - (define nil #x4F) - (define eof #x5F) ; double check - (define unbound #x6F) ; double check - (define void-object #x7F) ; double check - (define bwp-object #x8F) ; double check - (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 pagesize 4096) - (define pageshift 12) - (define wordsize 4) - (define wordshift 2) - - (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 disp-tcbucket-tconc 0) - (define disp-tcbucket-key 4) - (define disp-tcbucket-val 8) - (define disp-tcbucket-next 12) - (define tcbucket-size 16) - - (define record-ptag 5) - (define record-pmask 7) - (define disp-record-rtd 0) - (define disp-record-data 4) - (define disp-frame-size -17) - (define disp-frame-offset -13) - (define disp-multivalue-rp -9) - (define object-alignment 8) - (define align-shift 3) - (define dirty-word -1)) - -(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)] - [(dirty-vector) (mem 28 pcr)] - [else (error 'pcb-ref "invalid arg ~s" x)]))) - -(define (primref-loc op) - (unless (symbol? op) (error 'primref-loc "not a symbol ~s" op)) - (mem (fx- disp-symbol-system-value symbol-tag) - (obj op))) - -(define (generate-code x) - (define who 'generate-code) - (define (rp-label x) - (case x - [(value) (label-address SL_multiple_values_error_rp)] - [(effect) (label-address SL_multiple_values_ignore_rp)] - [else (error who "invalid rp-convention ~s" x)])) - (define (align n) - (fxsll (fxsra (fx+ n (fxsub1 object-alignment)) align-shift) align-shift)) - (define unique-label - (lambda () - (label (gensym)))) - (define (constant-val x) - (cond - [(fixnum? x) (obj x)] - [(boolean? x) (int (if x bool-t bool-f))] - [(null? x) (int nil)] - [(char? x) (int (fx+ (fxsll (char->integer x) char-shift) char-tag))] - [(eq? x (void)) (int void-object)] - [else (obj x)])) - (define (cond-branch op Lt Lf ac) - (define (opposite x) - (cadr (assq x '([je jne] [jl jge] [jle jg] [jg jle] [jge jl])))) - (unless (or Lt Lf) - (error 'cond-branch "no labels")) - (cond - [(not Lf) (cons (list op Lt) ac)] - [(not Lt) (cons (list (opposite op) Lf) ac)] - [else (list* (list op Lt) (jmp Lf) ac)])) - (define (indirect-type-pred pri-mask pri-tag sec-mask sec-tag rand* Lt Lf ac) - (cond - [(and Lt Lf) - (list* (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int pri-mask) ebx) - (cmpl (int pri-tag) ebx) - (jne Lf) - (movl (mem (fx- 0 pri-tag) eax) ebx) - (if sec-mask - (andl (int sec-mask) ebx) - '(nop)) - (cmpl (int sec-tag) ebx) - (jne Lf) - (jmp Lt) - ac)] - [Lf - (list* (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int pri-mask) ebx) - (cmpl (int pri-tag) ebx) - (jne Lf) - (movl (mem (fx- 0 pri-tag) eax) ebx) - (if sec-mask - (andl (int sec-mask) ebx) - '(nop)) - (cmpl (int sec-tag) ebx) - (jne Lf) - ac)] - [Lt - (let ([L_END (unique-label)]) - (list* (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int pri-mask) ebx) - (cmpl (int pri-tag) ebx) - (jne L_END) - (movl (mem (fx- 0 pri-tag) eax) ebx) - (if sec-mask - (andl (int sec-mask) ebx) - '(nop)) - (cmpl (int sec-tag) ebx) - (je Lt) - L_END - ac))] - [else ac])) - (define (type-pred mask tag rand* Lt Lf ac) - (cond - [mask - (list* - (movl (Simple (car rand*)) eax) - (andl (int mask) eax) - (cmpl (int tag) eax) - (cond-branch 'je Lt Lf ac))] - [else - (let ([v (Simple (car rand*))]) - (cond - [(memq (car v) '(mem register)) - (list* - (cmpl (int tag) (Simple (car rand*))) - (cond-branch 'je Lt Lf ac))] - [else - (list* - (movl (Simple (car rand*)) eax) - (cmpl (int tag) eax) - (cond-branch 'je Lt Lf ac))]))])) - (define (compare-and-branch op rand* Lt Lf ac) - (define (opposite x) - (cadr (assq x '([je je] [jl jg] [jle jge] [jg jl] [jge jle])))) - (cond - [(and (constant? (car rand*)) (constant? (cadr rand*))) - (list* - (movl (Simple (car rand*)) eax) - (cmpl (Simple (cadr rand*)) eax) - (cond-branch op Lt Lf ac))] - [(constant? (cadr rand*)) - (list* - (cmpl (Simple (cadr rand*)) (Simple (car rand*))) - (cond-branch op Lt Lf ac))] - [(constant? (car rand*)) - (list* - (cmpl (Simple (car rand*)) (Simple (cadr rand*))) - (cond-branch (opposite op) Lt Lf ac))] - [else - (list* - (movl (Simple (car rand*)) eax) - (cmpl (Simple (cadr rand*)) eax) - (cond-branch op Lt Lf ac))])) - (define (do-pred-prim op rand* Lt Lf ac) - (case op - [(fixnum?) (type-pred fx-mask fx-tag rand* Lt Lf ac)] - [(pair?) (type-pred pair-mask pair-tag rand* Lt Lf ac)] - [(char?) (type-pred char-mask char-tag rand* Lt Lf ac)] - [(string?) (type-pred string-mask string-tag rand* Lt Lf ac)] - [(symbol?) (type-pred symbol-mask symbol-tag rand* Lt Lf ac)] - [(procedure?) (type-pred closure-mask closure-tag rand* Lt Lf ac)] - [(boolean?) (type-pred bool-mask bool-tag rand* Lt Lf ac)] - [(null?) (type-pred #f nil rand* Lt Lf ac)] - [($unbound-object?) (type-pred #f unbound rand* Lt Lf ac)] - [($forward-ptr?) (type-pred #f -1 rand* Lt Lf ac)] - [(not) (type-pred #f bool-f rand* Lt Lf ac)] - [(eof-object?) (type-pred #f eof rand* Lt Lf ac)] - [(bwp-object?) (type-pred #f bwp-object 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)] - [(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)] - [($tcbucket-key) - (indirect-ref arg* (fx- disp-tcbucket-key vector-tag) ac)] - [($tcbucket-val) - (indirect-ref arg* (fx- disp-tcbucket-val vector-tag) ac)] - [($tcbucket-next) - (indirect-ref arg* (fx- disp-tcbucket-next vector-tag) ac)] - [(pointer-value) - (list* - (movl (Simple (car arg*)) eax) - (sarl (int fx-shift) eax) - (sall (int fx-shift) eax) - ac)] - [($symbol-plist) - (indirect-ref arg* (fx- disp-symbol-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-tcbucket) - (list* (movl (Simple (car arg*)) eax) - (movl eax (mem disp-tcbucket-tconc apr)) - (movl (Simple (cadr arg*)) eax) - (movl eax (mem disp-tcbucket-key apr)) - (movl (Simple (caddr arg*)) eax) - (movl eax (mem disp-tcbucket-val apr)) - (movl (Simple (cadddr arg*)) eax) - (movl eax (mem disp-tcbucket-next apr)) - (movl apr eax) - (addl (int vector-tag) eax) - (addl (int (align tcbucket-size)) apr) - ac)] - [(vector) - (let f ([arg* arg*] [idx disp-vector-data]) - (cond - [(null? arg*) - (list* (movl apr eax) - (addl (int vector-tag) eax) - (movl (int (fx- idx disp-vector-data)) - (mem disp-vector-length apr)) - (addl (int (align idx)) apr) - ac)] - [else - (list* (movl (Simple (car arg*)) eax) - (movl eax (mem idx apr)) - (f (cdr arg*) (fx+ idx wordsize)))]))] - [($string) - (let f ([arg* arg*] [idx disp-string-data]) - (cond - [(null? arg*) - (list* (movb (int 0) (mem idx apr)) - (movl apr eax) - (addl (int string-tag) eax) - (movl (int (fx* (fx- idx disp-string-data) wordsize)) - (mem disp-string-length apr)) - (addl (int (align (fxadd1 idx))) apr) - ac)] - [else - (record-case (car arg*) - [(constant c) - (unless (char? c) (error who "invalid arg to string ~s" x)) - (list* (movb (int (char->integer c)) (mem idx apr)) - (f (cdr arg*) (fxadd1 idx)))] - [else - (list* (movl (Simple (car arg*)) ebx) - (movb bh (mem idx apr)) - (f (cdr arg*) (fxadd1 idx)))])]))] - [($current-frame) - (list* (movl (pcb-ref 'next-continuation) eax) - ac)] - [($seal-frame-and-call) - (list* (movl (Simple (car arg*)) cpr) ; proc - (movl (pcb-ref 'frame-base) eax) - ; eax=baseofstack - (movl (mem (fx- 0 wordsize) eax) ebx) ; underflow handler - (movl ebx (mem (fx- 0 wordsize) fpr)) ; set - ; create a new cont record - (movl (int continuation-tag) (mem 0 apr)) - (movl fpr (mem disp-continuation-top apr)) - ; compute the size of the captured frame - (movl eax ebx) - (subl fpr ebx) - (subl (int wordsize) ebx) - ; and store it - (movl ebx (mem disp-continuation-size apr)) - ; load next cont - (movl (pcb-ref 'next-continuation) ebx) - ; and store it - (movl ebx (mem disp-continuation-next apr)) - ; adjust ap - (movl apr eax) - (addl (int vector-tag) eax) - (addl (int continuation-size) apr) - ; store new cont in current-cont - (movl eax (pcb-ref 'next-continuation)) - ; adjust fp - (movl fpr (pcb-ref 'frame-base)) - (subl (int wordsize) fpr) - ; tail-call f - (movl eax (mem (fx- 0 wordsize) fpr)) - (movl (int (argc-convention 1)) eax) - (tail-indirect-cpr-call) - ac)] - [($code-instr-size) - (indirect-ref arg* (fx- disp-code-instrsize vector-tag) - (cons (sall (int fx-shift) eax) ac))] - [($code-reloc-size) - (indirect-ref arg* (fx- disp-code-relocsize vector-tag) ac)] - [($code-closure-size) - (indirect-ref arg* (fx- disp-code-closuresize vector-tag) ac)] - [($set-car! $set-cdr! $vector-set! $string-set! $exit - $set-symbol-value! $set-symbol-plist! - $set-code-byte! $set-code-word! primitive-set! - $set-code-object! $set-code-object+offset! $set-code-object+offset/rel! - $record-set!) - (do-effect-prim op arg* - (cons (movl (int void-object) eax) ac))] - [(fixnum? immediate? $fxzero? boolean? char? pair? vector? string? symbol? - procedure? null? not eof-object? $fx= $fx< $fx<= $fx> $fx>= eq? - $char= $char< $char<= $char> $char>= $unbound-object? code? - $record? bwp-object?) - (do-pred->value-prim op arg* ac)] - [($code->closure) - (list* - (movl (Simple (car arg*)) eax) - (addl (int (fx- disp-code-data vector-tag)) eax) - (movl eax (mem 0 apr)) - (movl apr eax) - (addl (int closure-tag) eax) - (addl (int (align disp-closure-data)) apr) - ac)] - [($frame->continuation) - (NonTail - (make-closure (make-code-loc SL_continuation_code) arg*) - ac)] - [($make-call-with-values-procedure) - (NonTail - (make-closure (make-code-loc SL_call_with_values) arg*) - ac)] - [($make-values-procedure) - (NonTail - (make-closure (make-code-loc SL_values) arg*) - ac)] - [else - (error 'value-prim "unhandled ~s" op)])) - (define (indirect-assignment arg* offset ac) - (list* - (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem offset eax)) - ;;; record side effect - (addl (int offset) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)) - (define (do-effect-prim op arg* ac) - (case op - [($vector-set!) - (list* (movl (Simple (car arg*)) ebx) - (addl (Simple (cadr arg*)) ebx) - (addl (int (fx- disp-vector-data vector-tag)) ebx) - (movl (Simple (caddr arg*)) eax) - (movl eax (mem 0 ebx)) - ;;; record side effect - (shrl (int pageshift) ebx) - (sall (int wordshift) ebx) - (addl (pcb-ref 'dirty-vector) ebx) - (movl (int dirty-word) (mem 0 ebx)) - ac)] - [($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-car!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-car pair-tag) eax)) - ;;; record side effect - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-cdr!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-cdr pair-tag) eax)) - ;;; record side effect - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-tcbucket-key!) - (indirect-assignment arg* (fx- disp-tcbucket-key vector-tag) ac)] - [($set-tcbucket-val!) - (indirect-assignment arg* (fx- disp-tcbucket-val vector-tag) ac)] - [($set-tcbucket-next!) - (indirect-assignment arg* (fx- disp-tcbucket-next vector-tag) ac)] - [($set-tcbucket-tconc!) - (indirect-assignment arg* (fx- disp-tcbucket-tconc vector-tag) ac)] - - [($set-symbol-value!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-value symbol-tag) eax)) - ;;; record side effect - (addl (int (fx- disp-symbol-value symbol-tag)) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 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)) - ;;; record side effect - (addl (int (fx- disp-symbol-system-value symbol-tag)) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-symbol-plist!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-plist symbol-tag) eax)) - ;;; record side effect - (addl (int (fx- disp-symbol-plist symbol-tag)) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-symbol-unique-string!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-unique-string symbol-tag) eax)) - ;;; record side effect - (addl (int (fx- disp-symbol-unique-string symbol-tag)) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-symbol-string!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-string symbol-tag) eax)) - ;;; record side effect - (addl (int (fx- disp-symbol-string symbol-tag)) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($record-set!) - (list* (movl (Simple (car arg*)) ebx) - (addl (Simple (cadr arg*)) ebx) - (movl (Simple (caddr arg*)) eax) - (addl (int (fx- disp-record-data record-ptag)) ebx) - (movl eax (mem 0 ebx)) - ;;; record side effect - (shrl (int pageshift) ebx) - (sall (int wordshift) ebx) - (addl (pcb-ref 'dirty-vector) ebx) - (movl (int dirty-word) (mem 0 ebx)) - ac)] - [(cons void $fxadd1 $fxsub1) - (let f ([arg* arg*]) - (cond - [(null? arg*) ac] - [else - (Effect (car arg*) (f (cdr arg*)))]))] - [else - (error 'do-effect-prim "unhandled op ~s" op)])) - (define (do-simple-test x Lt Lf ac) - (unless (or Lt Lf) - (error 'Pred "no labels")) - (cond - [(not Lt) - (list* (cmpl (int bool-f) x) (je Lf) ac)] - [(not Lf) - (list* (cmpl (int bool-f) x) (jne Lt) ac)] - [else - (list* (cmpl (int bool-f) x) (je Lf) (jmp Lt) ac)])) - (define (Simple x) - (record-case x - [(cp-var i) - (mem (fx+ (fx* i wordsize) (fx- disp-closure-data closure-tag)) cpr)] - [(frame-var i) (mem (fx* i (fx- 0 wordsize)) fpr)] - [(constant c) (constant-val c)] - [(code-loc label) (label-address label)] - [(primref op) (primref-loc op)] - [else (error 'Simple "what ~s" x)])) - (define (frame-adjustment offset) - (fx* (fxsub1 offset) (fx- 0 wordsize))) - (define (NonTail x ac) - (record-case x - [(constant c) - (cons (movl (constant-val c) eax) ac)] - [(frame-var) - (cons (movl (Simple x) eax) ac)] - [(cp-var) - (cons (movl (Simple x) eax) ac)] - [(foreign-label L) - (cons (movl (list 'foreign-label L) eax) ac)] - [(primref c) - (cons (movl (primref-loc c) eax) ac)] - [(closure label arg*) - (let f ([arg* arg*] [off disp-closure-data]) - (cond - [(null? arg*) - (list* (movl (Simple label) (mem 0 apr)) - (movl apr eax) - (addl (int (align off)) apr) - (addl (int closure-tag) eax) - ac)] - [else - (list* (movl (Simple (car arg*)) eax) - (movl eax (mem off apr)) - (f (cdr arg*) (fx+ off wordsize)))]))] - [(conditional test conseq altern) - (let ([Lj (unique-label)] [Lf (unique-label)]) - (Pred test #f Lf - (NonTail conseq - (list* (jmp Lj) Lf (NonTail altern (cons Lj ac))))))] - [(seq e0 e1) - (Effect e0 (NonTail e1 ac))] - [(primcall op rand*) - (do-value-prim op rand* ac)] - [(new-frame base-idx size body) - (NonTail body ac)] - [(call-cp call-convention rp-convention offset size mask) - (let ([L_CALL (unique-label)]) - (case call-convention - [(normal) - (list* (addl (int (frame-adjustment offset)) fpr) - (movl (int (argc-convention size)) eax) - (jmp L_CALL) - ; NEW FRAME - `(byte-vector ,mask) - `(int ,(fx* offset wordsize)) - `(current-frame-offset) - (rp-label rp-convention) - `(byte 0) ; padding for indirect calls only - `(byte 0) ; direct calls are ok - L_CALL - (indirect-cpr-call) - (movl (mem 0 fpr) cpr) - (subl (int (frame-adjustment offset)) fpr) - ac)] - [(foreign) - (list* (addl (int (frame-adjustment offset)) fpr) - (movl (int (argc-convention size)) eax) - (movl '(foreign-label "ik_foreign_call") ebx) - (jmp L_CALL) - ; NEW FRAME - (byte-vector mask) - `(int ,(fx* offset wordsize)) - `(current-frame-offset) - (rp-label rp-convention) ; should be 0, since C has 1 rv - '(byte 0) - '(byte 0) - '(byte 0) - L_CALL - (call ebx) - (movl (mem 0 fpr) cpr) - (subl (int (frame-adjustment offset)) fpr) - ac)] - [else - (error who "invalid convention ~s for call-cp" call-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" call-convention)])] - [else - (list* (movl (mem (fx* (fx+ idx (fxadd1 i)) - (fx- 0 wordsize)) fpr) - eax) - (movl eax (mem (fx* (fx+ i 1) (fx- 0 wordsize)) fpr)) - (f (fxadd1 i)))]))] - [else (error 'Tail "invalid expression ~s" x)])) - (define (handle-vararg fml-count ac) - (define CONTINUE_LABEL (unique-label)) - (define DONE_LABEL (unique-label)) - (define CONS_LABEL (unique-label)) - (define LOOP_HEAD (unique-label)) - (define L_CALL (unique-label)) - (list* (cmpl (int (argc-convention (fxsub1 fml-count))) eax) - (jg (label SL_invalid_args)) - (jl CONS_LABEL) - (movl (int nil) ebx) - (jmp DONE_LABEL) - CONS_LABEL - (movl (pcb-ref 'allocation-redline) ebx) - (addl eax ebx) - (addl eax ebx) - (cmpl ebx apr) - (jle LOOP_HEAD) - ; overflow - (addl eax esp) ; advance esp to cover args - (pushl cpr) ; push current cp - (pushl eax) ; push argc - (negl eax) ; make argc positive - (addl (int (fx* 4 wordsize)) eax) ; add 4 words to adjust frame size - (pushl eax) ; push frame size - (addl eax eax) ; double the number of args - (movl eax (mem (fx* -2 wordsize) fpr)) ; pass it as first arg - (movl (int (argc-convention 1)) eax) ; setup argc - (movl (primref-loc 'do-vararg-overflow) cpr) ; load handler - (jmp L_CALL) ; go to overflow handler - ; NEW FRAME - (int 0) ; if the framesize=0, then the framesize is dynamic - '(current-frame-offset) - (int 0) ; multiarg rp - (byte 0) - (byte 0) - L_CALL - (indirect-cpr-call) - (popl eax) ; pop framesize and drop it - (popl eax) ; reload argc - (popl cpr) ; reload cp - (subl eax fpr) ; readjust fp - LOOP_HEAD - (movl (int nil) ebx) - CONTINUE_LABEL - (movl ebx (mem disp-cdr apr)) - (movl (mem fpr eax) ebx) - (movl ebx (mem disp-car apr)) - (movl apr ebx) - (addl (int pair-tag) ebx) - (addl (int pair-size) apr) - (addl (int (fxsll 1 fx-shift)) eax) - (cmpl (int (fx- 0 (fxsll fml-count fx-shift))) eax) - (jle CONTINUE_LABEL) - DONE_LABEL - (movl ebx (mem (fx- 0 (fxsll fml-count fx-shift)) fpr)) - ac)) - (define (Entry check? x ac) - (record-case x - [(clambda-case fml* proper body) - (let ([ac (Tail body ac)]) - (cond - [(and proper check?) - (list* (cmpl (int (argc-convention (length fml*))) eax) - (jne (label SL_invalid_args)) - ac)] - [proper ac] - [else - (handle-vararg (length fml*) ac)]))])) - (define make-dispatcher - (lambda (j? L L* x x* ac) - (cond - [(null? L*) (if j? (cons (jmp (label L)) ac) ac)] - [else - (record-case x - [(clambda-case fml* proper _) - (cond - [proper - (list* (cmpl (int (argc-convention (length fml*))) eax) - (je (label L)) - (make-dispatcher #t - (car L*) (cdr L*) (car x*) (cdr x*) ac))] - [else - (list* (cmpl (int (argc-convention (fxsub1 (length fml*)))) eax) - (jle (label L)) - (make-dispatcher #t - (car L*) (cdr L*) (car x*) (cdr x*) ac))])])]))) - (define (handle-cases x x*) - (let ([L* (map (lambda (_) (gensym)) x*)] - [L (gensym)]) - (make-dispatcher #f L L* x x* - (let f ([x x] [x* x*] [L L] [L* L*]) - (cond - [(null? x*) - (cons (label L) (Entry 'check x '()))] - [else - (cons (label L) - (Entry #f x - (f (car x*) (cdr x*) (car L*) (cdr L*))))]))))) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (list* - (fx+ disp-closure-data (fx* wordsize (length free))) - (label L) - (handle-cases (car cases) (cdr cases)))])) - (record-case x - [(codes list body) - (cons (cons 0 (Tail body '())) - (map CodeExpr list))])) - - -(define SL_nonprocedure (gensym "SL_nonprocedure")) -(define SL_invalid_args (gensym "SL_invalid_args")) -(define SL_foreign_call (gensym "SL_foreign_call")) -(define SL_continuation_code (gensym "SL_continuation_code")) -(define SL_multiple_values_error_rp (gensym "SL_multiple_values_error_rp")) -(define SL_multiple_values_ignore_rp (gensym "SL_multiple_ignore_error_rp")) -(define SL_underflow_multiple_values (gensym "SL_underflow_multiple_values")) -(define SL_underflow_handler (gensym "SL_underflow_handler")) -(define SL_scheme_exit (gensym "SL_scheme_exit")) -(define SL_apply (gensym "SL_apply")) -(define SL_values (gensym "SL_values")) -(define SL_call_with_values (gensym "SL_call_with_values")) - -(module () -(list*->code* - (list - (let ([L_cwv_done (gensym)] - [L_cwv_loop (gensym)] - [L_cwv_multi_rp (gensym)] - [L_cwv_call (gensym)]) - (list disp-closure-data - (label SL_call_with_values) - (cmpl (int (argc-convention 2)) eax) - (jne (label SL_invalid_args)) - (movl (mem (fx- 0 wordsize) fpr) ebx) ; producer - (movl ebx cpr) - (andl (int closure-mask) ebx) - (cmpl (int closure-tag) ebx) - (jne (label SL_nonprocedure)) - (movl (int (argc-convention 0)) eax) - (subl (int (fx* wordsize 2)) fpr) - (jmp (label L_cwv_call)) - ; MV NEW FRAME - (byte-vector '#(#b110)) - (int (fx* wordsize 3)) - '(current-frame-offset) - (label-address L_cwv_multi_rp) - (byte 0) - (byte 0) - (label L_cwv_call) - (indirect-cpr-call) - ;;; one value returned - (addl (int (fx* wordsize 2)) fpr) - (movl (mem (fx* -2 wordsize) fpr) ebx) ; consumer - (movl ebx cpr) - (movl eax (mem (fx- 0 wordsize) fpr)) - (movl (int (argc-convention 1)) eax) - (andl (int closure-mask) ebx) - (cmpl (int closure-tag) ebx) - (jne (label SL_nonprocedure)) - (tail-indirect-cpr-call) - ;;; multiple values returned - (label L_cwv_multi_rp) - ; because values does not pop the return point - ; we have to adjust fp one more word here - (addl (int (fx* wordsize 3)) fpr) - (movl (mem (fx* -2 wordsize) fpr) cpr) ; consumer - (cmpl (int (argc-convention 0)) eax) - (je (label L_cwv_done)) - (movl (int (fx* -4 wordsize)) ebx) - (addl fpr ebx) ; ebx points to first value - (movl ebx ecx) - (addl eax ecx) ; ecx points to the last value - (label L_cwv_loop) - (movl (mem 0 ebx) edx) - (movl edx (mem (fx* 3 wordsize) ebx)) - (subl (int wordsize) ebx) - (cmpl ecx ebx) - (jge (label L_cwv_loop)) - (label L_cwv_done) - (movl cpr ebx) - (andl (int closure-mask) ebx) - (cmpl (int closure-tag) ebx) - (jne (label SL_nonprocedure)) - (tail-indirect-cpr-call))) - - (let ([L_values_one_value (gensym)] - [L_values_many_values (gensym)]) - (list disp-closure-data - (label SL_values) - (cmpl (int (argc-convention 1)) eax) - (je (label L_values_one_value)) - (label L_values_many_values) - (movl (mem 0 fpr) ebx) ; return point - (jmp (mem disp-multivalue-rp ebx)) ; go - (label L_values_one_value) - (movl (mem (fx- 0 wordsize) fpr) eax) - (ret))) - - (let ([L_apply_done (gensym)] - [L_apply_loop (gensym)]) - (list 0 - (label SL_apply) - (movl (mem fpr eax) ebx) - (cmpl (int nil) ebx) - (je (label L_apply_done)) - (label L_apply_loop) - (movl (mem (fx- disp-car pair-tag) ebx) ecx) - (movl (mem (fx- disp-cdr pair-tag) ebx) ebx) - (movl ecx (mem fpr eax)) - (subl (int wordsize) eax) - (cmpl (int nil) ebx) - (jne (label L_apply_loop)) - (label L_apply_done) - (addl (int wordsize) eax) - (tail-indirect-cpr-call))) - - (list 0 - (label SL_nonprocedure) - (movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg - (movl (primref-loc '$apply-nonprocedure-error-handler) cpr) - (movl (int (argc-convention 1)) eax) - (tail-indirect-cpr-call)) - - (list 0 - (label SL_multiple_values_error_rp) - (movl (primref-loc '$multiple-values-error) cpr) - (tail-indirect-cpr-call)) - - (list 0 - (label SL_multiple_values_ignore_rp) - (ret)) - - (list 0 - (label SL_invalid_args) - ;;; - (movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg - (negl eax) - (movl eax (mem (fx- 0 (fx* 2 wordsize)) fpr)) - (movl (primref-loc '$incorrect-args-error-handler) cpr) - (movl (int (argc-convention 2)) eax) - (tail-indirect-cpr-call)) - - (let ([Lset (gensym)] [Lloop (gensym)]) - (list 0 - (label SL_foreign_call) - (movl fpr (pcb-ref 'frame-pointer)) - (movl apr (pcb-ref 'allocation-pointer)) - (movl fpr ebx) - (movl (pcb-ref 'system-stack) esp) - (pushl pcr) - (cmpl (int 0) eax) - (je (label Lset)) - (label Lloop) - (movl (mem ebx eax) ecx) - (pushl ecx) - (addl (int 4) eax) - (cmpl (int 0) eax) - (jne (label Lloop)) - (label Lset) - ; FOREIGN NEW FRAME - (call cpr) - (movl (pcb-ref 'frame-pointer) fpr) - (movl (pcb-ref 'allocation-pointer) apr) - (ret))) - - (let ([L_cont_zero_args (gensym)] - [L_cont_mult_args (gensym)] - [L_cont_one_arg (gensym)] - [L_cont_mult_move_args (gensym)] - [L_cont_mult_copy_loop (gensym)]) - (list - (fx+ disp-closure-data wordsize) - (label SL_continuation_code) - (movl (mem (fx- disp-closure-data closure-tag) cpr) ebx) ; captured-k - (movl ebx (pcb-ref 'next-continuation)) ; set - (movl (pcb-ref 'frame-base) ebx) - (cmpl (int (argc-convention 1)) eax) - (jg (label L_cont_zero_args)) - (jl (label L_cont_mult_args)) - (label L_cont_one_arg) - (movl (mem (fx- 0 wordsize) fpr) eax) - (movl ebx fpr) - (subl (int wordsize) fpr) - (ret) - (label L_cont_zero_args) - (subl (int wordsize) ebx) - (movl ebx fpr) - (movl (mem 0 ebx) ebx) ; return point - (jmp (mem disp-multivalue-rp ebx)) ; go - (label L_cont_mult_args) - (subl (int wordsize) ebx) - (cmpl ebx fpr) - (jne (label L_cont_mult_move_args)) - (movl (mem 0 ebx) ebx) - (jmp (mem disp-multivalue-rp ebx)) - (label L_cont_mult_move_args) - ; move args from fpr to ebx - (movl (int 0) ecx) - (label L_cont_mult_copy_loop) - (subl (int wordsize) ecx) - (movl (mem fpr ecx) edx) - (movl edx (mem ebx ecx)) - (cmpl ecx eax) - (jne (label L_cont_mult_copy_loop)) - (movl ebx fpr) - (movl (mem 0 ebx) ebx) - (jmp (mem disp-multivalue-rp ebx)) - )) - ))) - - - -(define (compile-expr expr) - (let* ([p (recordize expr)] - [p (optimize-direct-calls p)] - [p (remove-assignments p)] - [p (convert-closures p)] - [p (lift-codes p)] - [p (introduce-primcalls p)] - [p (simplify-operands 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*)]) - (car code*))) - -(define compile-file - (lambda (input-file output-file . rest) - (let ([ip (open-input-file input-file)] - [op (apply open-output-file output-file rest)]) - (let f () - (let ([x (read ip)]) - (unless (eof-object? x) - (fasl-write (compile-expr (expand x)) op) - (f)))) - (close-input-port ip) - (close-output-port op)))) - -(primitive-set! 'compile-file compile-file) -(primitive-set! 'assembler-output (make-parameter #f)) -) - diff --git a/src/libcompile-6.5.ss b/src/libcompile-6.5.ss deleted file mode 100644 index 51dd525..0000000 --- a/src/libcompile-6.5.ss +++ /dev/null @@ -1,3435 +0,0 @@ - - -;;; 6.2: * side-effects now modify the dirty-vector -;;; * added bwp-object? -;;; * added pointer-value -;;; * added tcbuckets -;;; 6.1: * added case-lambda, dropped lambda -;;; 6.0: * basic compiler - -(let () - -(define-syntax cond-expand - (lambda (x) - (syntax-case x () - [(_ test conseq altern) - (if (eval (syntax-object->datum #'test)) - #'conseq - #'altern)]))) - -(cond-expand (eq? "" "") - (include "record-case.chez.ss") - (include "record-case.ss")) - - -(include "set-operations.ss") - - -(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] - [bwp-object? 1 pred] - [$unbound-object? 1 pred] - [$forward-ptr? 1 pred] - [not 1 pred] - [pointer-value 1 value] - [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] - ;;; tcbuckets - [$make-tcbucket 4 value] - [$tcbucket-key 1 value] - [$tcbucket-val 1 value] - [$tcbucket-next 1 value] - [$set-tcbucket-val! 2 effect] - [$set-tcbucket-next! 2 effect] - [$set-tcbucket-tconc! 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? 2 pred] - [$record-rtd 1 value] - [$record-ref 2 value] - [$record-set! 3 effect] - ;;; - ;;; asm - ;;; - ;[code? 1 pred] - ;[$code-instr-size 1 value] - ;[$code-reloc-size 1 value] - ;[$code-closure-size 1 value] - ;[$code->closure 1 value] - ;[$set-code-byte! 3 effect] - ;[$set-code-word! 3 effect] - ;[$set-code-object! 4 effect] - ;[$set-code-object+offset! 5 effect] - ;[$set-code-object+offset/rel! 5 effect] - ;;; - [$make-call-with-values-procedure 0 value] - [$make-values-procedure 0 value] - [$install-underflow-handler 0 effect] - )) - -(define (primitive-context x) - (cond - [(assq x open-coded-primitives) => caddr] - [else (error 'primitive-context "unknown prim ~s" x)])) - - -;;; primitives table section -(define primitives-table - '(;;; system locations used by the C/Scheme interface - [$apply-nonprocedure-error-handler library] - [$incorrect-args-error-handler library] - [$multiple-values-error library] - [$intern library] - [do-overflow library] - [do-vararg-overflow library] - [do-stack-overflow library] - ;;; type predicates - [fixnum? public] - [immediate? public] - [boolean? public] - [char? public] - [null? public] - [pair? public] - [symbol? public] - [vector? public] - [string? public] - [procedure? public] - [eof-object? public] - [not public] - [eq? public] - [equal? public] - ;;; fixnum primitives - [fxadd1 public] - [fxsub1 public] - [fx+ public] - [fx- public] - [fx* public] - [fxsll public] - [fxsra public] - [fxlogor public] - [fxlogand public] - [fxlogxor public] - [fxlognot public] - [fxquotient public] - [fxremainder public] - [fxmodulo public] - ;;; fixnum predicates - [fxzero? public] - [fx= public] - [fx< public] - [fx<= public] - [fx> public] - [fx>= public] - ;;; characters - [char=? public] - [char? public] - [char>=? public] - [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] - [memv 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] - [primitive-set! 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] - [syntax-error public] - [current-expand public] - [expand-mode public] - [assembler-output public] - [compile-file public] - [fasl-write public] - - [$sc-put-cte public] - [sc-expand public] - [$make-environment public] - [environment? public] - [interaction-environment public] - [identifier? public] - [syntax->list public] - [syntax-object->datum public] - [datum->syntax-object public] - [generate-temporaries public] - [free-identifier=? public] - [bound-identifier=? public] - [literal-identifier=? public] - [syntax-error public] - [$syntax-dispatch public] - - - - [interpret public] - [eval public] - [current-eval public] - [load public] - [new-cafe public] - [collect public] - [call/cc public] - [call/cf library] - [dynamic-wind public] - [values public] - [call-with-values public] - [make-traced-procedure library] - [trace-symbol! library] - [untrace-symbol! library] - ;;; record - [$base-rtd library] - [record? public] - [record-rtd public] - [record-name public] - [record-printer public] - [record-length public] - [record-ref public] - [record-set! public] - ;;; record rtds - [make-record-type public] - [record-type-name public] - [record-type-descriptor public] - [record-type-symbol public] - [record-type-field-names public] - [record-constructor public] - [record-predicate public] - [record-field-accessor public] - [record-field-mutator public] - ;;; hash tables - [make-hash-table public] - [hash-table? public] - [get-hash-table public] - [put-hash-table! 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-reloc-vec public] - [code-code-vec public] - [code->closure public] - [list*->code* library] - ;;; - ;;; POSIX - ;;; - [fork public] - [posix-fork public] - [system public] - [$debug public] - [$underflow-misaligned-error public] - )) - - -(define (primitive? x) - (cond - [(assq x primitives-table) #t] - [(assq x open-coded-primitives) #t] - [else #f])) - -(define (open-codeable? x) - (cond - [(assq x open-coded-primitives) #t] - [(assq x primitives-table) #f] - [else (error 'open-codeable "invalid primitive ~s" x)])) - -(define (open-coded-primitive-args x) - (cond - [(assq x open-coded-primitives) => cadr] - [else (error 'open-coded-primitive-args "invalid ~s" x)])) - -;;; end of primitives table section - - -(define-record constant (value)) -(define-record code-loc (label)) -(define-record foreign-label (label)) -(define-record var (name assigned)) -(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 recbind (lhs* rhs* body)) -(define-record fix (lhs* rhs* body)) - -(define-record seq (e0 e1)) -(define-record clambda-case (arg* proper body)) -(define-record clambda (cases)) -(define-record clambda-code (label cases free)) - -(define-record closure (code free*)) -(define-record funcall (op rand*)) -(define-record appcall (op rand*)) -(define-record forcall (op rand*)) -(define-record code-rec (arg* proper free* body)) - -(define-record codes (list body)) -(define-record assign (lhs rhs)) - -(define unique-var - (let ([counter 0]) - (lambda (x) - (let ([g (gensym (format "~a:~a" x counter))]) - (set! counter (fxadd1 counter)) - (make-var g #f))))) - -(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)))]))] - [(letrec) - (unless (fx= (length x) 3) (syntax-error x)) - (let ([bind* (cadr x)] [body (caddr x)]) - (let ([lhs* (map car bind*)] - [rhs* (map cadr bind*)]) - (let ([nlhs* (gen-fml* lhs*)]) - (let ([env (extend-env lhs* nlhs* env)]) - (make-recbind nlhs* - (map (lambda (rhs) (E rhs env)) rhs*) - (E body env))))))] - [(letrec) - (unless (fx= (length x) 3) (syntax-error x)) - (let ([bind* (cadr x)] [body (caddr x)]) - (let ([lhs* (map car bind*)] - [rhs* (map cadr bind*)] - [v* (map (lambda (x) '(void)) bind*)] - [t* (map (lambda (x) (gensym)) bind*)]) - (E `((case-lambda - [,lhs* - ((case-lambda - [,t* - (begin ,@(map (lambda (x v) `(set! ,x ,v)) lhs* t*) - ,body)]) - ,@rhs*)]) - ,@v*) - env)))] - [(case-lambda) - (let ([cls* - (map - (lambda (cls) - (let ([fml* (car cls)] [body (cadr cls)]) - (let ([nfml* (gen-fml* fml*)]) - (let ([body (E body (extend-env fml* nfml* env))]) - (make-clambda-case - (properize nfml*) - (list? fml*) - body))))) - (cdr x))]) - (make-clambda cls*))] - [(foreign-call) - (let ([name (quoted-string (cadr x))] [arg* (cddr x)]) - (make-forcall name - (map (lambda (x) (E x env)) arg*)))] - [(|#primitive|) - (let ([var (cadr x)]) - (if (primitive? var) - (make-primref var) - (error 'recordize "invalid primitive ~s" var)))] - [(top-level-value) - (let ([var (quoted-sym (cadr x))]) - (cond - [(primitive? var) (make-primref var)] - [else (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))] - [(recbind lhs* rhs* body) - `(letrec ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*) - ,(E body))] - [(fix lhs* rhs* body) - `(fix ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*) - ,(E body))] - [(seq e0 e1) `(begin ,(E e0) ,(E e1))] - [(clambda-case args proper body) - `(clambda-case ,(E-args proper args) ,(E body))] - [(clambda cls*) - `(case-lambda . ,(map E cls*))] - [(clambda-code label clauses free) - `(code ,label . ,(map E clauses))] - [(closure code free*) - `(closure ,(E code) ,(map E free*))] - [(code-rec arg* proper free* body) - `(code-rec [arg: ,(E-args proper arg*)] - [free: ,(map E free*)] - ,(E body))] - [(codes list body) - `(codes ,(map E list) - ,(E body))] - [(funcall rator rand*) `(funcall ,(E rator) . ,(map E rand*))] - [(appcall rator rand*) `(appcall ,(E rator) . ,(map E rand*))] - [(forcall rator rand*) `(foreign-call ,rator . ,(map E rand*))] - [(assign lhs rhs) `(set! ,(E lhs) ,(E rhs))] - [(return x) `(return ,(E x))] - [(new-frame base-idx size body) - `(new-frame [base: ,base-idx] - [size: ,size] - ,(E body))] - [(frame-var idx) - (string->symbol (format "fv.~a" idx))] - [(cp-var idx) - (string->symbol (format "cp.~a" idx))] - [(save-cp expr) - `(save-cp ,(E expr))] - [(eval-cp check body) - `(eval-cp ,check ,(E body))] - [(call-cp call-convention rp-convention base-idx arg-count live-mask) - `(call-cp [conv: ,call-convention] - [rpconv: ,rp-convention] - [base-idx: ,base-idx] - [arg-count: ,arg-count] - [live-mask: ,live-mask])] - [(foreign-label x) `(foreign-label ,x)] - [else (error 'unparse "invalid record ~s" x)])) - (E x)) - -(define (optimize-direct-calls x) - (define who 'optimize-direct-calls) - (define (make-conses ls) - (cond - [(null? ls) (make-constant '())] - [else - (make-primcall 'cons - (list (car ls) (make-conses (cdr ls))))])) - (define (properize lhs* rhs*) - (cond - [(null? lhs*) (error who "improper improper")] - [(null? (cdr lhs*)) - (list (make-conses rhs*))] - [else (cons (car rhs*) (properize (cdr lhs*) (cdr rhs*)))])) - (define (inline-case cls rand*) - (record-case cls - [(clambda-case fml* proper body) - (if proper - (and (fx= (length fml*) (length rand*)) - (make-bind fml* rand* body)) - (and (fx<= (length fml*) (length rand*)) - (make-bind fml* (properize fml* rand*) body)))])) - (define (try-inline cls* rand* default) - (cond - [(null? cls*) default] - [(inline-case (car cls*) rand*)] - [else (try-inline (cdr cls*) rand* default)])) - (define (inline rator rand*) - (record-case rator - [(clambda cls*) - (try-inline cls* rand* - (make-funcall rator rand*))] - [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))] - [(recbind lhs* rhs* body) - (make-recbind 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))] - [(clambda cls*) - (make-clambda - (map (lambda (x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (Expr body))])) - cls*))] - [(primcall rator rand*) - (make-primcall rator (map Expr rand*))] - [(funcall rator rand*) - (inline (Expr rator) (map Expr rand*))] - [(appcall rator rand*) - (make-appcall (Expr rator) (map Expr rand*))] - [(forcall rator rand*) - (make-forcall rator (map Expr rand*))] - [(assign lhs rhs) - (make-assign lhs (Expr rhs))] - [else (error who "invalid expression ~s" (unparse x))])) - (Expr x)) - - -(define (optimize-letrec x) - (define who 'optimize-letrec) - (define (extend-hash lhs* h ref) - (for-each (lambda (lhs) (put-hash-table! h lhs #t)) lhs*) - (lambda (x) - (unless (get-hash-table h x #f) - (put-hash-table! h x #t) - (ref x)))) - (define (E* x* ref comp) - (cond - [(null? x*) '()] - [else - (cons (E (car x*) ref comp) - (E* (cdr x*) ref comp))])) - (define (do-rhs* i lhs* rhs* ref comp vref vcomp) - (cond - [(null? rhs*) '()] - [else - (let ([h (make-hash-table)]) - (let ([ref - (lambda (x) - (unless (get-hash-table h x #f) - (put-hash-table! h x #t) - (ref x) - (when (memq x lhs*) - (vector-set! vref i #t))))] - [comp - (lambda () - (vector-set! vcomp i #t) - (comp))]) - (cons (E (car rhs*) ref comp) - (do-rhs* (fxadd1 i) lhs* (cdr rhs*) ref comp vref vcomp))))])) - (define (partition-rhs* i lhs* rhs* vref vcomp) - (cond - [(null? lhs*) (values '() '() '() '() '() '())] - [else - (let-values - ([(slhs* srhs* llhs* lrhs* clhs* crhs*) - (partition-rhs* (fxadd1 i) (cdr lhs*) (cdr rhs*) vref vcomp)] - [(lhs rhs) (values (car lhs*) (car rhs*))]) - (cond - [(var-assigned lhs) - (values slhs* srhs* llhs* lrhs* (cons lhs clhs*) (cons rhs crhs*))] - [(clambda? rhs) - (values slhs* srhs* (cons lhs llhs*) (cons rhs lrhs*) clhs* crhs*)] - [(or (vector-ref vref i) (vector-ref vcomp i)) - (values slhs* srhs* llhs* lrhs* (cons lhs clhs*) (cons rhs crhs*))] - [else - (values (cons lhs slhs*) (cons rhs srhs*) llhs* lrhs* clhs* crhs*)] - ))])) - (define (do-recbind lhs* rhs* body ref comp) - (let ([h (make-hash-table)] - [vref (make-vector (length lhs*) #f)] - [vcomp (make-vector (length lhs*) #f)]) - (let* ([ref (extend-hash lhs* h ref)] - [body (E body ref comp)]) - (let ([rhs* (do-rhs* 0 lhs* rhs* ref comp vref vcomp)]) - (let-values ([(slhs* srhs* llhs* lrhs* clhs* crhs*) - (partition-rhs* 0 lhs* rhs* vref vcomp)]) - (let ([v* (map (lambda (x) (make-primcall 'void '())) clhs*)] - [t* (map (lambda (x) (unique-var 'tmp)) clhs*)]) - (make-bind slhs* srhs* - (make-bind clhs* v* - (make-fix llhs* lrhs* - (make-bind t* crhs* - (build-assign* clhs* t* body))))))))))) - (define (build-assign* lhs* rhs* body) - (cond - [(null? lhs*) body] - [else - (make-seq - (make-assign (car lhs*) (car rhs*)) - (build-assign* (cdr lhs*) (cdr rhs*) body))])) - (define (E x ref comp) - (record-case x - [(constant) x] - [(var) (ref x) x] - [(assign lhs rhs) - (set-var-assigned! lhs #t) - (ref lhs) - (make-assign lhs (E rhs ref comp))] - [(primref) x] - [(bind lhs* rhs* body) - (let ([rhs* (E* rhs* ref comp)]) - (let ([h (make-hash-table)]) - (let ([body (E body (extend-hash lhs* h ref) comp)]) - (make-bind lhs* rhs* body))))] - [(recbind lhs* rhs* body) - (if (null? lhs*) - (E body ref comp) - (do-recbind lhs* rhs* body ref comp))] - [(conditional e0 e1 e2) - (make-conditional (E e0 ref comp) (E e1 ref comp) (E e2 ref comp))] - [(seq e0 e1) (make-seq (E e0 ref comp) (E e1 ref comp))] - [(clambda cls*) - (make-clambda - (map (lambda (x) - (record-case x - [(clambda-case fml* proper body) - (let ([h (make-hash-table)]) - (let ([body (E body (extend-hash fml* h ref) void)]) - (make-clambda-case fml* proper body)))])) - cls*))] - [(primcall rator rand*) - (when (memq rator '(call/cc call/cf)) - (comp)) - (make-primcall rator (E* rand* ref comp))] - [(funcall rator rand*) - (let ([rator (E rator ref comp)] [rand* (E* rand* ref comp)]) - (record-case rator - [(primref op) - (when (memq op '(call/cc call/cf)) - (comp))] - [else - (comp)]) - (make-funcall rator rand*))] - [(appcall rator rand*) - (let ([rator (E rator ref comp)] [rand* (E* rand* ref comp)]) - (record-case rator - [(primref op) - (when (memq op '(call/cc call/cf)) - (comp))] - [else - (comp)]) - (make-appcall rator rand*))] - [(forcall rator rand*) - (make-forcall rator (E* rand* ref comp))] - [else (error who "invalid expression ~s" (unparse x))])) - (E x (lambda (x) (error who "free var ~s found" x)) - void)) - - -(define (remove-letrec x) - (define who 'remove-letrec) - (define (Expr x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Expr body))] - [(recbind lhs* rhs* body) - (let ([t* (map (lambda (lhs) (unique-var 'tmp)) lhs*)] - [v* (map (lambda (lhs) (make-primcall 'void '())) lhs*)]) - (make-bind lhs* v* - (make-bind t* (map Expr rhs*) - (let f ([lhs* lhs*] [t* t*]) - (cond - [(null? lhs*) (Expr body)] - [else - (make-seq - (make-assign (car lhs*) (car t*)) - (f (cdr lhs*) (cdr t*)))])))))] - ;[(fix lhs* rhs* body) - ; (Expr (make-recbind lhs* rhs* body))] - [(fix lhs* rhs* body) - (make-fix lhs* (map Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (make-conditional - (Expr test) - (Expr conseq) - (Expr altern))] - [(seq e0 e1) - (make-seq (Expr e0) (Expr e1))] - [(clambda cls*) - (make-clambda - (map (lambda (x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (Expr body))])) - cls*))] - [(primcall rator rand*) - (make-primcall rator (map Expr rand*))] - [(funcall rator rand*) - (make-funcall (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*) - (for-each Expr x*)) - (define (Expr x) - (record-case x - [(constant) (void)] - [(var) (void)] - [(primref) (void)] - [(bind lhs* rhs* body) - (begin (Expr body) (Expr* rhs*))] - [(recbind lhs* rhs* body) - (begin (Expr body) (Expr* rhs*))] - [(fix lhs* rhs* body) - (Expr* rhs*) - (Expr body) - (when (ormap var-assigned lhs*) - (error 'uncover-assigned "a fix lhs is assigned"))] - [(conditional test conseq altern) - (begin (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (begin (Expr e0) (Expr e1))] - [(clambda cls*) - (for-each - (lambda (cls) - (Expr (clambda-case-body cls))) - cls*)] - [(primcall rator rand*) (Expr* rand*)] - [(funcall rator rand*) - (begin (Expr rator) (Expr* rand*))] - [(appcall rator rand*) - (begin (Expr rator) (Expr* rand*))] - [(forcall rator rand*) (Expr* rand*)] - [(assign lhs rhs) - (set-var-assigned! lhs #t) - (Expr rhs)] - [else (error who "invalid expression ~s" (unparse x))])) - (Expr x)) - - - -(define (rewrite-assignments x) - (define who 'rewrite-assignments) - (define (fix-lhs* lhs*) - (cond - [(null? lhs*) (values '() '() '())] - [else - (let ([x (car lhs*)]) - (let-values ([(lhs* a-lhs* a-rhs*) (fix-lhs* (cdr lhs*))]) - (cond - [(var-assigned x) - (let ([t (unique-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 - [(var-assigned x) - (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* lhs*)]) - (make-bind lhs* (map Expr rhs*) - (bind-assigned a-lhs* a-rhs* (Expr body))))] - [(fix lhs* rhs* body) - (make-fix lhs* (map Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (make-seq (Expr e0) (Expr e1))] - [(clambda cls*) - (make-clambda - (map (lambda (cls) - (record-case cls - [(clambda-case fml* proper body) - (let-values ([(fml* a-lhs* a-rhs*) (fix-lhs* fml*)]) - (make-clambda-case fml* proper - (bind-assigned a-lhs* a-rhs* (Expr body))))])) - cls*))] - [(primcall op rand*) - (make-primcall op (map Expr rand*))] - [(forcall op rand*) - (make-forcall op (map Expr rand*))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(appcall rator rand*) - (make-appcall (Expr rator) (map Expr rand*))] - [(assign lhs rhs) - (unless (var-assigned lhs) - (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) - (uncover-assigned x) - (rewrite-assignments 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 (do-clambda* x*) - (cond - [(null? x*) (values '() '())] - [else - (let-values ([(a a-free) (do-clambda (car x*))] - [(d d-free) (do-clambda* (cdr x*))]) - (values (cons a d) (union a-free d-free)))])) - (define (do-clambda x) - (record-case x - [(clambda cls*) - (let-values ([(cls* free) - (let f ([cls* cls*]) - (cond - [(null? cls*) (values '() '())] - [else - (record-case (car cls*) - [(clambda-case fml* proper body) - (let-values ([(body body-free) (Expr body)] - [(cls* cls*-free) (f (cdr cls*))]) - (values - (cons (make-clambda-case fml* proper body) - cls*) - (union (difference body-free fml*) - cls*-free)))])]))]) - (values (make-closure (make-clambda-code (gensym) cls* free) free) - free))])) - (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*))))] - [(fix lhs* rhs* body) - (let-values ([(rhs* rfree) (do-clambda* rhs*)] - [(body bfree) (Expr body)]) - (values (make-fix lhs* rhs* body) - (difference (union bfree rfree) 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)))] - [(clambda) - (do-clambda ex)] - [(primcall op rand*) - (let-values ([(rand* rand*-free) (Expr* rand*)]) - (values (make-primcall op rand*) rand*-free))] - [(forcall op rand*) - (let-values ([(rand* rand*-free) (Expr* rand*)]) - (values (make-forcall op rand*) rand*-free))] - [(funcall rator rand*) - (let-values ([(rator rat-free) (Expr rator)] - [(rand* rand*-free) (Expr* rand*)]) - (values (make-funcall rator rand*) - (union rat-free rand*-free)))] - [(appcall rator rand*) - (let-values ([(rator rat-free) (Expr rator)] - [(rand* rand*-free) (Expr* rand*)]) - (values (make-appcall rator rand*) - (union rat-free rand*-free)))] - [else (error who "invalid expression ~s" (unparse ex))])) - (let-values ([(prog free) (Expr prog)]) - (unless (null? free) - (error 'convert-closures "free vars ~s encountered in ~a" - free (unparse prog))) - prog)) - - -(define (lift-codes x) - (define who 'lift-codes) - (define all-codes '()) - (define (do-code x) - (record-case x - [(clambda-code label cls* free) - (let ([cls* (map - (lambda (x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (E body))])) - cls*)]) - (let ([g (make-code-loc label)]) - (set! all-codes - (cons (make-clambda-code label cls* free) all-codes)) - g))])) - (define (E x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(bind lhs* rhs* body) - (make-bind lhs* (map E rhs*) (E body))] - [(fix lhs* rhs* body) - (make-fix lhs* (map E rhs*) (E body))] - [(conditional test conseq altern) - (make-conditional (E test) (E conseq) (E altern))] - [(seq e0 e1) (make-seq (E e0) (E e1))] - [(closure c free) (make-closure (do-code c) free)] - [(primcall op rand*) (make-primcall op (map E rand*))] - [(forcall op rand*) (make-forcall op (map E rand*))] - [(funcall rator rand*) (make-funcall (E rator) (map E rand*))] - [(appcall rator rand*) (make-appcall (E rator) (map E rand*))] - [else (error who "invalid expression ~s" (unparse x))])) - (let ([x (E x)]) - (make-codes all-codes x))) - - - - -(define (syntactically-valid? op rand*) - (define (valid-arg-count? op rand*) - (let ([n (open-coded-primitive-args op)] [m (length rand*)]) - (cond - [(eq? n 'any) #t] - [(eq? n 'no-code) - (error 'syntactically-valid - "should not primcall non codable prim ~s" op)] - [(fixnum? n) - (cond - [(fx= n m) #t] - [else - (error 'compile - "Possible incorrect number of args in ~s" - (cons op (map unparse rand*))) - #f])] - [else (error 'do-primcall "BUG: what ~s" n)]))) - (define (check op pred?) - (lambda (arg) - (record-case arg - [(constant c) - (cond - [(pred? c) #t] - [else - (error 'compile "Possible argument error to primitive ~s" op) - #f])] - [(primref) - (cond - [(pred? (lambda (x) x)) #t] - [else - (error 'compile "Possible argument error to primitive ~s" op) - #f])] - [else #t]))) - (define (nonnegative-fixnum? n) - (and (fixnum? n) (fx>= n 0))) - (define (byte? n) - (and (fixnum? n) (fx<= 0 n) (fx<= n 127))) - (define (valid-arg-types? op rand*) - (case op - [(fixnum? immediate? boolean? char? vector? string? procedure? - null? pair? not cons eq? vector symbol? error eof-object eof-object? - void $unbound-object? code? $forward-ptr? bwp-object? - pointer-value) - '#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-rtd $record-ref $record-set! - primitive-set! primitive-ref - $make-tcbucket $tcbucket-key $tcbucket-val $tcbucket-next - $set-tcbucket-val! $set-tcbucket-next! $set-tcbucket-tconc!) - #t] - [else (error 'valid-arg-types? "unhandled op ~s" op)])) - (and (valid-arg-count? op rand*) - (or (null? rand*) - (valid-arg-types? op rand*)))) - - -;;; 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))] - [(fix lhs* rhs* body) - (make-fix lhs* (map Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (make-seq (Expr e0) (Expr e1))] - [(primcall op arg*) - (case op - ;[(values) - ; (if (fx= (length arg*) 1) - ; (Expr (car arg*)) - ; (begin - ; (warning 'compile "possible incorrect number of values") - ; (make-funcall (make-primref 'values) (map Expr arg*))))] - [else - (make-primcall op (map Expr arg*))])] - [(forcall op arg*) - (make-forcall op (map Expr arg*))] - [(funcall rator rand*) - (cond - [(and (primref? rator) - (open-codeable? (primref-name rator)) - (syntactically-valid? (primref-name rator) rand*)) - (Expr (make-primcall (primref-name rator) rand*))] - [else - (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))] - [(fix lhs* rhs* body) - (make-fix lhs* (map Expr rhs*) (Tail body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Tail conseq) (Tail altern))] - [(seq e0 e1) (make-seq (Expr e0) (Tail e1))] - [(primcall op arg*) - (case op - ;[(values) - ; (if (fx= (length arg*) 1) - ; (make-return (Expr (car arg*))) - ; (make-return* (map Expr arg*)))] - [else - (make-return (make-primcall op (map Expr arg*)))])] - [(forcall op arg*) - (make-return (make-forcall op (map Expr arg*)))] - [(funcall rator rand*) - (cond - [(and (primref? rator) - (open-codeable? (primref-name rator)) - (syntactically-valid? (primref-name rator) rand*)) - (Tail (make-primcall (primref-name rator) rand*))] - [else - (make-funcall (Expr rator) (map Expr rand*))])] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (CaseExpr x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (Tail body))])) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (make-clambda-code L (map CaseExpr cases) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) (Tail body))])) - (CodesExpr x)) - - -(define (simplify-operands x) - (define who 'simplify-operands) - (define (simple? x) - (or (constant? x) (var? x) (primref? x))) - (define (simplify arg lhs* rhs* k) - (if (simple? arg) - (k arg lhs* rhs*) - (let ([v (unique-var 'tmp)]) - (k v (cons v lhs*) (cons (Expr arg) rhs*))))) - (define (simplify* arg* lhs* rhs* k) - (cond - [(null? arg*) (k '() lhs* rhs*)] - [else - (simplify (car arg*) lhs* rhs* - (lambda (a lhs* rhs*) - (simplify* (cdr arg*) lhs* rhs* - (lambda (d lhs* rhs*) - (k (cons a d) lhs* rhs*)))))])) - (define (Expr x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(closure) x] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Expr body))] - [(fix lhs* rhs* body) - (make-fix lhs* (map Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (make-seq (Expr e0) (Expr e1))] - [(primcall op arg*) - (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))] - [(fix lhs* rhs* body) - (make-fix lhs* (map Expr rhs*) (Tail body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Tail conseq) (Tail altern))] - [(seq e0 e1) (make-seq (Expr e0) (Tail e1))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (CaseExpr x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (Tail body))])) - (define (CodeExpr x) - (record-case x - [(clambda-code L clauses free) - (make-clambda-code L (map CaseExpr clauses) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) (Tail body))])) - (CodesExpr x)) - - -(define (insert-stack-overflow-checks x) - (define who 'insert-stack-overflow-checks) - (define (insert-check body) - (make-seq - (make-conditional - (make-primcall '$fp-overflow '()) - (make-funcall (make-primref 'do-stack-overflow) '()) - (make-primcall 'void '())) - body)) - (define (Expr x) - (record-case x - [(constant) #f] - [(var) #f] - [(primref) #f] - [(closure code free*) #f] - [(bind lhs* rhs* body) - (or (ormap Expr rhs*) (Expr body))] - [(fix lhs* rhs* body) (Expr body)] - [(conditional test conseq altern) - (or (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (or (Expr e0) (Expr e1))] - [(primcall op arg*) (ormap Expr arg*)] - [(forcall op arg*) (ormap Expr arg*)] - [(funcall rator arg*) #t] - [(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))] - [(fix lhs* rhs* body) (Tail body)] - [(conditional test conseq altern) - (or (Expr test) (Tail conseq) (Tail altern))] - [(seq e0 e1) (or (Expr e0) (Tail e1))] - [(funcall rator arg*) (or (Expr rator) (ormap Expr arg*))] - [(appcall rator arg*) (or (Expr rator) (ormap Expr arg*))] - [else (error who "invalid tail expression ~s" (unparse x))])) - (define (CaseExpr x) - (record-case x - [(clambda-case fml* proper body) - (if (Tail body) - (make-clambda-case fml* proper (insert-check body)) - x)])) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (make-clambda-code L (map CaseExpr cases) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) - (if (Tail body) - (insert-check body) - body))])) - (CodesExpr x)) - - -(define (insert-allocation-checks x) - (define who 'insert-allocation-checks) - (define (check-bytes n var body) - (make-seq - (make-conditional - (make-primcall '$ap-check-bytes - (list (make-constant n) var)) - (make-funcall (make-primref 'do-overflow) - (list - (make-primcall '$fx+ - (list (make-constant n) var)))) - (make-primcall 'void '())) - body)) - (define (check-words n var body) - (make-seq - (make-conditional - (make-primcall '$ap-check-words - (list (make-constant n) var)) - (make-funcall (make-primref 'do-overflow-words) - (list - (make-primcall '$fx+ - (list (make-constant n) var)))) - (make-primcall 'void '())) - body)) - (define (check-const n body) - (make-seq - (make-conditional - (make-primcall '$ap-check-const - (list (make-constant n))) - (make-funcall (make-primref 'do-overflow) - (list (make-constant n))) - (make-primcall 'void '())) - body)) - (define (closure-size x) - (record-case x - [(closure code free*) - (align (fx+ disp-closure-data (fx* (length free*) wordsize)))] - [else (error 'closure-size "~s is not a closure" x)])) - (define (sum ac ls) - (cond - [(null? ls) ac] - [else (sum (fx+ ac (car ls)) (cdr ls))])) - (define (Expr x) - (record-case x - [(constant) x] - [(var) x] - [(primref) x] - [(closure) - (check-const (closure-size x) x)] - [(fix lhs* rhs* body) - (if (null? lhs*) - (Expr body) - (check-const (sum 0 (map closure-size rhs*)) - (make-fix lhs* rhs* - (Expr body))))] - [(bind lhs* rhs* body) - (make-bind lhs* (map Expr rhs*) (Expr body))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Expr conseq) (Expr altern))] - [(seq e0 e1) (make-seq (Expr e0) (Expr e1))] - [(primcall op arg*) - (let ([x (make-primcall op (map Expr arg*))]) - (case op - [(cons) (check-const pair-size x)] - [($make-symbol) (check-const symbol-size x)] - [($make-tcbucket) (check-const tcbucket-size x)] - [($frame->continuation $code->closure) - (check-const (fx+ disp-closure-data (fx* (length arg*) wordsize)) x)] - [($make-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))] - [(fix lhs* rhs* body) - (if (null? lhs*) - (Tail body) - (check-const (sum 0 (map closure-size rhs*)) - (make-fix lhs* rhs* - (Tail body))))] - [(conditional test conseq altern) - (make-conditional (Expr test) (Tail conseq) (Tail altern))] - [(seq e0 e1) (make-seq (Expr e0) (Tail e1))] - [(funcall rator rand*) - (make-funcall (Expr rator) (map Expr rand*))] - [(appcall op arg*) - (make-appcall (Expr op) (map Expr arg*))] - [else (error who "invalid expression ~s" (unparse x))])) - (define (CaseExpr x) - (record-case x - [(clambda-case fml* proper body) - (make-clambda-case fml* proper (Tail body))])) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (make-clambda-code L (map CaseExpr cases) free)])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) (Tail body))])) - (CodesExpr x)) - - -(define (remove-local-variables x) - (define who 'remove-local-variables) - (define (simple* x* r) - (map (lambda (x) - (cond - [(assq x r) => cdr] - [else - (when (var? x) (error who "unbound var ~s" x)) - x])) - x*)) - (define (env->mask r sz) - (let ([s (make-vector (fxsra (fx+ sz 7) 3) 0)]) - (for-each - (lambda (idx) - (let ([q (fxsra idx 3)] - [r (fxlogand idx 7)]) - (vector-set! s q - (fxlogor (vector-ref s q) (fxsll 1 r))))) - r) - s)) - (define (do-new-frame op rand* si r call-convention rp-convention orig-live) - (make-new-frame (fxadd1 si) (fx+ (length rand*) 2) - (let f ([r* rand*] [nsi (fx+ si 2)] [live orig-live]) - (cond - [(null? r*) - (make-seq - (make-seq - (make-save-cp (make-frame-var si)) - (case call-convention - [(normal apply) - (make-eval-cp #t (Expr op nsi r (cons si live)))] - [(foreign) - (make-eval-cp #f (make-foreign-label op))] - [else (error who "invalid convention ~s" call-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 (do-closure r) - (lambda (x) - (record-case x - [(closure code free*) - (make-closure code (simple* free* r))]))) - (define (do-fix lhs* rhs* body si r live k) - (let f ([l* lhs*] [nlhs* '()] [si si] [r r] [live live]) - (cond - [(null? l*) - (make-fix (reverse nlhs*) - (map (do-closure r) rhs*) - (k body si r live))] - [else - (let ([v (make-frame-var si)]) - (f (cdr l*) (cons v nlhs*) (fxadd1 si) - (cons (cons (car l*) v) r) - (cons si live)))]))) - (define (Tail x si r live) - (record-case x - [(return v) (make-return (Expr v si r live))] - [(bind lhs* rhs* body) - (do-bind lhs* rhs* body si r live Tail)] - [(fix lhs* rhs* body) - (do-fix lhs* rhs* body si r live Tail)] - [(conditional test conseq altern) - (make-conditional - (Expr test si r live) - (Tail conseq si r live) - (Tail altern si r live))] - [(seq e0 e1) (make-seq (Effect e0 si r live) (Tail e1 si r live))] - [(primcall op arg*) - (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)] - [(fix lhs* rhs* body) - (do-fix lhs* rhs* body si r live Effect)] - [(conditional test conseq altern) - (make-conditional - (Expr test si r live) - (Effect conseq si r live) - (Effect altern si r live))] - [(seq e0 e1) (make-seq (Effect e0 si r live) (Effect e1 si r live))] - [(primcall op arg*) - (make-primcall op (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)] - [(fix lhs* rhs* body) - (do-fix lhs* rhs* body si r live Expr)] - [(conditional test conseq altern) - (make-conditional - (Expr test si r live) - (Expr conseq si r live) - (Expr altern si r live))] - [(seq e0 e1) (make-seq (Effect e0 si r live) (Expr e1 si r live))] - [(primcall op arg*) - (make-primcall op (simple* arg* r))] - [(forcall op rand*) - (do-new-frame op rand* si r 'foreign 'value live)] - [(funcall op rand*) - (do-new-frame op rand* si r 'normal 'value live)] - [(appcall op rand*) - (do-new-frame op rand* si r 'apply 'value live)] - [else (error who "invalid expression ~s" (unparse x))])) - (define (bind-fml* fml* r) - (let f ([si 1] [fml* fml*]) - (cond - [(null? fml*) (values '() si r '())] - [else - (let-values ([(nfml* nsi r live) (f (fxadd1 si) (cdr fml*))]) - (let ([v (make-frame-var si)]) - (values (cons v nfml*) - nsi - (cons (cons (car fml*) v) r) - (cons si live))))]))) - (define (bind-free* free*) - (let f ([free* free*] [idx 0] [r '()]) - (cond - [(null? free*) r] - [else - (f (cdr free*) (fxadd1 idx) - (cons (cons (car free*) (make-cp-var idx)) r))]))) - (define CaseExpr - (lambda (r) - (lambda (x) - (record-case x - [(clambda-case fml* proper body) - (let-values ([(fml* si r live) (bind-fml* fml* r)]) - (make-clambda-case fml* proper (Tail body si r live)))])))) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (let ([r (bind-free* free)]) - (make-clambda-code L (map (CaseExpr r) cases) free))])) - (define (CodesExpr x) - (record-case x - [(codes list body) - (make-codes (map CodeExpr list) - (Tail body 1 '() '()))])) - (CodesExpr x)) - - -(begin - (define fx-shift 2) - (define fx-mask #x03) - (define fx-tag 0) - (define bool-f #x2F) - (define bool-t #x3F) - (define bool-mask #xEF) - (define bool-tag #x2F) - (define bool-shift 4) - (define nil #x4F) - (define eof #x5F) ; double check - (define unbound #x6F) ; double check - (define void-object #x7F) ; double check - (define bwp-object #x8F) ; double check - (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 pagesize 4096) - (define pageshift 12) - (define wordsize 4) - (define wordshift 2) - - (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 disp-tcbucket-tconc 0) - (define disp-tcbucket-key 4) - (define disp-tcbucket-val 8) - (define disp-tcbucket-next 12) - (define tcbucket-size 16) - - (define record-ptag 5) - (define record-pmask 7) - (define disp-record-rtd 0) - (define disp-record-data 4) - (define disp-frame-size -17) - (define disp-frame-offset -13) - (define disp-multivalue-rp -9) - (define object-alignment 8) - (define align-shift 3) - (define dirty-word -1)) - -(define (align n) - (fxsll (fxsra (fx+ n (fxsub1 object-alignment)) align-shift) align-shift)) - -(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)] - [(dirty-vector) (mem 28 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 unique-label - (lambda () - (label (gensym)))) - (define (constant-val x) - (cond - [(fixnum? x) (obj x)] - [(boolean? x) (int (if x bool-t bool-f))] - [(null? x) (int nil)] - [(char? x) (int (fx+ (fxsll (char->integer x) char-shift) char-tag))] - [(eq? x (void)) (int void-object)] - [else (obj x)])) - (define (cond-branch op Lt Lf ac) - (define (opposite x) - (cadr (assq x '([je jne] [jl jge] [jle jg] [jg jle] [jge jl])))) - (unless (or Lt Lf) - (error 'cond-branch "no labels")) - (cond - [(not Lf) (cons (list op Lt) ac)] - [(not Lt) (cons (list (opposite op) Lf) ac)] - [else (list* (list op Lt) (jmp Lf) ac)])) - (define (indirect-type-pred pri-mask pri-tag sec-mask sec-tag rand* Lt Lf ac) - (cond - [(and Lt Lf) - (list* (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int pri-mask) ebx) - (cmpl (int pri-tag) ebx) - (jne Lf) - (movl (mem (fx- 0 pri-tag) eax) ebx) - (if sec-mask - (andl (int sec-mask) ebx) - '(nop)) - (cmpl (int sec-tag) ebx) - (jne Lf) - (jmp Lt) - ac)] - [Lf - (list* (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int pri-mask) ebx) - (cmpl (int pri-tag) ebx) - (jne Lf) - (movl (mem (fx- 0 pri-tag) eax) ebx) - (if sec-mask - (andl (int sec-mask) ebx) - '(nop)) - (cmpl (int sec-tag) ebx) - (jne Lf) - ac)] - [Lt - (let ([L_END (unique-label)]) - (list* (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int pri-mask) ebx) - (cmpl (int pri-tag) ebx) - (jne L_END) - (movl (mem (fx- 0 pri-tag) eax) ebx) - (if sec-mask - (andl (int sec-mask) ebx) - '(nop)) - (cmpl (int sec-tag) ebx) - (je Lt) - L_END - ac))] - [else ac])) - (define (type-pred mask tag rand* Lt Lf ac) - (cond - [mask - (list* - (movl (Simple (car rand*)) eax) - (andl (int mask) eax) - (cmpl (int tag) eax) - (cond-branch 'je Lt Lf ac))] - [else - (let ([v (Simple (car rand*))]) - (cond - [(memq (car v) '(mem register)) - (list* - (cmpl (int tag) (Simple (car rand*))) - (cond-branch 'je Lt Lf ac))] - [else - (list* - (movl (Simple (car rand*)) eax) - (cmpl (int tag) eax) - (cond-branch 'je Lt Lf ac))]))])) - (define (compare-and-branch op rand* Lt Lf ac) - (define (opposite x) - (cadr (assq x '([je je] [jl jg] [jle jge] [jg jl] [jge jle])))) - (cond - [(and (constant? (car rand*)) (constant? (cadr rand*))) - (list* - (movl (Simple (car rand*)) eax) - (cmpl (Simple (cadr rand*)) eax) - (cond-branch op Lt Lf ac))] - [(constant? (cadr rand*)) - (list* - (cmpl (Simple (cadr rand*)) (Simple (car rand*))) - (cond-branch op Lt Lf ac))] - [(constant? (car rand*)) - (list* - (cmpl (Simple (car rand*)) (Simple (cadr rand*))) - (cond-branch (opposite op) Lt Lf ac))] - [else - (list* - (movl (Simple (car rand*)) eax) - (cmpl (Simple (cadr rand*)) eax) - (cond-branch op Lt Lf ac))])) - (define (do-pred-prim op rand* Lt Lf ac) - (case op - [(fixnum?) (type-pred fx-mask fx-tag rand* Lt Lf ac)] - [(pair?) (type-pred pair-mask pair-tag rand* Lt Lf ac)] - [(char?) (type-pred char-mask char-tag rand* Lt Lf ac)] - [(string?) (type-pred string-mask string-tag rand* Lt Lf ac)] - [(symbol?) (type-pred symbol-mask symbol-tag rand* Lt Lf ac)] - [(procedure?) (type-pred closure-mask closure-tag rand* Lt Lf ac)] - [(boolean?) (type-pred bool-mask bool-tag rand* Lt Lf ac)] - [(null?) (type-pred #f nil rand* Lt Lf ac)] - [($unbound-object?) (type-pred #f unbound rand* Lt Lf ac)] - [($forward-ptr?) (type-pred #f -1 rand* Lt Lf ac)] - [(not) (type-pred #f bool-f rand* Lt Lf ac)] - [(eof-object?) (type-pred #f eof rand* Lt Lf ac)] - [(bwp-object?) (type-pred #f bwp-object 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)] - [($record/rtd?) - (cond - [Lf - (list* (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int vector-mask) eax) - (cmpl (int vector-tag) eax) - (jne Lf) - (movl (Simple (cadr rand*)) eax) - (cmpl (mem (fx- disp-record-rtd vector-tag) ebx) eax) - (jne Lf) - (if Lt - (cons (jmp Lt) ac) - ac))] - [Lt - (let ([Ljoin (unique-label)]) - (list* (movl (Simple (car rand*)) eax) - (movl eax ebx) - (andl (int vector-mask) eax) - (cmpl (int vector-tag) eax) - (jne Ljoin) - (movl (Simple (cadr rand*)) eax) - (cmpl (mem (fx- disp-record-rtd vector-tag) ebx) eax) - (je Lt) - (label Ljoin) - ac))] - [else ac])] - [(code?) - (indirect-type-pred vector-mask vector-tag #f code-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)] - [($tcbucket-key) - (indirect-ref arg* (fx- disp-tcbucket-key vector-tag) ac)] - [($tcbucket-val) - (indirect-ref arg* (fx- disp-tcbucket-val vector-tag) ac)] - [($tcbucket-next) - (indirect-ref arg* (fx- disp-tcbucket-next vector-tag) ac)] - [(pointer-value) - (list* - (movl (Simple (car arg*)) eax) - (sarl (int fx-shift) eax) - (sall (int fx-shift) eax) - ac)] - [($symbol-plist) - (indirect-ref arg* (fx- disp-symbol-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-tcbucket) - (list* (movl (Simple (car arg*)) eax) - (movl eax (mem disp-tcbucket-tconc apr)) - (movl (Simple (cadr arg*)) eax) - (movl eax (mem disp-tcbucket-key apr)) - (movl (Simple (caddr arg*)) eax) - (movl eax (mem disp-tcbucket-val apr)) - (movl (Simple (cadddr arg*)) eax) - (movl eax (mem disp-tcbucket-next apr)) - (movl apr eax) - (addl (int vector-tag) eax) - (addl (int (align tcbucket-size)) apr) - ac)] - [(vector) - (let f ([arg* arg*] [idx disp-vector-data]) - (cond - [(null? arg*) - (list* (movl apr eax) - (addl (int vector-tag) eax) - (movl (int (fx- idx disp-vector-data)) - (mem disp-vector-length apr)) - (addl (int (align idx)) apr) - ac)] - [else - (list* (movl (Simple (car arg*)) eax) - (movl eax (mem idx apr)) - (f (cdr arg*) (fx+ idx wordsize)))]))] - [($string) - (let f ([arg* arg*] [idx disp-string-data]) - (cond - [(null? arg*) - (list* (movb (int 0) (mem idx apr)) - (movl apr eax) - (addl (int string-tag) eax) - (movl (int (fx* (fx- idx disp-string-data) wordsize)) - (mem disp-string-length apr)) - (addl (int (align (fxadd1 idx))) apr) - ac)] - [else - (record-case (car arg*) - [(constant c) - (unless (char? c) (error who "invalid arg to string ~s" x)) - (list* (movb (int (char->integer c)) (mem idx apr)) - (f (cdr arg*) (fxadd1 idx)))] - [else - (list* (movl (Simple (car arg*)) ebx) - (movb bh (mem idx apr)) - (f (cdr arg*) (fxadd1 idx)))])]))] - [($current-frame) - (list* (movl (pcb-ref 'next-continuation) eax) - ac)] - [($seal-frame-and-call) - (list* (movl (Simple (car arg*)) cpr) ; proc - (movl (pcb-ref 'frame-base) eax) - ; eax=baseofstack - (movl (mem (fx- 0 wordsize) eax) ebx) ; underflow handler - (movl ebx (mem (fx- 0 wordsize) fpr)) ; set - ; create a new cont record - (movl (int continuation-tag) (mem 0 apr)) - (movl fpr (mem disp-continuation-top apr)) - ; compute the size of the captured frame - (movl eax ebx) - (subl fpr ebx) - (subl (int wordsize) ebx) - ; and store it - (movl ebx (mem disp-continuation-size apr)) - ; load next cont - (movl (pcb-ref 'next-continuation) ebx) - ; and store it - (movl ebx (mem disp-continuation-next apr)) - ; adjust ap - (movl apr eax) - (addl (int vector-tag) eax) - (addl (int continuation-size) apr) - ; store new cont in current-cont - (movl eax (pcb-ref 'next-continuation)) - ; adjust fp - (movl fpr (pcb-ref 'frame-base)) - (subl (int wordsize) fpr) - ; tail-call f - (movl eax (mem (fx- 0 wordsize) fpr)) - (movl (int (argc-convention 1)) eax) - (tail-indirect-cpr-call) - ac)] - [($code-instr-size) - (indirect-ref arg* (fx- disp-code-instrsize vector-tag) - (cons (sall (int fx-shift) eax) ac))] - [($code-reloc-size) - (indirect-ref arg* (fx- disp-code-relocsize vector-tag) ac)] - [($code-closure-size) - (indirect-ref arg* (fx- disp-code-closuresize vector-tag) ac)] - [($set-car! $set-cdr! $vector-set! $string-set! $exit - $set-symbol-value! $set-symbol-plist! - $set-code-byte! $set-code-word! primitive-set! - $set-code-object! $set-code-object+offset! $set-code-object+offset/rel! - $record-set!) - (do-effect-prim op arg* - (cons (movl (int void-object) eax) ac))] - [(fixnum? immediate? $fxzero? boolean? char? pair? vector? string? symbol? - procedure? null? not eof-object? $fx= $fx< $fx<= $fx> $fx>= eq? - $char= $char< $char<= $char> $char>= $unbound-object? code? - $record? bwp-object?) - (do-pred->value-prim op arg* ac)] - [($code->closure) - (list* - (movl (Simple (car arg*)) eax) - (addl (int (fx- disp-code-data vector-tag)) eax) - (movl eax (mem 0 apr)) - (movl apr eax) - (addl (int closure-tag) eax) - (addl (int (align disp-closure-data)) apr) - ac)] - [($frame->continuation) - (NonTail - (make-closure (make-code-loc SL_continuation_code) arg*) - ac)] - [($make-call-with-values-procedure) - (NonTail - (make-closure (make-code-loc SL_call_with_values) arg*) - ac)] - [($make-values-procedure) - (NonTail - (make-closure (make-code-loc SL_values) arg*) - ac)] - [else - (error 'value-prim "unhandled ~s" op)])) - (define (indirect-assignment arg* offset ac) - (list* - (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem offset eax)) - ;;; record side effect - (addl (int offset) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)) - (define (do-effect-prim op arg* ac) - (case op - [($vector-set!) - (list* (movl (Simple (car arg*)) ebx) - (addl (Simple (cadr arg*)) ebx) - (addl (int (fx- disp-vector-data vector-tag)) ebx) - (movl (Simple (caddr arg*)) eax) - (movl eax (mem 0 ebx)) - ;;; record side effect - (shrl (int pageshift) ebx) - (sall (int wordshift) ebx) - (addl (pcb-ref 'dirty-vector) ebx) - (movl (int dirty-word) (mem 0 ebx)) - ac)] - [($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-car!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-car pair-tag) eax)) - ;;; record side effect - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-cdr!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-cdr pair-tag) eax)) - ;;; record side effect - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-tcbucket-key!) - (indirect-assignment arg* (fx- disp-tcbucket-key vector-tag) ac)] - [($set-tcbucket-val!) - (indirect-assignment arg* (fx- disp-tcbucket-val vector-tag) ac)] - [($set-tcbucket-next!) - (indirect-assignment arg* (fx- disp-tcbucket-next vector-tag) ac)] - [($set-tcbucket-tconc!) - (indirect-assignment arg* (fx- disp-tcbucket-tconc vector-tag) ac)] - - [($set-symbol-value!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-value symbol-tag) eax)) - ;;; record side effect - (addl (int (fx- disp-symbol-value symbol-tag)) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 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)) - ;;; record side effect - (addl (int (fx- disp-symbol-system-value symbol-tag)) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-symbol-plist!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-plist symbol-tag) eax)) - ;;; record side effect - (addl (int (fx- disp-symbol-plist symbol-tag)) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-symbol-unique-string!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-unique-string symbol-tag) eax)) - ;;; record side effect - (addl (int (fx- disp-symbol-unique-string symbol-tag)) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($set-symbol-string!) - (list* (movl (Simple (car arg*)) eax) - (movl (Simple (cadr arg*)) ebx) - (movl ebx (mem (fx- disp-symbol-string symbol-tag) eax)) - ;;; record side effect - (addl (int (fx- disp-symbol-string symbol-tag)) eax) - (shrl (int pageshift) eax) - (sall (int wordshift) eax) - (addl (pcb-ref 'dirty-vector) eax) - (movl (int dirty-word) (mem 0 eax)) - ac)] - [($record-set!) - (list* (movl (Simple (car arg*)) ebx) - (addl (Simple (cadr arg*)) ebx) - (movl (Simple (caddr arg*)) eax) - (addl (int (fx- disp-record-data record-ptag)) ebx) - (movl eax (mem 0 ebx)) - ;;; record side effect - (shrl (int pageshift) ebx) - (sall (int wordshift) ebx) - (addl (pcb-ref 'dirty-vector) ebx) - (movl (int dirty-word) (mem 0 ebx)) - ac)] - [(cons void $fxadd1 $fxsub1) - (let f ([arg* arg*]) - (cond - [(null? arg*) ac] - [else - (Effect (car arg*) (f (cdr arg*)))]))] - [else - (error 'do-effect-prim "unhandled op ~s" op)])) - (define (do-simple-test x Lt Lf ac) - (unless (or Lt Lf) - (error 'Pred "no labels")) - (cond - [(not Lt) - (list* (cmpl (int bool-f) x) (je Lf) ac)] - [(not Lf) - (list* (cmpl (int bool-f) x) (jne Lt) ac)] - [else - (list* (cmpl (int bool-f) x) (je Lf) (jmp Lt) ac)])) - (define (Simple x) - (record-case x - [(cp-var i) - (mem (fx+ (fx* i wordsize) (fx- disp-closure-data closure-tag)) cpr)] - [(frame-var i) (mem (fx* i (fx- 0 wordsize)) fpr)] - [(constant c) (constant-val c)] - [(code-loc label) (label-address label)] - [(primref op) (primref-loc op)] - [else (error 'Simple "what ~s" x)])) - (define (closure-size x) - (align (fx+ disp-closure-data - (fx* wordsize (length (closure-free* x)))))) - (define (assign-codes rhs* n* i ac) - (cond - [(null? rhs*) ac] - [else - (record-case (car rhs*) - [(closure label free*) - (cons (movl (Simple label) (mem i apr)) - (assign-codes - (cdr rhs*) (cdr n*) (fx+ i (car n*)) ac))])])) - (define (whack-free x i n* rhs* ac) - (cond - [(null? rhs*) ac] - [else - (let ([free (closure-free* (car rhs*))]) - (let f ([free free] [j (fx+ i disp-closure-data)]) - (cond - [(null? free) - (whack-free x (fx+ i (car n*)) (cdr n*) (cdr rhs*) ac)] - [(eq? (car free) x) - (cons - (movl eax (mem j apr)) - (f (cdr free) (fx+ j wordsize)))] - [else (f (cdr free) (fx+ j wordsize))])))])) - (define (assign-nonrec-free* rhs* all-rhs* n* seen ac) - (cond - [(null? rhs*) ac] - [else - (let f ([ls (closure-free* (car rhs*))] [seen seen]) - (cond - [(null? ls) - (assign-nonrec-free* (cdr rhs*) all-rhs* n* seen ac)] - [(memq (car ls) seen) (f (cdr ls) seen)] - [else - (cons - (movl (Simple (car ls)) eax) - (whack-free (car ls) 0 n* all-rhs* - (f (cdr ls) (cons (car ls) seen))))]))])) - (define (assign-rec-free* lhs* rhs* all-n* ac) - (list* (movl apr eax) - (addl (int closure-tag) eax) - (let f ([lhs* lhs*] [n* all-n*]) - (cond - [(null? (cdr lhs*)) - (cons - (movl eax (Simple (car lhs*))) - (whack-free (car lhs*) 0 all-n* rhs* ac))] - [else - (cons - (movl eax (Simple (car lhs*))) - (whack-free (car lhs*) 0 all-n* rhs* - (cons - (addl (int (car n*)) eax) - (f (cdr lhs*) (cdr n*)))))])))) - (define (sum ac ls) - (cond - [(null? ls) ac] - [else (sum (fx+ ac (car ls)) (cdr ls))])) - (define (do-fix lhs* rhs* ac) - ;;; 1. first, set the code pointers in the right places - ;;; 2. next, for every variable appearing in the rhs* but is not in - ;;; the lhs*, load it once and set it everywhere it occurs. - ;;; 3. next, compute the values of the lhs*, and for every computed - ;;; value, store it on the stack, and set it everywhere it occurs - ;;; in the rhs* - ;;; 4. that's it. - (let* ([n* (map closure-size rhs*)]) - (assign-codes rhs* n* 0 - (assign-nonrec-free* rhs* rhs* n* lhs* - (assign-rec-free* lhs* rhs* n* - (cons (addl (int (sum 0 n*)) apr) ac)))))) - (define (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))] - [(fix lhs* rhs* body) - (do-fix lhs* rhs* (NonTail body ac))] - [(primcall op rand*) - (do-value-prim op rand* ac)] - [(new-frame base-idx size body) - (NonTail body ac)] - [(call-cp 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)] - [(foreign) - (list* (addl (int (frame-adjustment offset)) fpr) - (movl (int (argc-convention size)) eax) - (movl '(foreign-label "ik_foreign_call") ebx) - (jmp L_CALL) - ; NEW FRAME - (byte-vector mask) - `(int ,(fx* offset wordsize)) - `(current-frame-offset) - (rp-label rp-convention) ; should be 0, since C has 1 rv - '(byte 0) - '(byte 0) - '(byte 0) - L_CALL - (call ebx) - (movl (mem 0 fpr) cpr) - (subl (int (frame-adjustment offset)) fpr) - ac)] - [else - (error who "invalid convention ~s for call-cp" call-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))] - [(fix lhs* rhs* body) - (do-fix lhs* rhs* (Pred body Lt Lf ac))] - [(primcall op rand*) - (do-pred-prim op rand* Lt Lf ac)] - [(conditional test conseq altern) - (cond - [(not Lt) - (let ([Lj^ (unique-label)] [Lf^ (unique-label)]) - (Pred test #f Lf^ - (Pred conseq Lj^ Lf - (cons Lf^ - (Pred altern #f Lf - (cons Lj^ ac))))))] - [(not Lf) - (let ([Lj^ (unique-label)] [Lf^ (unique-label)]) - (Pred test #f Lf^ - (Pred conseq Lt Lj^ - (cons Lf^ - (Pred altern Lt #f - (cons Lj^ ac))))))] - [else - (let ([Lf^ (unique-label)]) - (Pred test #f Lf^ - (Pred conseq Lt Lf - (cons Lf^ - (Pred altern Lt Lf ac)))))])] - [(seq e0 e1) - (Effect e0 (Pred e1 Lt Lf ac))] - [(new-frame) - (NonTail x (do-simple-test eax Lt Lf ac))] - [else (error 'Pred "invalid expression ~s" x)])) - (define (idx->frame-loc i) - (mem (fx* i (fx- 0 wordsize)) fpr)) - (define (Effect x ac) - (record-case x - [(constant) ac] - [(primcall op rand*) - (do-effect-prim op rand* ac)] - [(conditional test conseq altern) - (let ([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))] - [(fix lhs* rhs* body) - (do-fix lhs* rhs* (Effect body 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))] - [(fix lhs* rhs* body) - (do-fix lhs* rhs* (Tail body 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" call-convention)])] - [else - (list* (movl (mem (fx* (fx+ idx (fxadd1 i)) - (fx- 0 wordsize)) fpr) - eax) - (movl eax (mem (fx* (fx+ i 1) (fx- 0 wordsize)) fpr)) - (f (fxadd1 i)))]))] - [else (error 'Tail "invalid expression ~s" x)])) - (define (handle-vararg fml-count ac) - (define CONTINUE_LABEL (unique-label)) - (define DONE_LABEL (unique-label)) - (define CONS_LABEL (unique-label)) - (define LOOP_HEAD (unique-label)) - (define L_CALL (unique-label)) - (list* (cmpl (int (argc-convention (fxsub1 fml-count))) eax) - (jg (label SL_invalid_args)) - (jl CONS_LABEL) - (movl (int nil) ebx) - (jmp DONE_LABEL) - CONS_LABEL - (movl (pcb-ref 'allocation-redline) ebx) - (addl eax ebx) - (addl eax ebx) - (cmpl ebx apr) - (jle LOOP_HEAD) - ; overflow - (addl eax esp) ; advance esp to cover args - (pushl cpr) ; push current cp - (pushl eax) ; push argc - (negl eax) ; make argc positive - (addl (int (fx* 4 wordsize)) eax) ; add 4 words to adjust frame size - (pushl eax) ; push frame size - (addl eax eax) ; double the number of args - (movl eax (mem (fx* -2 wordsize) fpr)) ; pass it as first arg - (movl (int (argc-convention 1)) eax) ; setup argc - (movl (primref-loc 'do-vararg-overflow) cpr) ; load handler - (jmp L_CALL) ; go to overflow handler - ; NEW FRAME - (int 0) ; if the framesize=0, then the framesize is dynamic - '(current-frame-offset) - (int 0) ; multiarg rp - (byte 0) - (byte 0) - L_CALL - (indirect-cpr-call) - (popl eax) ; pop framesize and drop it - (popl eax) ; reload argc - (popl cpr) ; reload cp - (subl eax fpr) ; readjust fp - LOOP_HEAD - (movl (int nil) ebx) - CONTINUE_LABEL - (movl ebx (mem disp-cdr apr)) - (movl (mem fpr eax) ebx) - (movl ebx (mem disp-car apr)) - (movl apr ebx) - (addl (int pair-tag) ebx) - (addl (int pair-size) apr) - (addl (int (fxsll 1 fx-shift)) eax) - (cmpl (int (fx- 0 (fxsll fml-count fx-shift))) eax) - (jle CONTINUE_LABEL) - DONE_LABEL - (movl ebx (mem (fx- 0 (fxsll fml-count fx-shift)) fpr)) - ac)) - (define (Entry check? x ac) - (record-case x - [(clambda-case fml* proper body) - (let ([ac (Tail body ac)]) - (cond - [(and proper check?) - (list* (cmpl (int (argc-convention (length fml*))) eax) - (jne (label SL_invalid_args)) - ac)] - [proper ac] - [else - (handle-vararg (length fml*) ac)]))])) - (define make-dispatcher - (lambda (j? L L* x x* ac) - (cond - [(null? L*) (if j? (cons (jmp (label L)) ac) ac)] - [else - (record-case x - [(clambda-case fml* proper _) - (cond - [proper - (list* (cmpl (int (argc-convention (length fml*))) eax) - (je (label L)) - (make-dispatcher #t - (car L*) (cdr L*) (car x*) (cdr x*) ac))] - [else - (list* (cmpl (int (argc-convention (fxsub1 (length fml*)))) eax) - (jle (label L)) - (make-dispatcher #t - (car L*) (cdr L*) (car x*) (cdr x*) ac))])])]))) - (define (handle-cases x x*) - (let ([L* (map (lambda (_) (gensym)) x*)] - [L (gensym)]) - (make-dispatcher #f L L* x x* - (let f ([x x] [x* x*] [L L] [L* L*]) - (cond - [(null? x*) - (cons (label L) (Entry 'check x '()))] - [else - (cons (label L) - (Entry #f x - (f (car x*) (cdr x*) (car L*) (cdr L*))))]))))) - (define (CodeExpr x) - (record-case x - [(clambda-code L cases free) - (list* - (fx+ disp-closure-data (fx* wordsize (length free))) - (label L) - (handle-cases (car cases) (cdr cases)))])) - (record-case x - [(codes list body) - (cons (cons 0 (Tail body '())) - (map CodeExpr list))])) - - -(define SL_nonprocedure (gensym "SL_nonprocedure")) -(define SL_invalid_args (gensym "SL_invalid_args")) -(define SL_foreign_call (gensym "SL_foreign_call")) -(define SL_continuation_code (gensym "SL_continuation_code")) -(define SL_multiple_values_error_rp (gensym "SL_multiple_values_error_rp")) -(define SL_multiple_values_ignore_rp (gensym "SL_multiple_ignore_error_rp")) -(define SL_underflow_multiple_values (gensym "SL_underflow_multiple_values")) -(define SL_underflow_handler (gensym "SL_underflow_handler")) -(define SL_scheme_exit (gensym "SL_scheme_exit")) -(define SL_apply (gensym "SL_apply")) -(define SL_values (gensym "SL_values")) -(define SL_call_with_values (gensym "SL_call_with_values")) - -(module () -(list*->code* - (list - (let ([L_cwv_done (gensym)] - [L_cwv_loop (gensym)] - [L_cwv_multi_rp (gensym)] - [L_cwv_call (gensym)]) - (list disp-closure-data - (label SL_call_with_values) - (cmpl (int (argc-convention 2)) eax) - (jne (label SL_invalid_args)) - (movl (mem (fx- 0 wordsize) fpr) ebx) ; producer - (movl ebx cpr) - (andl (int closure-mask) ebx) - (cmpl (int closure-tag) ebx) - (jne (label SL_nonprocedure)) - (movl (int (argc-convention 0)) eax) - (subl (int (fx* wordsize 2)) fpr) - (jmp (label L_cwv_call)) - ; MV NEW FRAME - (byte-vector '#(#b110)) - (int (fx* wordsize 3)) - '(current-frame-offset) - (label-address L_cwv_multi_rp) - (byte 0) - (byte 0) - (label L_cwv_call) - (indirect-cpr-call) - ;;; one value returned - (addl (int (fx* wordsize 2)) fpr) - (movl (mem (fx* -2 wordsize) fpr) ebx) ; consumer - (movl ebx cpr) - (movl eax (mem (fx- 0 wordsize) fpr)) - (movl (int (argc-convention 1)) eax) - (andl (int closure-mask) ebx) - (cmpl (int closure-tag) ebx) - (jne (label SL_nonprocedure)) - (tail-indirect-cpr-call) - ;;; multiple values returned - (label L_cwv_multi_rp) - ; because values does not pop the return point - ; we have to adjust fp one more word here - (addl (int (fx* wordsize 3)) fpr) - (movl (mem (fx* -2 wordsize) fpr) cpr) ; consumer - (cmpl (int (argc-convention 0)) eax) - (je (label L_cwv_done)) - (movl (int (fx* -4 wordsize)) ebx) - (addl fpr ebx) ; ebx points to first value - (movl ebx ecx) - (addl eax ecx) ; ecx points to the last value - (label L_cwv_loop) - (movl (mem 0 ebx) edx) - (movl edx (mem (fx* 3 wordsize) ebx)) - (subl (int wordsize) ebx) - (cmpl ecx ebx) - (jge (label L_cwv_loop)) - (label L_cwv_done) - (movl cpr ebx) - (andl (int closure-mask) ebx) - (cmpl (int closure-tag) ebx) - (jne (label SL_nonprocedure)) - (tail-indirect-cpr-call))) - - (let ([L_values_one_value (gensym)] - [L_values_many_values (gensym)]) - (list disp-closure-data - (label SL_values) - (cmpl (int (argc-convention 1)) eax) - (je (label L_values_one_value)) - (label L_values_many_values) - (movl (mem 0 fpr) ebx) ; return point - (jmp (mem disp-multivalue-rp ebx)) ; go - (label L_values_one_value) - (movl (mem (fx- 0 wordsize) fpr) eax) - (ret))) - - (let ([L_apply_done (gensym)] - [L_apply_loop (gensym)]) - (list 0 - (label SL_apply) - (movl (mem fpr eax) ebx) - (cmpl (int nil) ebx) - (je (label L_apply_done)) - (label L_apply_loop) - (movl (mem (fx- disp-car pair-tag) ebx) ecx) - (movl (mem (fx- disp-cdr pair-tag) ebx) ebx) - (movl ecx (mem fpr eax)) - (subl (int wordsize) eax) - (cmpl (int nil) ebx) - (jne (label L_apply_loop)) - (label L_apply_done) - (addl (int wordsize) eax) - (tail-indirect-cpr-call))) - - (list 0 - (label SL_nonprocedure) - (movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg - (movl (primref-loc '$apply-nonprocedure-error-handler) cpr) - (movl (int (argc-convention 1)) eax) - (tail-indirect-cpr-call)) - - (list 0 - (label SL_multiple_values_error_rp) - (movl (primref-loc '$multiple-values-error) cpr) - (tail-indirect-cpr-call)) - - (list 0 - (label SL_multiple_values_ignore_rp) - (ret)) - - (list 0 - (label SL_invalid_args) - ;;; - (movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg - (negl eax) - (movl eax (mem (fx- 0 (fx* 2 wordsize)) fpr)) - (movl (primref-loc '$incorrect-args-error-handler) cpr) - (movl (int (argc-convention 2)) eax) - (tail-indirect-cpr-call)) - - (let ([Lset (gensym)] [Lloop (gensym)]) - (list 0 - (label SL_foreign_call) - (movl fpr (pcb-ref 'frame-pointer)) - (movl apr (pcb-ref 'allocation-pointer)) - (movl fpr ebx) - (movl (pcb-ref 'system-stack) esp) - (pushl pcr) - (cmpl (int 0) eax) - (je (label Lset)) - (label Lloop) - (movl (mem ebx eax) ecx) - (pushl ecx) - (addl (int 4) eax) - (cmpl (int 0) eax) - (jne (label Lloop)) - (label Lset) - ; FOREIGN NEW FRAME - (call cpr) - (movl (pcb-ref 'frame-pointer) fpr) - (movl (pcb-ref 'allocation-pointer) apr) - (ret))) - - (let ([L_cont_zero_args (gensym)] - [L_cont_mult_args (gensym)] - [L_cont_one_arg (gensym)] - [L_cont_mult_move_args (gensym)] - [L_cont_mult_copy_loop (gensym)]) - (list - (fx+ disp-closure-data wordsize) - (label SL_continuation_code) - (movl (mem (fx- disp-closure-data closure-tag) cpr) ebx) ; captured-k - (movl ebx (pcb-ref 'next-continuation)) ; set - (movl (pcb-ref 'frame-base) ebx) - (cmpl (int (argc-convention 1)) eax) - (jg (label L_cont_zero_args)) - (jl (label L_cont_mult_args)) - (label L_cont_one_arg) - (movl (mem (fx- 0 wordsize) fpr) eax) - (movl ebx fpr) - (subl (int wordsize) fpr) - (ret) - (label L_cont_zero_args) - (subl (int wordsize) ebx) - (movl ebx fpr) - (movl (mem 0 ebx) ebx) ; return point - (jmp (mem disp-multivalue-rp ebx)) ; go - (label L_cont_mult_args) - (subl (int wordsize) ebx) - (cmpl ebx fpr) - (jne (label L_cont_mult_move_args)) - (movl (mem 0 ebx) ebx) - (jmp (mem disp-multivalue-rp ebx)) - (label L_cont_mult_move_args) - ; move args from fpr to ebx - (movl (int 0) ecx) - (label L_cont_mult_copy_loop) - (subl (int wordsize) ecx) - (movl (mem fpr ecx) edx) - (movl edx (mem ebx ecx)) - (cmpl ecx eax) - (jne (label L_cont_mult_copy_loop)) - (movl ebx fpr) - (movl (mem 0 ebx) ebx) - (jmp (mem disp-multivalue-rp ebx)) - )) - ))) - - - -(define (compile-expr expr) - (let* ([p (recordize expr)] - [p (optimize-direct-calls p)] - [p (optimize-letrec p)] - [p (remove-letrec p)] - [p (remove-assignments p)] - [p (convert-closures p)] - [p (lift-codes p)] - [p (introduce-primcalls p)] - [p (simplify-operands 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*)]) - (car code*))) - -(define compile-file - (lambda (input-file output-file . rest) - (let ([ip (open-input-file input-file)] - [op (apply open-output-file output-file rest)]) - (let f () - (let ([x (read ip)]) - (unless (eof-object? x) - (fasl-write (compile-expr (expand x)) op) - (f)))) - (close-input-port ip) - (close-output-port op)))) - -(primitive-set! 'compile-file compile-file) -(primitive-set! 'assembler-output (make-parameter #f)) -) - diff --git a/src/libcompile-8.1.ss b/src/libcompile-8.1.ss index b25dcf3..984d346 100644 --- a/src/libcompile-8.1.ss +++ b/src/libcompile-8.1.ss @@ -126,7 +126,9 @@ [port? 1 pred] [input-port? 1 pred] [output-port? 1 pred] - [$make-port 7 value] + [$make-port/input 7 value] + [$make-port/output 7 value] + [$make-port/both 7 value] [$port-handler 1 value] [$port-input-buffer 1 value] [$port-input-index 1 value] @@ -362,8 +364,8 @@ [(top-level-value) (let ([var (quoted-sym (cadr x))]) (if (eq? (expand-mode) 'bootstrap) - ;(error 'compile "reference to ~s in bootstrap mode" var) - (make-primref var) + (error 'compile "reference to ~s in bootstrap mode" var) + ;(make-primref var) (make-funcall (make-primref 'top-level-value) (list (make-constant var)))))] @@ -1096,7 +1098,14 @@ [(fixnum? immediate? boolean? char? vector? string? procedure? null? pair? not cons eq? vector symbol? error eof-object eof-object? void $unbound-object? $code? $forward-ptr? bwp-object? - pointer-value top-level-value car cdr list* list $record) + pointer-value top-level-value car cdr list* list $record + port? input-port? output-port? + $make-port/input $make-port/output $make-port/both + $port-handler + $port-input-buffer $port-input-index $port-input-size + $port-output-buffer $port-output-index $port-output-size + $set-port-input-index! $set-port-input-size! + $set-port-output-index! $set-port-output-size! ) '#t] [($fxadd1 $fxsub1 $fxzero? $fxlognot $fxlogor $fxlogand $fx+ $fx- $fx* $fx= $fx< $fx<= $fx> $fx>= $fxquotient $fxmodulo $fxsll $fxsra $fxlogxor $exit) @@ -1468,6 +1477,8 @@ (check-bytes (fxadd1 disp-string-data) (car arg*) x)])] [($string) (check-const (fx+ (length arg*) (fx+ disp-string-data 1)) x)] + [($make-port/input $make-port/output $make-port/both) + (check-const port-size x)] [($make-vector) (record-case (car arg*) [(constant i) @@ -1551,7 +1562,7 @@ s)) (define (check? x) (cond - [(primref? x) #t] ;;;; PRIMREF CHECK + [(primref? x) #f] ;;;; PRIMREF CHECK [else #t])) (define (do-new-frame op rand* si r call-convention rp-convention orig-live) (make-new-frame (fxadd1 si) (fx+ (length rand*) 2) @@ -1967,6 +1978,19 @@ (define disp-code-relocsize 8) (define disp-code-freevars 12) (define disp-code-data 16) + (define port-tag #x3F) + (define input-port-tag #x7F) + (define output-port-tag #xBF) + (define input/output-port-tag #xFF) + (define port-mask #x3F) + (define disp-port-handler 4) + (define disp-port-input-buffer 8) + (define disp-port-input-index 12) + (define disp-port-input-size 16) + (define disp-port-output-buffer 20) + (define disp-port-output-index 24) + (define disp-port-output-size 28) + (define port-size 32) (define disp-tcbucket-tconc 0) (define disp-tcbucket-key 4) (define disp-tcbucket-val 8) @@ -2220,6 +2244,15 @@ [($record?) (indirect-type-pred record-pmask record-ptag record-pmask record-ptag rand* Lt Lf ac)] + [(output-port?) + (indirect-type-pred + vector-mask vector-tag #f output-port-tag rand* Lt Lf ac)] + [(input-port?) + (indirect-type-pred + vector-mask vector-tag #f input-port-tag rand* Lt Lf ac)] + [(port?) + (indirect-type-pred + vector-mask vector-tag port-mask port-tag rand* Lt Lf ac)] [($record/rtd?) (cond [Lf @@ -2352,6 +2385,23 @@ (movl (Simple (car arg*)) eax) (movl (mem off eax) eax) ac)) + (define (do-make-port tag args ac) + (let f ([args args] [idx disp-vector-data]) + (cond + [(null? args) + (if (fx= idx port-size) + (list* + (movl (int tag) (mem 0 apr)) + (movl apr eax) + (addl (int port-size) apr) + (addl (int vector-tag) eax) + ac) + (error 'do-make-port "BUG"))] + [else + (list* + (movl (Simple (car args)) eax) + (movl eax (mem idx apr)) + (f (cdr args) (fx+ idx wordsize)))]))) (define (do-value-prim op arg* ac) (case op [(eof-object) (cons (movl (int eof) eax) ac)] @@ -2489,6 +2539,20 @@ (indirect-ref arg* (fx- disp-tcbucket-val vector-tag) ac)] [($tcbucket-next) (indirect-ref arg* (fx- disp-tcbucket-next vector-tag) ac)] + [($port-handler) + (indirect-ref arg* (fx- disp-port-handler vector-tag) ac)] + [($port-input-buffer) + (indirect-ref arg* (fx- disp-port-input-buffer vector-tag) ac)] + [($port-input-index) + (indirect-ref arg* (fx- disp-port-input-index vector-tag) ac)] + [($port-input-size) + (indirect-ref arg* (fx- disp-port-input-size vector-tag) ac)] + [($port-output-buffer) + (indirect-ref arg* (fx- disp-port-output-buffer vector-tag) ac)] + [($port-output-index) + (indirect-ref arg* (fx- disp-port-output-index vector-tag) ac)] + [($port-output-size) + (indirect-ref arg* (fx- disp-port-output-size vector-tag) ac)] [(pointer-value) (list* (movl (Simple (car arg*)) eax) @@ -2668,6 +2732,9 @@ (addl (int symbol-tag) eax) (addl (int (align symbol-size)) apr) ac)] + [($make-port/input) (do-make-port input-port-tag arg* ac)] + [($make-port/output) (do-make-port output-port-tag arg* ac)] + [($make-port/both) (do-make-port input/output-port-tag arg* ac)] [($make-tcbucket) (list* (movl (Simple (car arg*)) eax) (movl eax (mem disp-tcbucket-tconc apr)) @@ -2781,13 +2848,15 @@ $set-symbol-value! $set-symbol-plist! $code-set! primitive-set! $set-code-object! $set-code-object+offset! $set-code-object+offset/rel! - $record-set!) + $record-set! + $set-port-input-index! $set-port-input-size! + $set-port-output-index! $set-port-output-size!) (do-effect-prim op arg* (cons (movl (int void-object) eax) ac))] [(fixnum? 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? - $record? $record/rtd? bwp-object?) + $record? $record/rtd? bwp-object? port? input-port? output-port?) (do-pred->value-prim op arg* ac)] [($code->closure) (list* @@ -2881,7 +2950,32 @@ (indirect-assignment arg* (fx- disp-tcbucket-next vector-tag) ac)] [($set-tcbucket-tconc!) (indirect-assignment arg* (fx- disp-tcbucket-tconc vector-tag) ac)] - + [($set-port-input-index!) + (list* + (movl (Simple (car arg*)) eax) + (movl (Simple (cadr arg*)) ebx) + (movl ebx (mem (fx- disp-port-input-index vector-tag) eax)) + ac)] + [($set-port-input-size!) + (list* + (movl (Simple (car arg*)) eax) + (movl (Simple (cadr arg*)) ebx) + (movl (int 0) (mem (fx- disp-port-input-index vector-tag) eax)) + (movl ebx (mem (fx- disp-port-input-size vector-tag) eax)) + ac)] + [($set-port-output-index!) + (list* + (movl (Simple (car arg*)) eax) + (movl (Simple (cadr arg*)) ebx) + (movl ebx (mem (fx- disp-port-output-index vector-tag) eax)) + ac)] + [($set-port-output-size!) + (list* + (movl (Simple (car arg*)) eax) + (movl (Simple (cadr arg*)) ebx) + (movl (int 0) (mem (fx- disp-port-output-index vector-tag) eax)) + (movl ebx (mem (fx- disp-port-output-size vector-tag) eax)) + ac)] [($set-symbol-value!) (list* (movl (Simple (car arg*)) eax) (movl (Simple (cadr arg*)) ebx) diff --git a/src/libcompile-6.7.ss b/src/libcompile-9.0.ss similarity index 96% rename from src/libcompile-6.7.ss rename to src/libcompile-9.0.ss index 8e21502..8e8dc40 100644 --- a/src/libcompile-6.7.ss +++ b/src/libcompile-9.0.ss @@ -1,4 +1,7 @@ +;;; 9.0: * calls (gensym ) instead of +;;; (gensym (symbol->string )) in order to avoid incrementing +;;; gensym-count. ;;; 6.7: * open-coded top-level-value, car, cdr ;;; 6.2: * side-effects now modify the dirty-vector ;;; * added bwp-object? @@ -122,6 +125,24 @@ [primitive-ref 1 value] [primitive-set! 2 effect] [top-level-value 1 value] + ;;; ports + [port? 1 pred] + [input-port? 1 pred] + [output-port? 1 pred] + [$make-port/input 7 value] + [$make-port/output 7 value] + [$make-port/both 7 value] + [$port-handler 1 value] + [$port-input-buffer 1 value] + [$port-input-index 1 value] + [$port-input-size 1 value] + [$port-output-buffer 1 value] + [$port-output-index 1 value] + [$port-output-size 1 value] + [$set-port-input-index! 2 effect] + [$set-port-input-size! 2 effect] + [$set-port-output-index! 2 effect] + [$set-port-output-size! 2 effect] ;;; tcbuckets [$make-tcbucket 4 value] [$tcbucket-key 1 value] @@ -215,7 +236,7 @@ (define-record assign (lhs rhs)) (define (unique-var x) - (make-var (gensym (symbol->string x)) #f)) + (make-var (gensym x) #f)) (define (make-bind^ lhs* rhs* body) @@ -347,6 +368,7 @@ (let ([var (quoted-sym (cadr x))]) (if (eq? (expand-mode) 'bootstrap) (error 'compile "reference to ~s in bootstrap mode" var) + ;(make-primref var) (make-funcall (make-primref 'top-level-value) (list (make-constant var)))))] @@ -1079,7 +1101,14 @@ [(fixnum? immediate? boolean? char? vector? string? procedure? null? pair? not cons eq? vector symbol? error eof-object eof-object? void $unbound-object? $code? $forward-ptr? bwp-object? - pointer-value top-level-value car cdr list* list $record) + pointer-value top-level-value car cdr list* list $record + port? input-port? output-port? + $make-port/input $make-port/output $make-port/both + $port-handler + $port-input-buffer $port-input-index $port-input-size + $port-output-buffer $port-output-index $port-output-size + $set-port-input-index! $set-port-input-size! + $set-port-output-index! $set-port-output-size! ) '#t] [($fxadd1 $fxsub1 $fxzero? $fxlognot $fxlogor $fxlogand $fx+ $fx- $fx* $fx= $fx< $fx<= $fx> $fx>= $fxquotient $fxmodulo $fxsll $fxsra $fxlogxor $exit) @@ -1451,6 +1480,8 @@ (check-bytes (fxadd1 disp-string-data) (car arg*) x)])] [($string) (check-const (fx+ (length arg*) (fx+ disp-string-data 1)) x)] + [($make-port/input $make-port/output $make-port/both) + (check-const port-size x)] [($make-vector) (record-case (car arg*) [(constant i) @@ -1950,11 +1981,24 @@ (define disp-code-relocsize 8) (define disp-code-freevars 12) (define disp-code-data 16) + (define port-tag #x3F) + (define input-port-tag #x7F) + (define output-port-tag #xBF) + (define input/output-port-tag #xFF) + (define port-mask #x3F) + (define disp-port-handler 4) + (define disp-port-input-buffer 8) + (define disp-port-input-index 12) + (define disp-port-input-size 16) + (define disp-port-output-buffer 20) + (define disp-port-output-index 24) + (define disp-port-output-size 28) + (define port-size 32) (define disp-tcbucket-tconc 0) (define disp-tcbucket-key 4) (define disp-tcbucket-val 8) (define disp-tcbucket-next 12) - (define tcbucket-size 16) + (define tcbucket-size 24) (define record-ptag 5) (define record-pmask 7) (define disp-record-rtd 0) @@ -2203,6 +2247,15 @@ [($record?) (indirect-type-pred record-pmask record-ptag record-pmask record-ptag rand* Lt Lf ac)] + [(output-port?) + (indirect-type-pred + vector-mask vector-tag #f output-port-tag rand* Lt Lf ac)] + [(input-port?) + (indirect-type-pred + vector-mask vector-tag #f input-port-tag rand* Lt Lf ac)] + [(port?) + (indirect-type-pred + vector-mask vector-tag port-mask port-tag rand* Lt Lf ac)] [($record/rtd?) (cond [Lf @@ -2335,6 +2388,23 @@ (movl (Simple (car arg*)) eax) (movl (mem off eax) eax) ac)) + (define (do-make-port tag args ac) + (let f ([args args] [idx disp-vector-data]) + (cond + [(null? args) + (if (fx= idx port-size) + (list* + (movl (int tag) (mem 0 apr)) + (movl apr eax) + (addl (int port-size) apr) + (addl (int vector-tag) eax) + ac) + (error 'do-make-port "BUG"))] + [else + (list* + (movl (Simple (car args)) eax) + (movl eax (mem idx apr)) + (f (cdr args) (fx+ idx wordsize)))]))) (define (do-value-prim op arg* ac) (case op [(eof-object) (cons (movl (int eof) eax) ac)] @@ -2472,6 +2542,20 @@ (indirect-ref arg* (fx- disp-tcbucket-val vector-tag) ac)] [($tcbucket-next) (indirect-ref arg* (fx- disp-tcbucket-next vector-tag) ac)] + [($port-handler) + (indirect-ref arg* (fx- disp-port-handler vector-tag) ac)] + [($port-input-buffer) + (indirect-ref arg* (fx- disp-port-input-buffer vector-tag) ac)] + [($port-input-index) + (indirect-ref arg* (fx- disp-port-input-index vector-tag) ac)] + [($port-input-size) + (indirect-ref arg* (fx- disp-port-input-size vector-tag) ac)] + [($port-output-buffer) + (indirect-ref arg* (fx- disp-port-output-buffer vector-tag) ac)] + [($port-output-index) + (indirect-ref arg* (fx- disp-port-output-index vector-tag) ac)] + [($port-output-size) + (indirect-ref arg* (fx- disp-port-output-size vector-tag) ac)] [(pointer-value) (list* (movl (Simple (car arg*)) eax) @@ -2651,6 +2735,9 @@ (addl (int symbol-tag) eax) (addl (int (align symbol-size)) apr) ac)] + [($make-port/input) (do-make-port input-port-tag arg* ac)] + [($make-port/output) (do-make-port output-port-tag arg* ac)] + [($make-port/both) (do-make-port input/output-port-tag arg* ac)] [($make-tcbucket) (list* (movl (Simple (car arg*)) eax) (movl eax (mem disp-tcbucket-tconc apr)) @@ -2764,13 +2851,15 @@ $set-symbol-value! $set-symbol-plist! $code-set! primitive-set! $set-code-object! $set-code-object+offset! $set-code-object+offset/rel! - $record-set!) + $record-set! + $set-port-input-index! $set-port-input-size! + $set-port-output-index! $set-port-output-size!) (do-effect-prim op arg* (cons (movl (int void-object) eax) ac))] [(fixnum? 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? - $record? $record/rtd? bwp-object?) + $record? $record/rtd? bwp-object? port? input-port? output-port?) (do-pred->value-prim op arg* ac)] [($code->closure) (list* @@ -2864,7 +2953,32 @@ (indirect-assignment arg* (fx- disp-tcbucket-next vector-tag) ac)] [($set-tcbucket-tconc!) (indirect-assignment arg* (fx- disp-tcbucket-tconc vector-tag) ac)] - + [($set-port-input-index!) + (list* + (movl (Simple (car arg*)) eax) + (movl (Simple (cadr arg*)) ebx) + (movl ebx (mem (fx- disp-port-input-index vector-tag) eax)) + ac)] + [($set-port-input-size!) + (list* + (movl (Simple (car arg*)) eax) + (movl (Simple (cadr arg*)) ebx) + (movl (int 0) (mem (fx- disp-port-input-index vector-tag) eax)) + (movl ebx (mem (fx- disp-port-input-size vector-tag) eax)) + ac)] + [($set-port-output-index!) + (list* + (movl (Simple (car arg*)) eax) + (movl (Simple (cadr arg*)) ebx) + (movl ebx (mem (fx- disp-port-output-index vector-tag) eax)) + ac)] + [($set-port-output-size!) + (list* + (movl (Simple (car arg*)) eax) + (movl (Simple (cadr arg*)) ebx) + (movl (int 0) (mem (fx- disp-port-output-index vector-tag) eax)) + (movl ebx (mem (fx- disp-port-output-size vector-tag) eax)) + ac)] [($set-symbol-value!) (list* (movl (Simple (car arg*)) eax) (movl (Simple (cadr arg*)) ebx) diff --git a/src/libcompile-6.6.ss b/src/libcompile-9.1.ss similarity index 80% rename from src/libcompile-6.6.ss rename to src/libcompile-9.1.ss index 6e2ba57..84b1cb1 100644 --- a/src/libcompile-6.6.ss +++ b/src/libcompile-9.1.ss @@ -1,5 +1,8 @@ - +;;; 9.0: * calls (gensym ) instead of +;;; (gensym (symbol->string )) in order to avoid incrementing +;;; gensym-count. +;;; 6.7: * open-coded top-level-value, car, cdr ;;; 6.2: * side-effects now modify the dirty-vector ;;; * added bwp-object? ;;; * added pointer-value @@ -88,6 +91,10 @@ [$char->fixnum 1 value] ;;; lists/pairs [cons 2 value] + [list* positive value] + [list any value] + [car 1 value] + [cdr 1 value] [$car 1 value] [$cdr 1 value] [$set-car! 2 effect] @@ -98,6 +105,7 @@ [$vector-length 1 value] [$vector-ref 2 value] [$vector-set! 3 effect] + [$vector-memq 2 value] ;;; strings [$make-string 1 value] [$string any value] @@ -116,13 +124,36 @@ [$set-symbol-plist! 2 effect] [primitive-ref 1 value] [primitive-set! 2 effect] + [top-level-value 1 value] + ;;; ports + [port? 1 pred] + [input-port? 1 pred] + [output-port? 1 pred] + [$make-port/input 7 value] + [$make-port/output 7 value] + [$make-port/both 7 value] + [$port-handler 1 value] + [$port-input-buffer 1 value] + [$port-input-index 1 value] + [$port-input-size 1 value] + [$port-output-buffer 1 value] + [$port-output-index 1 value] + [$port-output-size 1 value] + [$set-port-input-index! 2 effect] + [$set-port-input-size! 2 effect] + [$set-port-output-index! 2 effect] + [$set-port-output-size! 2 effect] ;;; tcbuckets [$make-tcbucket 4 value] [$tcbucket-key 1 value] [$tcbucket-val 1 value] [$tcbucket-next 1 value] + [$tcbucket-dlink-next 1 value] + [$tcbucket-dlink-prev 1 value] [$set-tcbucket-val! 2 effect] [$set-tcbucket-next! 2 effect] + [$set-tcbucket-dlink-next! 2 effect] + [$set-tcbucket-dlink-prev! 2 effect] [$set-tcbucket-tconc! 2 effect] ;;; misc [eof-object 0 value] @@ -141,13 +172,14 @@ [$record-rtd 1 value] [$record-ref 2 value] [$record-set! 3 effect] + [$record any value] ;;; ;;; asm ;;; [$code? 1 pred] [$code-size 1 value] [$code-reloc-vector 1 value] - [$code-closure-size 1 value] + [$code-freevars 1 value] [$code-ref 2 value] [$code-set! 3 value] [$code->closure 1 value] @@ -162,299 +194,10 @@ [(assq x open-coded-primitives) => caddr] [else (error 'primitive-context "unknown prim ~s" x)])) - -;;; primitives table section -(define primitives-table - '(;;; system locations used by the C/Scheme interface - [$apply-nonprocedure-error-handler library] - [$incorrect-args-error-handler library] - [$multiple-values-error library] - [$intern library] - [do-overflow library] - [do-vararg-overflow library] - [do-stack-overflow library] - ;;; type predicates - [fixnum? public] - [immediate? public] - [boolean? public] - [char? public] - [null? public] - [pair? public] - [symbol? public] - [vector? public] - [string? public] - [procedure? public] - [eof-object? public] - [not public] - [eq? public] - [equal? public] - ;;; fixnum primitives - [fxadd1 public] - [fxsub1 public] - [fx+ public] - [fx- public] - [fx* public] - [fxsll public] - [fxsra public] - [fxlogor public] - [fxlogand public] - [fxlogxor public] - [fxlognot public] - [fxquotient public] - [fxremainder public] - [fxmodulo public] - ;;; fixnum predicates - [fxzero? public] - [fx= public] - [fx< public] - [fx<= public] - [fx> public] - [fx>= public] - ;;; characters - [char=? public] - [char? public] - [char>=? public] - [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] - [memv 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] - [primitive-set! 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] - [syntax-error public] - [current-expand public] - [expand-mode public] - [assembler-output public] - [compile-file public] - [fasl-write public] - - [$sc-put-cte public] - [sc-expand public] - [$make-environment public] - [environment? public] - [interaction-environment public] - [identifier? public] - [syntax->list public] - [syntax-object->datum public] - [datum->syntax-object public] - [generate-temporaries public] - [free-identifier=? public] - [bound-identifier=? public] - [literal-identifier=? public] - [syntax-error public] - [$syntax-dispatch public] - - - - [interpret public] - [compile public] - [eval public] - [current-eval public] - [load public] - [new-cafe public] - [collect public] - [call/cc public] - [call/cf library] - [dynamic-wind public] - [values public] - [call-with-values public] - [make-traced-procedure library] - [trace-symbol! library] - [untrace-symbol! library] - ;;; record - [$base-rtd library] - [record? public] - [record-rtd public] - [record-name public] - [record-printer public] - [record-length public] - [record-ref public] - [record-set! public] - ;;; record rtds - [make-record-type public] - [record-type-name public] - [record-type-descriptor public] - [record-type-symbol public] - [record-type-field-names public] - [record-constructor public] - [record-predicate public] - [record-field-accessor public] - [record-field-mutator public] - ;;; hash tables - [make-hash-table public] - [hash-table? public] - [get-hash-table public] - [put-hash-table! public] - ;;; asm - [make-code public] - [code? public] - [code-size public] - [code-closure-size public] - [code-ref public] - [code-set! public] - [code-reloc-vector public] - [set-code-reloc-vector! public] - [code->closure public] - [list*->code* library] - ;;; - ;;; POSIX - ;;; - [fork public] - [posix-fork public] - [system public] - [$debug public] - [$underflow-misaligned-error public] - )) - - -(define (primitive? x) - (cond - [(assq x primitives-table) #t] - [(assq x open-coded-primitives) #t] - [else #f])) - (define (open-codeable? x) (cond [(assq x open-coded-primitives) #t] - [(assq x primitives-table) #f] - [else (error 'open-codeable "invalid primitive ~s" x)])) + [else #f])) (define (open-coded-primitive-args x) (cond @@ -476,6 +219,7 @@ (define-record return (value)) (define-record call-cp (call-convention rp-convention base-idx arg-count live-mask)) +(define-record tailcall-cp (convention arg-count)) (define-record primcall (op arg*)) (define-record primref (name)) (define-record conditional (test conseq altern)) @@ -487,22 +231,17 @@ (define-record clambda-case (arg* proper body)) (define-record clambda (cases)) (define-record clambda-code (label cases free)) - (define-record closure (code free*)) (define-record funcall (op rand*)) (define-record appcall (op rand*)) (define-record forcall (op rand*)) (define-record code-rec (arg* proper free* body)) - (define-record codes (list body)) (define-record assign (lhs rhs)) -(define unique-var - (let ([counter 0]) - (lambda (x) - (let ([g (gensym (format "~a:~a" x counter))]) - (set! counter (fxadd1 counter)) - (make-var g #f))))) +(define (unique-var x) + (make-var (gensym x) #f)) + (define (make-bind^ lhs* rhs* body) (if (null? lhs*) @@ -623,14 +362,32 @@ (map (lambda (x) (E x env)) arg*)))] [(|#primitive|) (let ([var (cadr x)]) - (if (primitive? var) - (make-primref var) - (error 'recordize "invalid primitive ~s" var)))] + (make-primref var))] + ;;; [(|#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))]) - (cond - [(primitive? var) (make-primref var)] - [else (error 'recordize "invalid top-level var ~s" var)]))] + (if (eq? (expand-mode) 'bootstrap) + (error 'compile "reference to ~s in bootstrap mode" var) + ;(make-primref var) + (make-funcall + (make-primref 'top-level-value) + (list (make-constant var)))))] + ;;; [(top-level-value) + ;;; (let ([var (quoted-sym (cadr x))]) + ;;; (if (eq? (expand-mode) 'bootstrap) + ;;; (if (primitive? var) + ;;; (make-primref var) + ;;; (error 'compile "invalid primitive ~s" var)) + ;;; (make-funcall + ;;; (make-primref 'top-level-value) + ;;; (list (make-constant var)))))] + [(set-top-level-value!) + (make-funcall (make-primref 'set-top-level-value!) + (map (lambda (x) (E x env)) (cdr x)))] [(memv) (make-funcall (make-primref 'memq) @@ -792,6 +549,95 @@ (Expr x)) + + +(define lambda-both 0) +(define lambda-producer 0) +(define lambda-consumer 0) +(define lambda-none 0) +(define branching-producer 0) + + +(define (analyze-cwv x) + (define who 'analyze-cwv) + (define (lambda? x) + (record-case x + [(clambda) #t] + [else #f])) + (define (branching-producer? x) + (define (bt? x) + (record-case x + [(bind lhs* rhs* body) (bt? body)] + [(recbind lhs* rhs* body) (bt? body)] + [(conditional test conseq altern) #t] + [(seq e0 e1) (bt? e1)] + [else #f])) + (define (branching-clause? x) + (record-case x + [(clambda-case fml* proper body) + (bt? body)])) + (record-case x + [(clambda cls*) + (ormap branching-clause? cls*)] + [else #f])) + (define (analyze producer consumer) + (cond + [(and (lambda? producer) (lambda? consumer)) + (set! lambda-both (fxadd1 lambda-both))] + [(lambda? producer) + (set! lambda-producer (fxadd1 lambda-producer))] + [(lambda? consumer) + (set! lambda-consumer (fxadd1 lambda-consumer))] + [else + (set! lambda-none (fxadd1 lambda-none))]) + (when (branching-producer? producer) + (set! branching-producer (fxadd1 branching-producer))) + (printf "both=~s p=~s c=~s none=~s branching-prod=~s\n" + lambda-both lambda-producer lambda-consumer lambda-none + branching-producer)) + (define (E x) + (record-case x + [(constant) (void)] + [(var) (void)] + [(primref) (void)] + [(bind lhs* rhs* body) + (for-each E rhs*) (E body)] + [(recbind lhs* rhs* body) + (for-each E rhs*) (E body)] + [(conditional test conseq altern) + (E test) + (E conseq) + (E altern)] + [(seq e0 e1) (E e0) (E e1)] + [(clambda cls*) + (for-each + (lambda (x) + (record-case x + [(clambda-case fml* proper body) (E body)])) + cls*)] + [(primcall rator rand*) + (for-each E rand*) + (when (and (eq? rator 'call-with-values) (fx= (length rand*) 2)) + (analyze (car rand*) (cadr rand*)))] + [(funcall rator rand*) + (E rator) (for-each E rand*) + (when (and (record-case rator + [(primref op) (eq? op 'call-with-values)] + [else #f]) + (fx= (length rand*) 2)) + (analyze (car rand*) (cadr rand*)))] + [(appcall rator rand*) + (E rator) (for-each E rand*)] + [(forcall rator rand*) + (for-each E rand*)] + [(assign lhs rhs) + (E rhs)] + [else (error who "invalid expression ~s" (unparse x))])) + (E x)) + + + + (define (optimize-letrec x) (define who 'optimize-letrec) (define (extend-hash lhs* h ref) @@ -1089,6 +935,7 @@ + (define (convert-closures prog) (define who 'convert-closures) (define (Expr* x*) @@ -1220,6 +1067,7 @@ (let ([n (open-coded-primitive-args op)] [m (length rand*)]) (cond [(eq? n 'any) #t] + [(eq? n 'positive) (fx> m 1)] [(eq? n 'no-code) (error 'syntactically-valid "should not primcall non codable prim ~s" op)] @@ -1257,7 +1105,14 @@ [(fixnum? immediate? boolean? char? vector? string? procedure? null? pair? not cons eq? vector symbol? error eof-object eof-object? void $unbound-object? $code? $forward-ptr? bwp-object? - pointer-value) + pointer-value top-level-value car cdr list* list $record + port? input-port? output-port? + $make-port/input $make-port/output $make-port/both + $port-handler + $port-input-buffer $port-input-index $port-input-size + $port-output-buffer $port-output-index $port-output-size + $set-port-input-index! $set-port-input-size! + $set-port-output-index! $set-port-output-size! ) '#t] [($fxadd1 $fxsub1 $fxzero? $fxlognot $fxlogor $fxlogand $fx+ $fx- $fx* $fx= $fx< $fx<= $fx> $fx>= $fxquotient $fxmodulo $fxsll $fxsra $fxlogxor $exit) @@ -1291,12 +1146,17 @@ $set-symbol-unique-string! $set-symbol-string! $seal-frame-and-call $frame->continuation $code->closure - $code-size $code-reloc-vector $code-closure-size + $code-size $code-reloc-vector $code-freevars $code-ref $code-set! $make-record $record? $record/rtd? $record-rtd $record-ref $record-set! primitive-set! primitive-ref $make-tcbucket $tcbucket-key $tcbucket-val $tcbucket-next - $set-tcbucket-val! $set-tcbucket-next! $set-tcbucket-tconc!) + $tcbucket-dlink-next + $tcbucket-dlink-prev + $set-tcbucket-val! + $set-tcbucket-dlink-next! + $set-tcbucket-dlink-prev! + $set-tcbucket-next! $set-tcbucket-tconc!) #t] [else (error 'valid-arg-types? "unhandled op ~s" op)])) (and (valid-arg-count? op rand*) @@ -1309,6 +1169,24 @@ ;;; funcalls to open-codable primrefs whos arguments are "ok" are converted to ;;; primcalls. + +(define uninlined '()) +(define (mark-uninlined x) + (cond + [(assq x uninlined) => + (lambda (p) (set-cdr! p (fxadd1 (cdr p))))] + [else (set! uninlined (cons (cons x 1) uninlined))])) + +(module () + (primitive-set! 'uninlined-stats + (lambda () + (let f ([ls uninlined] [ac '()]) + (cond + [(null? ls) ac] + [(fx> (cdar ls) 15) + (f (cdr ls) (cons (car ls) ac))] + [else (f (cdr ls) ac)]))))) + (define (introduce-primcalls x) (define who 'introduce-primcalls) (define (simple? x) @@ -1345,6 +1223,8 @@ (syntactically-valid? (primref-name rator) rand*)) (Expr (make-primcall (primref-name rator) rand*))] [else + (when (primref? rator) + (mark-uninlined (primref-name rator))) (make-funcall (Expr rator) (map Expr rand*))])] [(appcall op arg*) (make-appcall (Expr op) (map Expr arg*))] @@ -1430,10 +1310,14 @@ (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*))))] + (cond + [(memq op '(not car cdr)) + (make-primcall op (map Expr arg*))] + [else + (simplify* arg* '() '() + (lambda (arg* lhs* rhs*) + (make-bind^ lhs* rhs* + (make-primcall op arg*))))])] [(forcall op arg*) (make-forcall op (map Expr arg*))] [(funcall rator rand*) @@ -1536,10 +1420,10 @@ (make-conditional (make-primcall '$ap-check-bytes (list (make-constant n) var)) - (make-funcall (make-primref 'do-overflow) + (make-forcall "ik_collect" ;(make-primref 'do-overflow) (list (make-primcall '$fx+ - (list (make-constant n) var)))) + (list (make-constant (fx+ n 4096)) var)))) (make-primcall 'void '())) body)) (define (check-words n var body) @@ -1547,10 +1431,10 @@ (make-conditional (make-primcall '$ap-check-words (list (make-constant n) var)) - (make-funcall (make-primref 'do-overflow-words) + (make-forcall "ik_collect" ; (make-primref 'do-overflow-words) (list (make-primcall '$fx+ - (list (make-constant n) var)))) + (list (make-constant (fx+ n 4096)) var)))) (make-primcall 'void '())) body)) (define (check-const n body) @@ -1558,8 +1442,8 @@ (make-conditional (make-primcall '$ap-check-const (list (make-constant n))) - (make-funcall (make-primref 'do-overflow) - (list (make-constant n))) + (make-forcall "ik_collect" ;(make-primref 'do-overflow) + (list (make-constant (fx+ n 4096)))) (make-primcall 'void '())) body)) (define (closure-size x) @@ -1596,7 +1480,8 @@ [($make-symbol) (check-const symbol-size x)] [($make-tcbucket) (check-const tcbucket-size x)] [($frame->continuation $code->closure) - (check-const (fx+ disp-closure-data (fx* (length arg*) wordsize)) x)] + (check-const + (fx+ disp-closure-data (fx* (length arg*) wordsize)) x)] [($make-string) (record-case (car arg*) [(constant i) @@ -1605,6 +1490,8 @@ (check-bytes (fxadd1 disp-string-data) (car arg*) x)])] [($string) (check-const (fx+ (length arg*) (fx+ disp-string-data 1)) x)] + [($make-port/input $make-port/output $make-port/both) + (check-const port-size x)] [($make-vector) (record-case (car arg*) [(constant i) @@ -1617,7 +1504,11 @@ (check-const (fx+ (fx* i wordsize) disp-record-data) x)] [else (check-words (fxadd1 disp-record-data) (cadr arg*) x)])] - [(vector) + [(list*) + (check-const (fx* (fxsub1 (length arg*)) pair-size) x)] + [(list) + (check-const (fx* (length arg*) pair-size) x)] + [(vector $record) (check-const (fx+ (fx* (length arg*) wordsize) disp-vector-data) x)] [else x]))] [(forcall op arg*) @@ -1661,6 +1552,7 @@ (CodesExpr x)) + (define (remove-local-variables x) (define who 'remove-local-variables) (define (simple* x* r) @@ -1681,6 +1573,10 @@ (fxlogor (vector-ref s q) (fxsll 1 r))))) r) s)) + (define (check? x) + (cond + [(primref? x) #f] ;;;; PRIMREF CHECK + [else #t])) (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]) @@ -1691,7 +1587,7 @@ (make-save-cp (make-frame-var si)) (case call-convention [(normal apply) - (make-eval-cp #t (Expr op nsi r (cons si live)))] + (make-eval-cp (check? op) (Expr op nsi r (cons si live)))] [(foreign) (make-eval-cp #f (make-foreign-label op))] [else (error who "invalid convention ~s" call-convention)])) @@ -1735,6 +1631,82 @@ (f (cdr l*) (cons v nlhs*) (fxadd1 si) (cons (cons (car l*) v) r) (cons si live)))]))) + (define (do-tail-frame-old op rand* si r call-conv live) + (define (const? x) + (record-case x + [(constant) #t] + [(primref) #t] + [else #f])) + (define (evalrand* rand* i si r live) + (cond + [(null? rand*) + (make-eval-cp (check? op) (Expr op si r live))] + [(const? (car rand*)) + (evalrand* (cdr rand*) (fxadd1 i) (fxadd1 si) r live)] + [else + (let ([v (make-frame-var si)] + [rhs (Expr (car rand*) si r live)]) + (cond + [(and (frame-var? rhs) + (fx= (frame-var-idx rhs) i)) + (evalrand* (cdr rand*) (fx+ i 1) (fx+ si 1) r (cons si live))] + [else + (make-seq + (make-assign v rhs) + (evalrand* (cdr rand*) (fx+ 1 i) (fx+ 1 si) r + (cons si live)))]))])) + (define (moverand* rand* i si ac) + (cond + [(null? rand*) ac] + [(const? (car rand*)) + (make-seq + (make-assign (make-frame-var i) (car rand*)) + (moverand* (cdr rand*) (fxadd1 i) (fxadd1 si) ac))] + [else + (make-seq + (make-assign (make-frame-var i) (make-frame-var si)) + (moverand* (cdr rand*) (fxadd1 i) (fxadd1 si) ac))])) + (make-seq + (evalrand* rand* 1 si r live) + (moverand* rand* 1 si + (make-tailcall-cp call-conv (length rand*))))) + (define (do-tail-frame op rand* si r call-conv live) + (define (const? x) + (record-case x + [(constant) #t] + [(primref) #t] + [else #f])) + (define (evalrand* rand* i si r live ac) + (cond + [(null? rand*) + (make-seq + (make-eval-cp (check? op) (Expr op si r live)) + ac)] + [(const? (car rand*)) + (evalrand* (cdr rand*) (fxadd1 i) (fxadd1 si) r live + (make-seq ac + (make-assign (make-frame-var i) (car rand*))))] + [else + (let ([vsi (make-frame-var si)] + [rhs (Expr (car rand*) si r live)]) + (cond + [(and (frame-var? rhs) + (fx= (frame-var-idx rhs) i)) + (evalrand* (cdr rand*) (fx+ i 1) (fx+ si 1) r (cons si live) ac)] + [(fx= i si) + (make-seq + (make-assign vsi rhs) + (evalrand* (cdr rand*) (fx+ i 1) (fx+ si 1) r + (cons si live) ac))] + [else + (make-seq + (make-assign vsi rhs) + (evalrand* (cdr rand*) (fxadd1 i) (fxadd1 si) r (cons si live) + (make-seq ac + (make-assign (make-frame-var i) vsi))))]))])) + (make-seq + (evalrand* rand* 1 si r live (make-primcall 'void '())) + (make-tailcall-cp call-conv (length rand*)))) (define (Tail x si r live) (record-case x [(return v) (make-return (Expr v si r live))] @@ -1749,13 +1721,18 @@ (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)))])] + (make-return + (make-primcall op + (map (lambda (x) (Expr x si r live)) arg*)))] + [(funcall op rand*) - (do-new-frame op rand* si r 'normal 'tail live)] + (do-tail-frame op rand* si r 'normal live)] [(appcall op rand*) - (do-new-frame op rand* si r 'apply 'tail live)] + (do-tail-frame op rand* si r 'apply live)] +;;; [(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 @@ -1774,7 +1751,8 @@ (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))] + (make-primcall op + (map (lambda (x) (Expr x si r live)) arg*))] [(forcall op rand*) (do-new-frame op rand* si r 'foreign 'effect live)] [(funcall op rand*) @@ -1803,7 +1781,8 @@ (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))] + (make-primcall op + (map (lambda (x) (Expr x si r live)) arg*))] [(forcall op rand*) (do-new-frame op rand* si r 'foreign 'value live)] [(funcall op rand*) @@ -1847,7 +1826,112 @@ (make-codes (map CodeExpr list) (Tail body 1 '() '()))])) (CodesExpr x)) - + + + +(define checks-elim-count 0) +(define (optimize-ap-check x) + (define who 'optimize-ap-check) + (define (min x y) + (if (fx< x y) x y)) + (define (Tail x f) + (record-case x + [(return v) + (let-values ([(v f) (NonTail v f)]) + (make-return v))] + [(fix lhs* rhs* body) + (make-fix lhs* rhs* (Tail body f))] + [(conditional test conseq altern) + (let-values ([(test f) (NonTail test f)]) + (make-conditional + test + (Tail conseq f) + (Tail altern f)))] + [(seq e0 e1) + (let-values ([(e0 f) (NonTail e0 f)]) + (make-seq e0 (Tail e1 f)))] + [(tailcall-cp) x] + [else (error who "invalid tail expression ~s" (unparse x))])) + (define (do-primcall op arg* f) + (case op + [($ap-check-const) + (let ([n (constant-value (car arg*))]) + (cond + [(fx< n f) + ;(set! checks-elim-count (fxadd1 checks-elim-count)) + ;(printf "~s checks eliminated\n" checks-elim-count) + (values (make-constant #f) (fx- f n))] + [(fx<= n 4096) + (values (make-primcall '$ap-check-const + (list (make-constant 4096))) + (fx- 4096 n))] + [else + (values (make-primcall '$ap-check-const + (list (make-constant (fx+ n 4096)))) + 4096)]))] + [($ap-check-bytes $ap-check-words) + (values (make-primcall op + (list (make-constant (fx+ (constant-value (car arg*)) + 4096)) + (cadr arg*))) + 4096)] + [else (values (make-primcall op arg*) f)])) + (define (NonTail x f) + (record-case x + [(constant) (values x f)] + [(frame-var) (values x f)] + [(cp-var) (values x f)] + [(save-cp) (values x f)] + [(foreign-label) (values x f)] + [(primref) (values x f)] + [(closure) (values x f)] + [(call-cp call-conv) + (if (eq? call-conv 'foreign) + (values x f) + (values x 0))] + [(primcall op arg*) (do-primcall op arg* f)] + [(fix lhs* rhs* body) + (let-values ([(body f) (NonTail body f)]) + (values (make-fix lhs* rhs* body) f))] + [(conditional test conseq altern) + (let-values ([(test f) (NonTail test f)]) + (if (constant? test) + (if (constant-value test) + (NonTail conseq f) + (NonTail altern f)) + (let-values ([(conseq f0) (NonTail conseq f)] + [(altern f1) (NonTail altern f)]) + (values (make-conditional test conseq altern) + (min f0 f1)))))] + [(seq e0 e1) + (let-values ([(e0 f) (NonTail e0 f)]) + (let-values ([(e1 f) (NonTail e1 f)]) + (values (make-seq e0 e1) f)))] + [(assign lhs rhs) + (let-values ([(rhs f) (NonTail rhs f)]) + (values (make-assign lhs rhs) f))] + [(eval-cp check body) + (let-values ([(body f) (NonTail body f)]) + (values (make-eval-cp check body) f))] + [(new-frame base-idx size body) + (let-values ([(body f) (NonTail body f)]) + (values (make-new-frame base-idx size body) f))] + [else (error who "invalid nontail expression ~s" (unparse x))])) + (define CaseExpr + (lambda (x) + (record-case x + [(clambda-case fml* proper body) + (make-clambda-case fml* proper (Tail body 0))]))) + (define (CodeExpr x) + (record-case x + [(clambda-code L cases free) + (make-clambda-code L (map CaseExpr cases) free)])) + (define (CodesExpr x) + (record-case x + [(codes list body) + (make-codes (map CodeExpr list) + (Tail body 0))])) + (CodesExpr x)) (begin (define fx-shift 2) @@ -1905,14 +1989,28 @@ (define code-tag #x2F) (define disp-code-instrsize 4) (define disp-code-relocsize 8) - (define disp-code-closuresize 12) + (define disp-code-freevars 12) (define disp-code-data 16) + (define port-tag #x3F) + (define input-port-tag #x7F) + (define output-port-tag #xBF) + (define input/output-port-tag #xFF) + (define port-mask #x3F) + (define disp-port-handler 4) + (define disp-port-input-buffer 8) + (define disp-port-input-index 12) + (define disp-port-input-size 16) + (define disp-port-output-buffer 20) + (define disp-port-output-index 24) + (define disp-port-output-size 28) + (define port-size 32) (define disp-tcbucket-tconc 0) (define disp-tcbucket-key 4) (define disp-tcbucket-val 8) (define disp-tcbucket-next 12) - (define tcbucket-size 16) - + (define disp-tcbucket-dlink-prev 16) + (define disp-tcbucket-dlink-next 20) + (define tcbucket-size 24) (define record-ptag 5) (define record-pmask 7) (define disp-record-rtd 0) @@ -2015,6 +2113,7 @@ (mem (fx- disp-symbol-system-value symbol-tag) (obj op))) + (define (generate-code x) (define who 'generate-code) (define (rp-label x) @@ -2141,7 +2240,8 @@ [(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)] + [(not) (Pred (car rand*) Lf Lt ac)] + ;[(not) (type-pred #f bool-f rand* Lt Lf ac)] [(eof-object?) (type-pred #f eof rand* Lt Lf ac)] [(bwp-object?) (type-pred #f bwp-object rand* Lt Lf ac)] [($code?) @@ -2159,6 +2259,15 @@ [($record?) (indirect-type-pred record-pmask record-ptag record-pmask record-ptag rand* Lt Lf ac)] + [(output-port?) + (indirect-type-pred + vector-mask vector-tag #f output-port-tag rand* Lt Lf ac)] + [(input-port?) + (indirect-type-pred + vector-mask vector-tag #f input-port-tag rand* Lt Lf ac)] + [(port?) + (indirect-type-pred + vector-mask vector-tag port-mask port-tag rand* Lt Lf ac)] [($record/rtd?) (cond [Lf @@ -2183,7 +2292,7 @@ (movl (Simple (cadr rand*)) eax) (cmpl (mem (fx- disp-record-rtd vector-tag) ebx) eax) (je Lt) - (label Ljoin) + Ljoin ac))] [else ac])] [(immediate?) @@ -2245,7 +2354,7 @@ [($ap-check-const) (record-case (car rand*) [(constant i) - (if (fx< i pagesize) + (if (fx<= i pagesize) (list* (cmpl (pcb-ref 'allocation-redline) apr) (cond-branch 'jge Lt Lf ac)) @@ -2264,7 +2373,7 @@ [($fp-overflow) (list* (cmpl (pcb-ref 'frame-redline) fpr) (cond-branch 'jle Lt Lf ac))] - [($vector-ref) + [($vector-ref top-level-value car cdr $record-ref) (do-value-prim op rand* (do-simple-test eax Lt Lf ac))] [(cons void $fxadd1 $fxsub1) @@ -2291,6 +2400,23 @@ (movl (Simple (car arg*)) eax) (movl (mem off eax) eax) ac)) + (define (do-make-port tag args ac) + (let f ([args args] [idx disp-vector-data]) + (cond + [(null? args) + (if (fx= idx port-size) + (list* + (movl (int tag) (mem 0 apr)) + (movl apr eax) + (addl (int port-size) apr) + (addl (int vector-tag) eax) + ac) + (error 'do-make-port "BUG"))] + [else + (list* + (movl (Simple (car args)) eax) + (movl eax (mem idx apr)) + (f (cdr args) (fx+ idx wordsize)))]))) (define (do-value-prim op arg* ac) (case op [(eof-object) (cons (movl (int eof) eax) ac)] @@ -2428,6 +2554,24 @@ (indirect-ref arg* (fx- disp-tcbucket-val vector-tag) ac)] [($tcbucket-next) (indirect-ref arg* (fx- disp-tcbucket-next vector-tag) ac)] + [($tcbucket-dlink-next) + (indirect-ref arg* (fx- disp-tcbucket-dlink-next vector-tag) ac)] + [($tcbucket-dlink-prev) + (indirect-ref arg* (fx- disp-tcbucket-dlink-prev vector-tag) ac)] + [($port-handler) + (indirect-ref arg* (fx- disp-port-handler vector-tag) ac)] + [($port-input-buffer) + (indirect-ref arg* (fx- disp-port-input-buffer vector-tag) ac)] + [($port-input-index) + (indirect-ref arg* (fx- disp-port-input-index vector-tag) ac)] + [($port-input-size) + (indirect-ref arg* (fx- disp-port-input-size vector-tag) ac)] + [($port-output-buffer) + (indirect-ref arg* (fx- disp-port-output-buffer vector-tag) ac)] + [($port-output-index) + (indirect-ref arg* (fx- disp-port-output-index vector-tag) ac)] + [($port-output-size) + (indirect-ref arg* (fx- disp-port-output-size vector-tag) ac)] [(pointer-value) (list* (movl (Simple (car arg*)) eax) @@ -2440,6 +2584,51 @@ (indirect-ref arg* (fx- disp-record-rtd record-ptag) ac)] [($constant-ref) (list* (movl (Simple (car arg*)) eax) ac)] + [(car cdr) + (let ([x (car arg*)]) + (NonTail x + (list* + (movl eax ebx) + (andl (int pair-mask) eax) + (cmpl (int pair-tag) eax) + (if (eq? op 'car) + (list* + (jne (label SL_car_error)) + (movl (mem (fx- disp-car pair-tag) ebx) eax) + ac) + (list* + (jne (label SL_cdr_error)) + (movl (mem (fx- disp-cdr pair-tag) ebx) eax) + ac)))))] + [(top-level-value) + (let ([x (car arg*)]) + (cond + [(constant? x) + (let ([v (constant-value x)]) + (cond + [(symbol? v) + (list* + (movl (mem (fx- disp-symbol-value symbol-tag) (obj v)) eax) + (movl (obj v) ebx) + (cmpl (int unbound) eax) + (je (label SL_top_level_value_error)) + ac)] + [else + (list* + (movl (obj v) ebx) + (jmp (label SL_top_level_value_error)) + ac)]))] + [else + (NonTail x + (list* + (movl eax ebx) + (andl (int symbol-mask) eax) + (cmpl (int symbol-tag) eax) + (jne (label SL_top_level_value_error)) + (movl (mem (fx- disp-symbol-value symbol-tag) ebx) eax) + (cmpl (int unbound) eax) + (je (label SL_top_level_value_error)) + ac))]))] [($vector-ref) (list* (movl (Simple (car arg*)) ebx) (addl (Simple (cadr arg*)) ebx) @@ -2506,6 +2695,50 @@ (addl (int pair-tag) eax) (addl (int (align pair-size)) apr) ac)] + [(list) + (cond + [(null? arg*) (NonTail (make-constant '()) ac)] + [else + (list* + (addl (int pair-tag) apr) + (movl apr eax) + (let f ([a (car arg*)] [d (cdr arg*)]) + (list* + (movl (Simple a) ebx) + (movl ebx (mem (fx- disp-car pair-tag) apr)) + (if (null? d) + (list* + (movl (int nil) (mem (fx- disp-cdr pair-tag) apr)) + (addl (int (fx- pair-size pair-tag)) apr) + ac) + (list* + (addl (int pair-size) apr) + (movl apr + (mem (fx- disp-cdr (fx+ pair-tag pair-size)) apr)) + (f (car d) (cdr d)))))))])] + [(list*) + (cond + [(fx= (length arg*) 1) (NonTail (car arg*) ac)] + [(fx= (length arg*) 2) (NonTail (make-primcall 'cons arg*) ac)] + [else + (list* + (addl (int pair-tag) apr) + (movl apr eax) + (let f ([a (car arg*)] [b (cadr arg*)] [d (cddr arg*)]) + (list* + (movl (Simple a) ebx) + (movl ebx (mem (fx- disp-car pair-tag) apr)) + (if (null? d) + (list* + (movl (Simple b) ebx) + (movl ebx (mem (fx- disp-cdr pair-tag) apr)) + (addl (int (fx- pair-size pair-tag)) apr) + ac) + (list* + (addl (int pair-size) apr) + (movl apr + (mem (fx- disp-cdr (fx+ pair-tag pair-size)) apr)) + (f b (car d) (cdr d)))))))])] [($make-symbol) (list* (movl (Simple (car arg*)) eax) (movl eax (mem disp-symbol-string apr)) @@ -2518,6 +2751,9 @@ (addl (int symbol-tag) eax) (addl (int (align symbol-size)) apr) ac)] + [($make-port/input) (do-make-port input-port-tag arg* ac)] + [($make-port/output) (do-make-port output-port-tag arg* ac)] + [($make-port/both) (do-make-port input/output-port-tag arg* ac)] [($make-tcbucket) (list* (movl (Simple (car arg*)) eax) (movl eax (mem disp-tcbucket-tconc apr)) @@ -2527,10 +2763,31 @@ (movl eax (mem disp-tcbucket-val apr)) (movl (Simple (cadddr arg*)) eax) (movl eax (mem disp-tcbucket-next apr)) + (movl (int 0) (mem disp-tcbucket-dlink-prev apr)) + (movl (int 0) (mem disp-tcbucket-dlink-next apr)) (movl apr eax) (addl (int vector-tag) eax) (addl (int (align tcbucket-size)) apr) - ac)] + ac)] + [($record) + (let ([rtd (car arg*)] + [ac + (let f ([arg* (cdr arg*)] [idx disp-record-data]) + (cond + [(null? arg*) + (list* (movl apr eax) + (addl (int vector-tag) eax) + (addl (int (align idx)) apr) + ac)] + [else + (list* (movl (Simple (car arg*)) eax) + (movl eax (mem idx apr)) + (f (cdr arg*) (fx+ idx wordsize)))]))]) + (cond + [(constant? rtd) + (list* (movl (Simple rtd) (mem 0 apr)) ac)] + [else + (list* (movl (Simple rtd) eax) (movl eax (mem 0 apr)) ac)]))] [(vector) (let f ([arg* arg*] [idx disp-vector-data]) (cond @@ -2606,19 +2863,21 @@ (indirect-ref arg* (fx- disp-code-instrsize vector-tag) ac)] [($code-reloc-vector) (indirect-ref arg* (fx- disp-code-relocsize vector-tag) ac)] - [($code-closure-size) - (indirect-ref arg* (fx- disp-code-closuresize vector-tag) ac)] + [($code-freevars) + (indirect-ref arg* (fx- disp-code-freevars vector-tag) ac)] [($set-car! $set-cdr! $vector-set! $string-set! $exit $set-symbol-value! $set-symbol-plist! $code-set! primitive-set! $set-code-object! $set-code-object+offset! $set-code-object+offset/rel! - $record-set!) + $record-set! + $set-port-input-index! $set-port-input-size! + $set-port-output-index! $set-port-output-size!) (do-effect-prim op arg* (cons (movl (int void-object) eax) ac))] [(fixnum? 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? - $record? bwp-object?) + $record? $record/rtd? bwp-object? port? input-port? output-port?) (do-pred->value-prim op arg* ac)] [($code->closure) (list* @@ -2710,9 +2969,38 @@ (indirect-assignment arg* (fx- disp-tcbucket-val vector-tag) ac)] [($set-tcbucket-next!) (indirect-assignment arg* (fx- disp-tcbucket-next vector-tag) ac)] + [($set-tcbucket-dlink-next!) + (indirect-assignment arg* (fx- disp-tcbucket-dlink-next vector-tag) ac)] + [($set-tcbucket-dlink-prev!) + (indirect-assignment arg* (fx- disp-tcbucket-dlink-prev vector-tag) ac)] [($set-tcbucket-tconc!) (indirect-assignment arg* (fx- disp-tcbucket-tconc vector-tag) ac)] - + [($set-port-input-index!) + (list* + (movl (Simple (car arg*)) eax) + (movl (Simple (cadr arg*)) ebx) + (movl ebx (mem (fx- disp-port-input-index vector-tag) eax)) + ac)] + [($set-port-input-size!) + (list* + (movl (Simple (car arg*)) eax) + (movl (Simple (cadr arg*)) ebx) + (movl (int 0) (mem (fx- disp-port-input-index vector-tag) eax)) + (movl ebx (mem (fx- disp-port-input-size vector-tag) eax)) + ac)] + [($set-port-output-index!) + (list* + (movl (Simple (car arg*)) eax) + (movl (Simple (cadr arg*)) ebx) + (movl ebx (mem (fx- disp-port-output-index vector-tag) eax)) + ac)] + [($set-port-output-size!) + (list* + (movl (Simple (car arg*)) eax) + (movl (Simple (cadr arg*)) ebx) + (movl (int 0) (mem (fx- disp-port-output-index vector-tag) eax)) + (movl ebx (mem (fx- disp-port-output-size vector-tag) eax)) + ac)] [($set-symbol-value!) (list* (movl (Simple (car arg*)) eax) (movl (Simple (cadr arg*)) ebx) @@ -2780,7 +3068,7 @@ (addl (pcb-ref 'dirty-vector) ebx) (movl (int dirty-word) (mem 0 ebx)) ac)] - [(cons void $fxadd1 $fxsub1) + [(cons void $fxadd1 $fxsub1 $record-ref) (let f ([arg* arg*]) (cond [(null? arg*) ac] @@ -3009,10 +3297,31 @@ [(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))))))] + (let* ([Ljoin (unique-label)] + [ac (cons Ljoin ac)] + [altern-ac (Effect altern ac)]) + (cond + [(eq? altern-ac ac) ;; altern is nop + (let* ([conseq-ac (Effect conseq ac)]) + (cond + [(eq? conseq-ac ac) ;; conseq is nop too! + (Effect test ac)] + [else ; "when" pattern + (Pred test #f Ljoin conseq-ac)]))] + [else + (let* ([Lf (unique-label)] + [nac (list* (jmp Ljoin) Lf altern-ac)] + [conseq-ac (Effect conseq nac)]) + (cond + [(eq? conseq-ac nac) ;; "unless" pattern" + (Pred test Ljoin #f altern-ac)] + [else + (Pred test #f Lf conseq-ac)]))]))] +;;; [(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))] [(fix lhs* rhs* body) @@ -3020,23 +3329,27 @@ [(assign loc val) (record-case loc [(frame-var i) - (NonTail val - (cons (movl eax (idx->frame-loc i)) ac))] + (record-case val + [(constant c) + (cons (movl (constant-val c) (idx->frame-loc i)) ac)] + [else + (NonTail val + (cons (movl eax (idx->frame-loc i)) ac))])] [else (error who "invalid assign loc ~s" loc)])] [(eval-cp check body) - (NonTail body - (cond - [check + (cond + [check + (NonTail body (list* - (movl eax cpr) + (movl eax cpr) (andl (int closure-mask) eax) (cmpl (int closure-tag) eax) (jne (label SL_nonprocedure)) - ac)] - [else - (list* - (movl eax cpr) - ac)]))] + ac))] + [(primref? body) + (list* (movl (primref-loc (primref-name body)) cpr) ac)] + [else + (NonTail body (list* (movl eax cpr) ac))])] [(save-cp loc) (record-case loc [(frame-var i) @@ -3060,31 +3373,40 @@ (do-fix lhs* rhs* (Tail body 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" call-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)))]))] + [(tailcall-cp call-convention argc) + (list* + (movl (int (argc-convention argc)) eax) + (case call-convention + [(normal) (tail-indirect-cpr-call)] + [(apply) (jmp (label SL_apply))] + [else + (error who "invalid tail-call convention ~s" call-convention)]) + 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" call-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)) @@ -3188,7 +3510,7 @@ (record-case x [(clambda-code L cases free) (list* - (fx+ disp-closure-data (fx* wordsize (length free))) + (length free) (label L) (handle-cases (car cases) (cdr cases)))])) (record-case x @@ -3198,6 +3520,11 @@ (define SL_nonprocedure (gensym "SL_nonprocedure")) + +(define SL_top_level_value_error (gensym "SL_top_level_value_error")) +(define SL_car_error (gensym "SL_car_error")) +(define SL_cdr_error (gensym "SL_cdr_error")) + (define SL_invalid_args (gensym "SL_invalid_args")) (define SL_foreign_call (gensym "SL_foreign_call")) (define SL_continuation_code (gensym "SL_continuation_code")) @@ -3213,11 +3540,33 @@ (module () (list*->code* (list + (list 0 + (label SL_car_error) + (movl ebx (mem (fx- 0 wordsize) fpr)) + (movl (primref-loc 'car-error) cpr) + (movl (int (argc-convention 1)) eax) + (tail-indirect-cpr-call)) + + (list 0 + (label SL_cdr_error) + (movl ebx (mem (fx- 0 wordsize) fpr)) + (movl (primref-loc 'cdr-error) cpr) + (movl (int (argc-convention 1)) eax) + (tail-indirect-cpr-call)) + + (list 0 + (label SL_top_level_value_error) + (movl ebx (mem (fx- 0 wordsize) fpr)) + (movl (primref-loc 'top-level-value-error) cpr) + (movl (int (argc-convention 1)) eax) + (tail-indirect-cpr-call)) + (let ([L_cwv_done (gensym)] [L_cwv_loop (gensym)] [L_cwv_multi_rp (gensym)] [L_cwv_call (gensym)]) - (list disp-closure-data + (list + 0 ; no free vars (label SL_call_with_values) (cmpl (int (argc-convention 2)) eax) (jne (label SL_invalid_args)) @@ -3275,7 +3624,7 @@ (let ([L_values_one_value (gensym)] [L_values_many_values (gensym)]) - (list disp-closure-data + (list 0 ; no freevars (label SL_values) (cmpl (int (argc-convention 1)) eax) (je (label L_values_one_value)) @@ -3358,8 +3707,7 @@ [L_cont_one_arg (gensym)] [L_cont_mult_move_args (gensym)] [L_cont_mult_copy_loop (gensym)]) - (list - (fx+ disp-closure-data wordsize) + (list 1 ; freevars (label SL_continuation_code) (movl (mem (fx- disp-closure-data closure-tag) cpr) ebx) ; captured-k (movl ebx (pcb-ref 'next-continuation)) ; set @@ -3403,6 +3751,7 @@ (define (compile-expr expr) (let* ([p (recordize expr)] [p (optimize-direct-calls p)] +;;; [foo (analyze-cwv p)] [p (optimize-letrec p)] ;[p (remove-letrec p)] [p (remove-assignments p)] @@ -3413,6 +3762,7 @@ [p (insert-stack-overflow-checks p)] [p (insert-allocation-checks p)] [p (remove-local-variables p)] + [p (optimize-ap-check p)] [ls* (generate-code p)] [f (when (assembler-output) (for-each diff --git a/src/libcontrol-6.0.ss b/src/libcontrol-6.0.ss deleted file mode 100644 index 44d95ca..0000000 --- a/src/libcontrol-6.0.ss +++ /dev/null @@ -1,97 +0,0 @@ - -(let ([winders '()]) - - (define call-with-current-frame - (lambda (f) - (if ($fp-at-base) - (f ($current-frame)) - ($seal-frame-and-call f)))) - - (define primitive-call/cc - (lambda (f) - (call-with-current-frame - (lambda (frm) - (f ($frame->continuation frm)))))) - - (define len - (lambda (ls n) - (if (null? ls) - n - (len (cdr ls) (fxadd1 n))))) - - (define list-tail - (lambda (ls n) - (if (fxzero? n) - ls - (list-tail (cdr ls) (fxsub1 n))))) - - (define drop-uncommon-heads - (lambda (x y) - (if (eq? x y) - x - (drop-uncommon-heads (cdr x) (cdr y))))) - - (define common-tail - (lambda (x y) - (let ([lx (len x 0)] [ly (len y 0)]) - (let ([x (if (fx> lx ly) (list-tail x (fx- lx ly)) x)] - [y (if (fx> ly lx) (list-tail y (fx- ly lx)) y)]) - (if (eq? x y) - x - (drop-uncommon-heads (cdr x) (cdr y))))))) - - (define unwind* - (lambda (ls tail) - (unless (eq? ls tail) - (set! winders (cdr ls)) - ((cdar ls)) - (unwind* (cdr ls) tail)))) - - (define rewind* - (lambda (ls tail) - (unless (eq? ls tail) - (rewind* (cdr ls) tail) - ((caar ls)) - (set! winders ls)))) - - (define do-wind - (lambda (new) - (let ([tail (common-tail new winders)]) - (unwind* winders tail) - (rewind* new tail)))) - - (define call/cc - (lambda (f) - (primitive-call/cc - (lambda (k) - (let ([save winders]) - (f (lambda v* - (unless (eq? save winders) (do-wind save)) - (apply k v*)))))))) - -;;; (define dynamic-wind -;;; (lambda (in body out) -;;; (in) -;;; (set! winders (cons (cons in out) winders)) -;;; (let ([v (body)]) -;;; (set! winders (cdr winders)) -;;; (out) -;;; v))) - - (define dynamic-wind - (lambda (in body out) - (in) - (set! winders (cons (cons in out) winders)) - (call-with-values - body - (lambda v* - (set! winders (cdr winders)) - (out) - (apply values v*))))) - - (primitive-set! 'call/cf call-with-current-frame) - (primitive-set! 'call/cc call/cc) - (primitive-set! 'dynamic-wind dynamic-wind) - ;($install-underflow-handler) - (void)) - diff --git a/src/libcontrol.fasl b/src/libcontrol.fasl index aabf1e3..32f5af5 100644 Binary files a/src/libcontrol.fasl and b/src/libcontrol.fasl differ diff --git a/src/libcore-6.0.ss b/src/libcore-6.0.ss deleted file mode 100644 index 0bb3d1c..0000000 --- a/src/libcore-6.0.ss +++ /dev/null @@ -1,1392 +0,0 @@ - -(primitive-set! 'call-with-values - ($make-call-with-values-procedure)) - -(primitive-set! 'values - ($make-values-procedure)) - -(primitive-set! 'error - (lambda args - (foreign-call "ik_error" args))) - -(primitive-set! 'exit - (lambda args - (if (null? args) - (foreign-call "exit" 0) - (if (null? ($cdr args)) - (foreign-call "exit" ($car args)) - (error 'exit "too many arguments"))))) - -(primitive-set! 'eof-object - (lambda () (eof-object))) - -(primitive-set! 'void - (lambda () (void))) - -(primitive-set! 'eof-object? - (lambda (x) (eof-object? x))) - -(primitive-set! 'fxadd1 - (lambda (n) - (unless (fixnum? n) - (error 'fxadd1 "~s is not a fixnum" n)) - ($fxadd1 n))) - -(primitive-set! 'fxsub1 - (lambda (n) - (unless (fixnum? n) - (error 'fxsub1 "~s is not a fixnum" n)) - ($fxsub1 n))) - -(primitive-set! 'integer->char - (lambda (n) - (unless (fixnum? n) - (error 'integer->char "~s is not a fixnum" n)) - (unless (and ($fx>= n 0) - ($fx<= n 255)) - (error 'integer->char "~s is out of range[0..255]" n)) - ($fixnum->char n))) - -(primitive-set! 'char->integer - (lambda (x) - (unless (char? x) - (error 'char->integer "~s is not a character" x)) - ($char->fixnum x))) - -(primitive-set! 'fxlognot - (lambda (x) - (unless (fixnum? x) - (error 'fxlognot "~s is not a fixnum" x)) - ($fxlognot x))) - -(primitive-set! 'fixnum? (lambda (x) (fixnum? x))) -(primitive-set! 'immediate? (lambda (x) (immediate? x))) - -(primitive-set! 'fxzero? - (lambda (x) - (unless (fixnum? x) - (error 'fxzero? "~s is not a fixnum" x)) - ($fxzero? x))) - -(primitive-set! 'boolean? (lambda (x) (boolean? x))) - -(primitive-set! 'char? (lambda (x) (char? x))) - -(primitive-set! 'vector? (lambda (x) (vector? x))) - -(primitive-set! 'string? (lambda (x) (string? x))) - -(primitive-set! 'procedure? (lambda (x) (procedure? x))) - -(primitive-set! 'null? (lambda (x) (null? x))) - -(primitive-set! 'pair? (lambda (x) (pair? x))) - -(let () - (define fill! - (lambda (v i n fill) - (cond - [($fx= i n) v] - [else - ($vector-set! v i fill) - (fill! v ($fx+ i 1) n fill)]))) - (primitive-set! 'make-vector - (lambda (n . opt) - (unless (and (fixnum? n) ($fx>= n 0)) - (error 'make-vector "~s is not a valid size" n)) - (let ([fill (if (null? opt) - (void) - (if (null? ($cdr opt)) - ($car opt) - (error 'make-vector "too many arguments")))]) - (let ([v ($make-vector n)]) - (fill! v 0 n fill)))))) - -(primitive-set! 'vector-length - (lambda (x) - (unless (vector? x) - (error 'vector-length "~s is not a vector" x)) - ($vector-length x))) - -(primitive-set! 'make-string - (lambda (x) - (unless (and (fixnum? x) ($fx>= x 0)) - (error 'make-string "~s is not a valid size" x)) - ($make-string x))) - -(primitive-set! 'string-length - (lambda (x) - (unless (string? x) - (error 'string-length "~s is not a string" x)) - ($string-length x))) - -(primitive-set! 'string->list - (lambda (x) - (unless (string? x) - (error 'string->list "~s is not a string" x)) - (let f ([x x] [i ($string-length x)] [ac '()]) - (cond - [($fxzero? i) ac] - [else - (let ([i ($fxsub1 i)]) - (f x i (cons ($string-ref x i) ac)))])))) - -(let () - (define bstring=? - (lambda (s1 s2 i j) - (or ($fx= i j) - (and ($char= ($string-ref s1 i) ($string-ref s2 i)) - (bstring=? s1 s2 ($fxadd1 i) j))))) - (define check-strings-and-return-false - (lambda (s*) - (cond - [(null? s*) #f] - [(string? ($car s*)) - (check-strings-and-return-false ($cdr s*))] - [else (error 'string=? "~s is not a string" ($car s*))]))) - (define strings=? - (lambda (s s* n) - (or (null? s*) - (let ([a ($car s*)]) - (unless (string? a) - (error 'string=? "~s is not a string" a)) - (if ($fx= n ($string-length a)) - (and (strings=? s ($cdr s*) n) - (bstring=? s a 0 n)) - (check-strings-and-return-false ($cdr s*))))))) - (primitive-set! 'string=? - (lambda (s . s*) - (if (string? s) - (strings=? s s* ($string-length s)) - (error 'string=? "~s is not a string" s))))) - -(let () - (define length* - (lambda (s* n) - (cond - [(null? s*) n] - [else - (let ([a ($car s*)]) - (unless (string? a) - (error 'string-append "~s is not a string" a)) - (length* ($cdr s*) ($fx+ n ($string-length a))))]))) - (define fill-string - (lambda (s a si sj ai) - (unless ($fx= si sj) - ($string-set! s si ($string-ref a ai)) - (fill-string s a ($fxadd1 si) sj ($fxadd1 ai))))) - (define fill-strings - (lambda (s s* i) - (cond - [(null? s*) s] - [else - (let ([a ($car s*)]) - (let ([n ($string-length a)]) - (let ([j ($fx+ i n)]) - (fill-string s a i j 0) - (fill-strings s ($cdr s*) j))))]))) - (primitive-set! 'string-append - (lambda s* - (let ([n (length* s* 0)]) - (let ([s ($make-string n)]) - (fill-strings s s* 0)))))) - - -(let () - (define fill - (lambda (s d si sj di) - (cond - [($fx= si sj) d] - [else - ($string-set! d di ($string-ref s si)) - (fill s d ($fxadd1 si) sj ($fxadd1 di))]))) - (primitive-set! 'substring - (lambda (s n m) - (unless (string? s) - (error 'substring "~s is not a string" s)) - (let ([len ($string-length s)]) - (unless (and (fixnum? n) - ($fx>= n 0) - ($fx< n len)) - (error 'substring "~s is not a valid start index for ~s" n s)) - (unless (and (fixnum? m) - ($fx>= m 0) - ($fx<= m len)) - (error 'substring "~s is not a valid end index for ~s" m s)) - (let ([len ($fx- m n)]) - (if ($fx<= len 0) - "" - (fill s ($make-string len) n m 0))))))) - -(primitive-set! 'not (lambda (x) (not x))) - -(primitive-set! 'symbol->string - (lambda (x) - (unless (symbol? x) - (error 'symbol->string "~s is not a symbol" x)) - (let ([str ($symbol-string x)]) - (or str - (let ([ct (gensym-count)]) - (let ([str (string-append (gensym-prefix) (fixnum->string ct))]) - ($set-symbol-string! x str) - (gensym-count ($fxadd1 ct)) - str)))))) - -(primitive-set! 'gensym? - (lambda (x) - (and (symbol? x) - (let ([s ($symbol-unique-string x)]) - (and s #t))))) - -(let () - (define f - (lambda (n i j) - (cond - [($fxzero? n) - (values (make-string i) j)] - [else - (let ([q ($fxquotient n 10)]) - (call-with-values - (lambda () (f q ($fxadd1 i) j)) - (lambda (str j) - (let ([r ($fx- n ($fx* q 10))]) - (string-set! str j - ($fixnum->char ($fx+ r ($char->fixnum #\0)))) - (values str ($fxadd1 j))))))]))) - (primitive-set! 'fixnum->string - (lambda (x) - (unless (fixnum? x) (error 'fixnum->string "~s is not a fixnum" x)) - (cond - [($fxzero? x) "0"] - [($fx> x 0) - (call-with-values - (lambda () (f x 0 0)) - (lambda (str j) str))] - [($fx= x -536870912) "-536870912"] - [else - (call-with-values - (lambda () (f ($fx- 0 x) 1 1)) - (lambda (str j) - ($string-set! str 0 #\-) - str))])))) - -(primitive-set! 'top-level-value - (lambda (x) - (unless (symbol? x) - (error 'top-level-value "~s is not a symbol" x)) - (let ([v ($symbol-value x)]) - (when ($unbound-object? v) - (error 'top-level-value "unbound variable ~s" x)) - v))) - -(primitive-set! 'top-level-bound? - (lambda (x) - (unless (symbol? x) - (error 'top-level-bound? "~s is not a symbol" x)) - (not ($unbound-object? ($symbol-value x))))) - -(primitive-set! 'set-top-level-value! - (lambda (x v) - (unless (symbol? x) - (error 'set-top-level-value! "~s is not a symbol" x)) - ($set-symbol-value! x v))) - -(primitive-set! 'symbol? (lambda (x) (symbol? x))) - -(primitive-set! 'primitive? - (lambda (x) - (unless (symbol? x) - (error 'primitive? "~s is not a symbol" x)) - (procedure? (primitive-ref x)))) - -(primitive-set! 'primitive-ref - (lambda (x) - (unless (symbol? x) - (error 'primitive-ref "~s is not a symbol" x)) - (primitive-ref x))) - - -(primitive-set! 'fx+ - (lambda (x y) - (unless (fixnum? x) - (error 'fx+ "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fx+ "~s is not a fixnum" y)) - ($fx+ x y))) - -(primitive-set! 'fx- - (lambda (x y) - (unless (fixnum? x) - (error 'fx- "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fx- "~s is not a fixnum" y)) - ($fx- x y))) - -(primitive-set! 'fx* - (lambda (x y) - (unless (fixnum? x) - (error 'fx* "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fx* "~s is not a fixnum" y)) - ($fx* x y))) - - - -(primitive-set! 'fxquotient - (lambda (x y) - (unless (fixnum? x) - (error 'fxquotient "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fxquotient "~s is not a fixnum" y)) - (when ($fxzero? y) - (error 'fxquotient "zero dividend ~s" y)) - ($fxquotient x y))) - - -(primitive-set! 'fxremainder - (lambda (x y) - (unless (fixnum? x) - (error 'fxremainder "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fxremainder "~s is not a fixnum" y)) - (when ($fxzero? y) - (error 'fxremainder "zero dividend ~s" y)) - (let ([q ($fxquotient x y)]) - ($fx- x ($fx* q y))))) - - -(primitive-set! 'fxmodulo - (lambda (x y) - (unless (fixnum? x) - (error 'fxmodulo "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fxmodulo "~s is not a fixnum" y)) - (when ($fxzero? y) - (error 'fxmodulo "zero dividend ~s" y)) - ($fxmodulo x y))) - - -(primitive-set! 'fxlogor - (lambda (x y) - (unless (fixnum? x) - (error 'fxlogor "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fxlogor "~s is not a fixnum" y)) - ($fxlogor x y))) - -(primitive-set! 'fxlogxor - (lambda (x y) - (unless (fixnum? x) - (error 'fxlogxor "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fxlogxor "~s is not a fixnum" y)) - ($fxlogxor x y))) - -(primitive-set! 'fxlogand - (lambda (x y) - (unless (fixnum? x) - (error 'fxlogand "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fxlogand "~s is not a fixnum" y)) - ($fxlogand x y))) - -(primitive-set! 'fxsra - (lambda (x y) - (unless (fixnum? x) - (error 'fxsra "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fxsra "~s is not a fixnum" y)) - (unless ($fx>= y 0) - (error 'fxsra "negative shift not allowed, got ~s" y)) - ($fxsra x y))) - -(primitive-set! 'fxsll - (lambda (x y) - (unless (fixnum? x) - (error 'fxsll "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fxsll "~s is not a fixnum" y)) - (unless ($fx>= y 0) - (error 'fxsll "negative shift not allowed, got ~s" y)) - ($fxsll x y))) - -(primitive-set! 'fx= - (lambda (x y) - (unless (fixnum? x) - (error 'fx= "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fx= "~s is not a fixnum" y)) - ($fx= x y))) - -(primitive-set! 'fx< - (lambda (x y) - (unless (fixnum? x) - (error 'fx< "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fx< "~s is not a fixnum" y)) - ($fx< x y))) - -(primitive-set! 'fx<= - (lambda (x y) - (unless (fixnum? x) - (error 'fx<= "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fx<= "~s is not a fixnum" y)) - ($fx<= x y))) - -(primitive-set! 'fx> - (lambda (x y) - (unless (fixnum? x) - (error 'fx> "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fx> "~s is not a fixnum" y)) - ($fx> x y))) - -(primitive-set! 'fx>= - (lambda (x y) - (unless (fixnum? x) - (error 'fx>= "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fx>= "~s is not a fixnum" y)) - ($fx>= x y))) - -(primitive-set! 'char= - (lambda (x y) - (unless (char? x) - (error 'char= "~s is not a character" x)) - (unless (char? y) - (error 'char= "~s is not a character" y)) - ($char= x y))) - -(primitive-set! 'char< - (lambda (x y) - (unless (char? x) - (error 'char< "~s is not a character" x)) - (unless (char? y) - (error 'char< "~s is not a character" y)) - ($char< x y))) - -(primitive-set! 'char<= - (lambda (x y) - (unless (char? x) - (error 'char<= "~s is not a character" x)) - (unless (char? y) - (error 'char<= "~s is not a character" y)) - ($char<= x y))) - -(primitive-set! 'char> - (lambda (x y) - (unless (char? x) - (error 'char> "~s is not a character" x)) - (unless (char? y) - (error 'char> "~s is not a character" y)) - ($char> x y))) - -(primitive-set! 'char>= - (lambda (x y) - (unless (char? x) - (error 'char>= "~s is not a character" x)) - (unless (char? y) - (error 'char>= "~s is not a character" y)) - ($char>= x y))) - -(primitive-set! 'cons (lambda (x y) (cons x y))) - -(primitive-set! 'eq? (lambda (x y) (eq? x y))) - -(primitive-set! 'set-car! - (lambda (x y) - (unless (pair? x) - (error 'set-car! "~s is not a pair" x)) - ($set-car! x y))) - -(primitive-set! 'set-cdr! - (lambda (x y) - (unless (pair? x) - (error 'set-cdr! "~s is not a pair" x)) - ($set-cdr! x y))) - -(primitive-set! 'vector-ref - (lambda (v i) - (unless (vector? v) - (error 'vector-ref "~s is not a vector" v)) - (unless (fixnum? i) - (error 'vector-ref "~s is not a valid index" i)) - (unless (and ($fx< i ($vector-length v)) - ($fx<= 0 i)) - (error 'vector-ref "index ~s is out of range for ~s" i v)) - ($vector-ref v i))) - -(primitive-set! 'string-ref - (lambda (s i) - (unless (string? s) - (error 'string-ref "~s is not a string" s)) - (unless (fixnum? i) - (error 'string-ref "~s is not a valid index" i)) - (unless (and ($fx< i ($string-length s)) - ($fx<= 0 i)) - (error 'string-ref "index ~s is out of range for ~s" i s)) - ($string-ref s i))) - -(primitive-set! 'vector-set! - (lambda (v i c) - (unless (vector? v) - (error 'vector-set! "~s is not a vector" v)) - (unless (fixnum? i) - (error 'vector-set! "~s is not a valid index" i)) - (unless (and ($fx< i ($vector-length v)) - ($fx<= 0 i)) - (error 'vector-set! "index ~s is out of range for ~s" i v)) - ($vector-set! v i c))) - - -(primitive-set! 'string-set! - (lambda (s i c) - (unless (string? s) - (error 'string-set! "~s is not a string" s)) - (unless (fixnum? i) - (error 'string-set! "~s is not a valid index" i)) - (unless (and ($fx< i ($string-length s)) - ($fx>= i 0)) - (error 'string-set! "index ~s is out of range for ~s" i s)) - (unless (char? c) - (error 'string-set! "~s is not a character" c)) - ($string-set! s i c))) - -(primitive-set! 'vector - (letrec ([length - (lambda (ls n) - (cond - [(null? ls) n] - [else (length ($cdr ls) ($fx+ n 1))]))] - [loop - (lambda (v ls i n) - (cond - [($fx= i n) v] - [else - ($vector-set! v i ($car ls)) - (loop v ($cdr ls) ($fx+ i 1) n)]))]) - (lambda ls - (let ([n (length ls 0)]) - (let ([v (make-vector n)]) - (loop v ls 0 n)))))) - -(letrec ([length - (lambda (ls n) - (cond - [(null? ls) n] - [else (length ($cdr ls) ($fx+ n 1))]))] - [loop - (lambda (s ls i n) - (cond - [($fx= i n) s] - [else - (let ([c ($car ls)]) - (unless (char? c) - (error 'string "~s is not a character" c)) - ($string-set! s i c) - (loop s ($cdr ls) ($fx+ i 1) n))]))]) - (let ([f - (lambda ls - (let ([n (length ls 0)]) - (let ([s ($make-string n)]) - (loop s ls 0 n))))]) - (primitive-set! 'string f))) - -(primitive-set! 'list? - (letrec ([race - (lambda (h t) - (if (pair? h) - (let ([h ($cdr h)]) - (if (pair? h) - (and (not (eq? h t)) - (race ($cdr h) ($cdr t))) - (null? h))) - (null? h)))]) - (lambda (x) (race x x)))) - - - -(primitive-set! 'reverse - (letrec ([race - (lambda (h t ls ac) - (if (pair? h) - (let ([h ($cdr h)] [ac (cons ($car h) ac)]) - (if (pair? h) - (if (not (eq? h t)) - (race ($cdr h) ($cdr t) ls (cons ($car h) ac)) - (error 'reverse "~s is a circular list" ls)) - (if (null? h) - ac - (error 'reverse "~s is not a proper list" ls)))) - (if (null? h) - ac - (error 'reverse "~s is not a proper list" ls))))]) - (lambda (x) - (race x x x '())))) - -(primitive-set! 'memq - (letrec ([race - (lambda (h t ls x) - (if (pair? h) - (if (eq? ($car h) x) - h - (let ([h ($cdr h)]) - (if (pair? h) - (if (eq? ($car h) x) - h - (if (not (eq? h t)) - (race ($cdr h) ($cdr t) ls x) - (error 'memq "circular list ~s" ls))) - (if (null? h) - '#f - (error 'memq "~s is not a proper list" ls))))) - (if (null? h) - '#f - (error 'memq "~s is not a proper list" ls))))]) - (lambda (x ls) - (race ls ls ls x)))) - -(primitive-set! 'list->string - (letrec ([race - (lambda (h t ls n) - (if (pair? h) - (let ([h ($cdr h)]) - (if (pair? h) - (if (not (eq? h t)) - (race ($cdr h) ($cdr t) ls ($fx+ n 2)) - (error 'reverse "circular list ~s" ls)) - (if (null? h) - ($fx+ n 1) - (error 'reverse "~s is not a proper list" ls)))) - (if (null? h) - n - (error 'reverse "~s is not a proper list" ls))))] - [fill - (lambda (s i ls) - (cond - [(null? ls) s] - [else - (let ([c ($car ls)]) - (unless (char? c) - (error 'list->string "~s is not a character" c)) - ($string-set! s i c) - (fill s ($fxadd1 i) (cdr ls)))]))]) - (lambda (ls) - (let ([n (race ls ls ls 0)]) - (let ([s ($make-string n)]) - (fill s 0 ls)))))) - -(primitive-set! 'length - (letrec ([race - (lambda (h t ls n) - (if (pair? h) - (let ([h ($cdr h)]) - (if (pair? h) - (if (not (eq? h t)) - (race ($cdr h) ($cdr t) ls ($fx+ n 2)) - (error 'length "circular list ~s" ls)) - (if (null? h) - ($fx+ n 1) - (error 'length "~s is not a proper list" ls)))) - (if (null? h) - n - (error 'length "~s is not a proper list" ls))))]) - (lambda (ls) - (race ls ls ls 0)))) - - -(primitive-set! 'list-ref - (lambda (list index) - (define f - (lambda (ls i) - (cond - [($fxzero? i) - (if (pair? ls) - ($car ls) - (error 'list-ref "index ~s is out of range for ~s" index list))] - [(pair? ls) - (f ($cdr ls) ($fxsub1 i))] - [(null? ls) - (error 'list-rec "index ~s is out of range for ~s" index list)] - [else (error 'list-ref "~s is not a list" list)]))) - (unless (and (fixnum? index) ($fx>= index 0)) - (error 'list-ref "~s is not a valid index" index)) - (f list index))) - - - -;(primitive-set! 'apply -; (letrec ([fix -; (lambda (arg arg*) -; (cond -; [(null? arg*) -; (if (list? arg) -; arg -; (error 'apply "last arg is not a list"))] -; [else -; (cons arg (fix ($car arg*) ($cdr arg*)))]))]) -; (lambda (f arg . arg*) -; (unless (procedure? f) -; (error 'apply "APPLY ~s ~s ~s" f arg arg*)) -; ($apply f (fix arg arg*))))) -; - -(primitive-set! 'apply - (letrec ([fix - (lambda (arg arg*) - (cond - [(null? arg*) - (if (list? arg) - arg - (error 'apply "last arg is not a list"))] - [else - (cons arg (fix ($car arg*) ($cdr arg*)))]))]) - (lambda (f arg . arg*) - (unless (procedure? f) - (error 'apply "APPLY ~s ~s ~s" f arg arg*)) - (let ([args (fix arg arg*)]) - ($apply f args))))) - - -(primitive-set! 'assq - (letrec ([race - (lambda (x h t ls) - (if (pair? h) - (let ([a ($car h)] [h ($cdr h)]) - (if (pair? a) - (if (eq? ($car a) x) - a - (if (pair? h) - (if (not (eq? h t)) - (let ([a ($car h)]) - (if (pair? a) - (if (eq? ($car a) x) - a - (race x ($cdr h) ($cdr t) ls)) - (error 'assq "malformed alist ~s" - ls))) - (error 'assq "circular list ~s" ls)) - (if (null? h) - #f - (error 'assq "~s is not a proper list" ls)))) - (error 'assq "malformed alist ~s" ls))) - (if (null? h) - #f - (error 'assq "~s is not a proper list" ls))))]) - (lambda (x ls) - (race x ls ls ls)))) - -(primitive-set! 'string->symbol - (lambda (x) - (unless (string? x) - (error 'string->symbol "~s is not a string" x)) - (foreign-call "ik_intern_string" x))) - -(primitive-set! 'oblist - (lambda () - (foreign-call "ik_oblist"))) - -(primitive-set! 'gensym - (lambda args - (if (null? args) - ($make-symbol #f) - (if (null? ($cdr args)) - (let ([a ($car args)]) - (if (string? a) - ($make-symbol a) - (error 'gensym "~s is not a string" a))) - (error 'gensym "too many arguments"))))) - -(primitive-set! 'putprop - (lambda (x k v) - (unless (symbol? x) (error 'putprop "~s is not a symbol" x)) - (unless (symbol? k) (error 'putprop "~s is not a symbol" k)) - (let ([p ($symbol-plist x)]) - (cond - [(assq k p) => (lambda (x) (set-cdr! x v))] - [else - ($set-symbol-plist! x (cons (cons k v) p))])))) - -(primitive-set! 'getprop - (lambda (x k) - (unless (symbol? x) (error 'getprop "~s is not a symbol" x)) - (unless (symbol? k) (error 'getprop "~s is not a symbol" k)) - (let ([p ($symbol-plist x)]) - (cond - [(assq k p) => cdr] - [else #f])))) - -(primitive-set! 'remprop - (lambda (x k) - (unless (symbol? x) (error 'remprop "~s is not a symbol" x)) - (unless (symbol? k) (error 'remprop "~s is not a symbol" k)) - (let ([p ($symbol-plist x)]) - (unless (null? p) - (let ([a ($car p)]) - (cond - [(eq? ($car a) k) ($set-symbol-plist! x ($cdr p))] - [else - (let f ([q p] [p ($cdr p)]) - (unless (null? p) - (let ([a ($car p)]) - (cond - [(eq? ($car a) k) - ($set-cdr! q ($cdr p))] - [else - (f p ($cdr p))]))))])))))) - -(primitive-set! 'property-list - (lambda (x) - (unless (symbol? x) - (error 'property-list "~s is not a symbol" x)) - (letrec ([f - (lambda (ls ac) - (cond - [(null? ls) ac] - [else - (let ([a ($car ls)]) - (f ($cdr ls) - (cons ($car a) (cons ($cdr a) ac))))]))]) - (f ($symbol-plist x) '())))) - - -(primitive-set! 'make-parameter - (letrec ([make-param-no-guard - (lambda (x) - (lambda args - (if (null? args) - x - (if (null? ($cdr args)) - (set! x ($car args)) - (error #f "too many arguments to parameter")))))] - [make-param-with-guard - (lambda (x g) - (let ([f - (lambda args - (if (null? args) - x - (if (null? ($cdr args)) - (set! x (g ($car args))) - (error #f "too many arguments to parameter"))))]) - (if (procedure? g) - (begin (set! x (g x)) f) - (error 'make-parameter "not a procedure ~s" g))))]) - (lambda args - (if (pair? args) - (let ([x ($car args)] [args ($cdr args)]) - (if (null? args) - (make-param-no-guard x) - (let ([g ($car args)]) - (if (null? ($cdr args)) - (make-param-with-guard x g) - (error 'make-parameter "too many arguments"))))) - (error 'make-parameter "insufficient arguments"))))) - -(let () - (define vector-loop - (lambda (x y i n) - (or ($fx= i n) - (and (equal? ($vector-ref x i) ($vector-ref y i)) - (vector-loop x y ($fxadd1 i) n))))) - (define string-loop - (lambda (x y i n) - (or ($fx= i n) - (and ($char= ($string-ref x i) ($string-ref y i)) - (string-loop x y ($fxadd1 i) n))))) - (define equal? - (lambda (x y) - (cond - [(eq? x y) #t] - [(pair? x) - (and (pair? y) - (equal? ($car x) ($car y)) - (equal? ($cdr x) ($cdr y)))] - [(vector? x) - (and (vector? y) - (let ([n ($vector-length x)]) - (and ($fx= n ($vector-length y)) - (vector-loop x y 0 n))))] - [(string? x) - (and (string? y) - (let ([n ($string-length x)]) - (and ($fx= n ($string-length y)) - (string-loop x y 0 n))))] - [else #f]))) - (primitive-set! 'equal? equal?)) - - -(let () - (define who 'map) - (define len - (lambda (h t n) - (if (pair? h) - (let ([h ($cdr h)]) - (if (pair? h) - (if (eq? h t) - (error who "circular list") - (len ($cdr h) ($cdr t) ($fx+ n 2))) - (if (null? h) - ($fxadd1 n) - (error who "improper list")))) - (if (null? h) - n - (error who "improper list"))))) - - (define map1 - (lambda (f a d n) - (cond - [(pair? d) - (if ($fxzero? n) - (error who "list was altered!") - (cons (f a) - (map1 f ($car d) ($cdr d) ($fxsub1 n))))] - [(null? d) - (if ($fxzero? n) - (cons (f a) '()) - (error who "list was altered"))] - [else (error who "list was altered")]))) - - (define map2 - (lambda (f a1 a2 d1 d2 n) - (cond - [(pair? d1) - (cond - [(pair? d2) - (if ($fxzero? n) - (error who "list was altered") - (cons (f a1 a2) - (map2 f - ($car d1) ($car d2) - ($cdr d1) ($cdr d2) - ($fxsub1 n))))] - [else (error who "length mismatch")])] - [(null? d1) - (cond - [(null? d2) - (if ($fxzero? n) - (cons (f a1 a2) '()) - (error who "list was altered"))] - [else (error who "length mismatch")])] - [else (error who "list was altered")]))) - - (define cars - (lambda (ls*) - (cond - [(null? ls*) '()] - [else - (let ([a (car ls*)]) - (cond - [(pair? a) - (cons (car a) (cars (cdr ls*)))] - [else - (error 'map "length mismatch")]))]))) - (define cdrs - (lambda (ls*) - (cond - [(null? ls*) '()] - [else - (let ([a (car ls*)]) - (cond - [(pair? a) - (cons (cdr a) (cdrs (cdr ls*)))] - [else - (error 'map "length mismatch")]))]))) - (define mapm - (lambda (f ls ls* n) - (cond - [(null? ls) - (if (andmap null? ls*) - (if (fxzero? n) - '() - (error 'map "lists were mutated during operation")) - (error 'map "length mismatch"))] - [(fxzero? n) - (error 'map "lists were mutated during operation")] - [else - (cons - (apply f (car ls) (cars ls*)) - (mapm f (cdr ls) (cdrs ls*) (fxsub1 n)))]))) - - (define dup - (lambda (ls ac) - (cond - [(null? ls) ac] - [else (dup (cdr ls) (cons '() ac))]))) - (primitive-set! 'map - (lambda (f ls . ls*) - (unless (procedure? f) - (error who "~s is not a procedure" f)) - (cond - [(null? ls*) - (cond - [(pair? ls) - (let ([d ($cdr ls)]) - (map1 f ($car ls) d (len d d 0)))] - [(null? ls) '()] - [else (error who "improper list")])] - [(null? ($cdr ls*)) - (let ([ls2 ($car ls*)]) - (cond - [(pair? ls) - (if (pair? ls2) - (let ([d ($cdr ls)]) - (map2 f ($car ls) ($car ls2) d ($cdr ls2) (len d d 0))) - (error who "length mismatch"))] - [(null? ls) - (if (null? ls2) - '() - (error who "length mismatch"))] - [else (error who "not a list")]))] - [else - (cond - [(pair? ls) - (let ([n (len ls ls 0)]) - (mapm f ls ls* n))] - [(null? ls) - (if (andmap null? ls*) - '() - (error who "length mismatch"))])])))) - -(let () - (define who 'for-each) - (define len - (lambda (h t n) - (if (pair? h) - (let ([h ($cdr h)]) - (if (pair? h) - (if (eq? h t) - (error who "circular list") - (len ($cdr h) ($cdr t) ($fx+ n 2))) - (if (null? h) - ($fxadd1 n) - (error who "improper list")))) - (if (null? h) - n - (error who "improper list"))))) - - (define for-each1 - (lambda (f a d n) - (cond - [(pair? d) - (if ($fxzero? n) - (error who "list was altered!") - (begin - (f a) - (for-each1 f ($car d) ($cdr d) ($fxsub1 n))))] - [(null? d) - (if ($fxzero? n) - (f a) - (error who "list was altered"))] - [else (error who "list was altered")]))) - - (define for-each2 - (lambda (f a1 a2 d1 d2 n) - (cond - [(pair? d1) - (cond - [(pair? d2) - (if ($fxzero? n) - (error who "list was altered") - (begin - (f a1 a2) - (for-each2 f - ($car d1) ($car d2) - ($cdr d1) ($cdr d2) - ($fxsub1 n))))] - [else (error who "length mismatch")])] - [(null? d1) - (cond - [(null? d2) - (if ($fxzero? n) - (f a1 a2) - (error who "list was altered"))] - [else (error who "length mismatch")])] - [else (error who "list was altered")]))) - - (primitive-set! 'for-each - (lambda (f ls . ls*) - (unless (procedure? f) - (error who "~s is not a procedure" f)) - (cond - [(null? ls*) - (cond - [(pair? ls) - (let ([d ($cdr ls)]) - (for-each1 f ($car ls) d (len d d 0)))] - [(null? ls) (void)] - [else (error who "improper list")])] - [(null? ($cdr ls*)) - (let ([ls2 ($car ls*)]) - (cond - [(pair? ls) - (if (pair? ls2) - (let ([d ($cdr ls)]) - (for-each2 f - ($car ls) ($car ls2) d ($cdr ls2) (len d d 0))) - (error who "length mismatch"))] - [(null? ls) - (if (null? ls2) - (void) - (error who "length mismatch"))] - [else (error who "not a list")]))] - [else (error who "vararg not supported yet")])))) - - - -(let () - (define who 'andmap) - (define len - (lambda (h t n) - (if (pair? h) - (let ([h ($cdr h)]) - (if (pair? h) - (if (eq? h t) - (error who "circular list") - (len ($cdr h) ($cdr t) ($fx+ n 2))) - (if (null? h) - ($fxadd1 n) - (error who "improper list")))) - (if (null? h) - n - (error who "improper list"))))) - - (define andmap1 - (lambda (f a d n) - (cond - [(pair? d) - (if ($fxzero? n) - (error who "list was altered!") - (and (f a) - (andmap1 f ($car d) ($cdr d) ($fxsub1 n))))] - [(null? d) - (if ($fxzero? n) - (f a) - (error who "list was altered"))] - [else (error who "list was altered")]))) - - (primitive-set! 'andmap - (lambda (f ls . ls*) - (unless (procedure? f) - (error who "~s is not a procedure" f)) - (cond - [(null? ls*) - (cond - [(pair? ls) - (let ([d ($cdr ls)]) - (andmap1 f ($car ls) d (len d d 0)))] - [(null? ls) #t] - [else (error who "improper list")])] - [else (error who "vararg not supported yet")])))) - - -(let () - (define who 'ormap) - (define len - (lambda (h t n) - (if (pair? h) - (let ([h ($cdr h)]) - (if (pair? h) - (if (eq? h t) - (error who "circular list") - (len ($cdr h) ($cdr t) ($fx+ n 2))) - (if (null? h) - ($fxadd1 n) - (error who "improper list")))) - (if (null? h) - n - (error who "improper list"))))) - - (define ormap1 - (lambda (f a d n) - (cond - [(pair? d) - (if ($fxzero? n) - (error who "list was altered!") - (or (f a) - (ormap1 f ($car d) ($cdr d) ($fxsub1 n))))] - [(null? d) - (if ($fxzero? n) - (f a) - (error who "list was altered"))] - [else (error who "list was altered")]))) - - (primitive-set! 'ormap - (lambda (f ls . ls*) - (unless (procedure? f) - (error who "~s is not a procedure" f)) - (cond - [(null? ls*) - (cond - [(pair? ls) - (let ([d ($cdr ls)]) - (ormap1 f ($car ls) d (len d d 0)))] - [(null? ls) #f] - [else (error who "improper list")])] - [else (error who "vararg not supported yet")])))) - - - - -(let () - (define reverse - (lambda (h t ls ac) - (if (pair? h) - (let ([h ($cdr h)] [a1 ($car h)]) - (if (pair? h) - (if (not (eq? h t)) - (let ([a2 ($car h)]) - (reverse ($cdr h) ($cdr t) ls (cons a2 (cons a1 ac)))) - (error 'append "circular list ~s" ls)) - (if (null? h) - (cons a1 ac) - (error 'append "~s is not a proper list" ls)))) - (if (null? h) - ac - (error 'append "~s is not a proper list" ls))))) - (define revcons - (lambda (ls ac) - (cond - [(null? ls) ac] - [else - (revcons ($cdr ls) (cons ($car ls) ac))]))) - (define append - (lambda (ls ls*) - (cond - [(null? ls*) ls] - [else - (revcons (reverse ls ls ls '()) - (append ($car ls*) ($cdr ls*)))]))) - (primitive-set! 'append - (lambda (ls . ls*) - (append ls ls*)))) - - -(primitive-set! 'list->vector - (letrec ([race - (lambda (h t ls n) - (if (pair? h) - (let ([h ($cdr h)]) - (if (pair? h) - (if (not (eq? h t)) - (race ($cdr h) ($cdr t) ls ($fx+ n 2)) - (error 'list->vector "circular list ~s" ls)) - (if (null? h) - ($fx+ n 1) - (error 'list->vector "~s is not a proper list" ls)))) - (if (null? h) - n - (error 'list->vector "~s is not a proper list" ls))))] - [fill - (lambda (v i ls) - (cond - [(null? ls) v] - [else - (let ([c ($car ls)]) - ($vector-set! v i c) - (fill v ($fxadd1 i) (cdr ls)))]))]) - (lambda (ls) - (let ([n (race ls ls ls 0)]) - (let ([v (make-vector n)]) - (fill v 0 ls)))))) - - -(let () - (define f - (lambda (v i ls) - (cond - [($fx< i 0) ls] - [else - (f v ($fxsub1 i) (cons ($vector-ref v i) ls))]))) - (primitive-set! 'vector->list - (lambda (v) - (if (vector? v) - (let ([n ($vector-length v)]) - (if ($fxzero? n) - '() - (f v ($fxsub1 n) '()))) - (error 'vector->list "~s is not a vector" v))))) - -(let () - (define f - (lambda (n fill ls) - (cond - [($fxzero? n) ls] - [else - (f ($fxsub1 n) fill (cons fill ls))]))) - (primitive-set! 'make-list - (lambda (n . args) - (let ([fill - (if (null? args) - (void) - (if (null? (cdr args)) - (car args) - (error 'make-list "too many arguments")))]) - (if (fixnum? n) - (if ($fx>= n 0) - (f n fill '()) - (error 'make-list "negative size ~s" n)) - (error 'make-list "invalid size ~s" n)))))) - -(primitive-set! 'list (lambda x x)) - -(primitive-set! 'uuid - (lambda () - (let ([s (make-string 36)]) - (foreign-call "ik_uuid" s)))) - -(primitive-set! 'gensym->unique-string - (lambda (x) - (unless (symbol? x) - (error 'gensym->unique-string "~s is not a gensym" x)) - (let ([us ($symbol-unique-string x)]) - (cond - [(string? us) us] - [(eq? us #t) - (error 'gensym->unique-string "~s is not a gensym" x)] - [else - (let ([id (uuid)]) - ($set-symbol-unique-string! x id) - id)])))) - -(primitive-set! 'gensym-prefix - (make-parameter - "g" - (lambda (x) - (unless (string? x) - (error 'gensym-prefix "~s is not a string" x)) - x))) - -(primitive-set! 'gensym-count - (make-parameter - 0 - (lambda (x) - (unless (and (fixnum? x) ($fx>= x 0)) - (error 'gensym-count "~s is not a valid count" x)) - x))) - -(primitive-set! 'print-gensym - (make-parameter - #t - (lambda (x) - (unless (boolean? x) - (error 'print-gensym "~s is not a boolean" x)) - x))) - - -(primitive-set! 'make-hash-table - (lambda () - (make-hash-table))) - -(primitive-set! 'hash-table? - (lambda (x) - (hash-table? x))) - -(primitive-set! 'get-hash-table - (lambda (h k v) - (foreign-call "ik_get_hash_table" h k v))) - -(primitive-set! 'put-hash-table! - (lambda (h k v) - (foreign-call "ik_put_hash_table" h k v))) - diff --git a/src/libcore-6.1.ss b/src/libcore-6.1.ss deleted file mode 100644 index bed6703..0000000 --- a/src/libcore-6.1.ss +++ /dev/null @@ -1,1596 +0,0 @@ - -;;; 6.1: added uses of case-lambda to replace the ugly code -;;; 6.0: basic version working - - -(primitive-set! 'call-with-values - ($make-call-with-values-procedure)) - -(primitive-set! 'values - ($make-values-procedure)) - -(primitive-set! 'exit - (case-lambda - [() (exit 0)] - [(status) (foreign-call "exit" status)])) - -(primitive-set! 'eof-object - (lambda () (eof-object))) - -(primitive-set! 'void - (lambda () (void))) - -(primitive-set! 'eof-object? - (lambda (x) (eof-object? x))) - -(primitive-set! 'fxadd1 - (lambda (n) - (unless (fixnum? n) - (error 'fxadd1 "~s is not a fixnum" n)) - ($fxadd1 n))) - -(primitive-set! 'fxsub1 - (lambda (n) - (unless (fixnum? n) - (error 'fxsub1 "~s is not a fixnum" n)) - ($fxsub1 n))) - -(primitive-set! 'integer->char - (lambda (n) - (unless (fixnum? n) - (error 'integer->char "~s is not a fixnum" n)) - (unless (and ($fx>= n 0) - ($fx<= n 255)) - (error 'integer->char "~s is out of range[0..255]" n)) - ($fixnum->char n))) - -(primitive-set! 'char->integer - (lambda (x) - (unless (char? x) - (error 'char->integer "~s is not a character" x)) - ($char->fixnum x))) - -(primitive-set! 'fxlognot - (lambda (x) - (unless (fixnum? x) - (error 'fxlognot "~s is not a fixnum" x)) - ($fxlognot x))) - -(primitive-set! 'fixnum? (lambda (x) (fixnum? x))) -(primitive-set! 'immediate? (lambda (x) (immediate? x))) - -(primitive-set! 'fxzero? - (lambda (x) - (unless (fixnum? x) - (error 'fxzero? "~s is not a fixnum" x)) - ($fxzero? x))) - -(primitive-set! 'boolean? (lambda (x) (boolean? x))) - -(primitive-set! 'char? (lambda (x) (char? x))) - -(primitive-set! 'vector? (lambda (x) (vector? x))) - -(primitive-set! 'string? (lambda (x) (string? x))) - -(primitive-set! 'procedure? (lambda (x) (procedure? x))) - -(primitive-set! 'null? (lambda (x) (null? x))) - -(primitive-set! 'pair? (lambda (x) (pair? x))) - -(let () - (define fill! - (lambda (v i n fill) - (cond - [($fx= i n) v] - [else - ($vector-set! v i fill) - (fill! v ($fx+ i 1) n fill)]))) - (define make-vector - (case-lambda - [(n) (make-vector n (void))] - [(n fill) - (unless (and (fixnum? n) (fx>= n 0)) - (error 'make-vector "~s is not a valid length" n)) - (fill! ($make-vector n) 0 n fill)])) - (primitive-set! 'make-vector make-vector)) - -(primitive-set! 'vector-length - (lambda (x) - (unless (vector? x) - (error 'vector-length "~s is not a vector" x)) - ($vector-length x))) - -(let () - (define fill! - (lambda (s i n c) - (cond - [($fx= i n) s] - [else - ($string-set! s i c) - (fill! s ($fx+ i 1) n c)]))) - (define make-string - (case-lambda - [(n) - (unless (and (fixnum? n) (fx>= n 0)) - (error 'make-string "~s is not a valid length" n)) - ($make-string n)] - [(n c) - (unless (and (fixnum? n) (fx>= n 0)) - (error 'make-string "~s is not a valid length" n)) - (unless (char? c) - (error 'make-string "~s is not a character" c)) - (fill! ($make-string n) 0 n c)])) - (primitive-set! 'make-string make-string)) - - -(primitive-set! 'string-length - (lambda (x) - (unless (string? x) - (error 'string-length "~s is not a string" x)) - ($string-length x))) - -(primitive-set! 'string->list - (lambda (x) - (unless (string? x) - (error 'string->list "~s is not a string" x)) - (let f ([x x] [i ($string-length x)] [ac '()]) - (cond - [($fxzero? i) ac] - [else - (let ([i ($fxsub1 i)]) - (f x i (cons ($string-ref x i) ac)))])))) - - -(let () - (define bstring=? - (lambda (s1 s2 i j) - (or ($fx= i j) - (and ($char= ($string-ref s1 i) ($string-ref s2 i)) - (bstring=? s1 s2 ($fxadd1 i) j))))) - (define check-strings-and-return-false - (lambda (s*) - (cond - [(null? s*) #f] - [(string? ($car s*)) - (check-strings-and-return-false ($cdr s*))] - [else (err ($car s*))]))) - (define strings=? - (lambda (s s* n) - (or (null? s*) - (let ([a ($car s*)]) - (unless (string? a) - (error 'string=? "~s is not a string" a)) - (if ($fx= n ($string-length a)) - (and (strings=? s ($cdr s*) n) - (bstring=? s a 0 n)) - (check-strings-and-return-false ($cdr s*))))))) - (define (err x) - (error 'string=? "~s is not a string" x)) - (primitive-set! 'string=? - (case-lambda - [(s s1) - (if (string? s) - (if (string? s1) - (let ([n ($string-length s)]) - (and ($fx= n ($string-length s1)) - (bstring=? s s1 0 n))) - (err s1)) - (err s))] - [(s . s*) - (if (string? s) - (strings=? s s* ($string-length s)) - (err s))]))) - - - -(let () - ;; FIXME: make nonconsing on 0,1,2, and 3 args - (define length* - (lambda (s* n) - (cond - [(null? s*) n] - [else - (let ([a ($car s*)]) - (unless (string? a) - (error 'string-append "~s is not a string" a)) - (length* ($cdr s*) ($fx+ n ($string-length a))))]))) - (define fill-string - (lambda (s a si sj ai) - (unless ($fx= si sj) - ($string-set! s si ($string-ref a ai)) - (fill-string s a ($fxadd1 si) sj ($fxadd1 ai))))) - (define fill-strings - (lambda (s s* i) - (cond - [(null? s*) s] - [else - (let ([a ($car s*)]) - (let ([n ($string-length a)]) - (let ([j ($fx+ i n)]) - (fill-string s a i j 0) - (fill-strings s ($cdr s*) j))))]))) - (primitive-set! 'string-append - (lambda s* - (let ([n (length* s* 0)]) - (let ([s ($make-string n)]) - (fill-strings s s* 0)))))) - - -(let () - (define fill - (lambda (s d si sj di) - (cond - [($fx= si sj) d] - [else - ($string-set! d di ($string-ref s si)) - (fill s d ($fxadd1 si) sj ($fxadd1 di))]))) - (primitive-set! 'substring - (lambda (s n m) - (unless (string? s) - (error 'substring "~s is not a string" s)) - (let ([len ($string-length s)]) - (unless (and (fixnum? n) - ($fx>= n 0) - ($fx< n len)) - (error 'substring "~s is not a valid start index for ~s" n s)) - (unless (and (fixnum? m) - ($fx>= m 0) - ($fx<= m len)) - (error 'substring "~s is not a valid end index for ~s" m s)) - (let ([len ($fx- m n)]) - (if ($fx<= len 0) - "" - (fill s ($make-string len) n m 0))))))) - -(primitive-set! 'not (lambda (x) (not x))) - -(primitive-set! 'symbol->string - (lambda (x) - (unless (symbol? x) - (error 'symbol->string "~s is not a symbol" x)) - (let ([str ($symbol-string x)]) - (or str - (let ([ct (gensym-count)]) - (let ([str (string-append (gensym-prefix) (fixnum->string ct))]) - ($set-symbol-string! x str) - (gensym-count ($fxadd1 ct)) - str)))))) - -(primitive-set! 'gensym? - (lambda (x) - (and (symbol? x) - (let ([s ($symbol-unique-string x)]) - (and s #t))))) - -(let () - (define f - (lambda (n i j) - (cond - [($fxzero? n) - (values (make-string i) j)] - [else - (let ([q ($fxquotient n 10)]) - (call-with-values - (lambda () (f q ($fxadd1 i) j)) - (lambda (str j) - (let ([r ($fx- n ($fx* q 10))]) - (string-set! str j - ($fixnum->char ($fx+ r ($char->fixnum #\0)))) - (values str ($fxadd1 j))))))]))) - (primitive-set! 'fixnum->string - (lambda (x) - (unless (fixnum? x) (error 'fixnum->string "~s is not a fixnum" x)) - (cond - [($fxzero? x) "0"] - [($fx> x 0) - (call-with-values - (lambda () (f x 0 0)) - (lambda (str j) str))] - [($fx= x -536870912) "-536870912"] - [else - (call-with-values - (lambda () (f ($fx- 0 x) 1 1)) - (lambda (str j) - ($string-set! str 0 #\-) - str))])))) - -(primitive-set! 'top-level-value - (lambda (x) - (unless (symbol? x) - (error 'top-level-value "~s is not a symbol" x)) - (let ([v ($symbol-value x)]) - (when ($unbound-object? v) - (error 'top-level-value "unbound variable ~s" x)) - v))) - -(primitive-set! 'top-level-bound? - (lambda (x) - (unless (symbol? x) - (error 'top-level-bound? "~s is not a symbol" x)) - (not ($unbound-object? ($symbol-value x))))) - -(primitive-set! 'set-top-level-value! - (lambda (x v) - (unless (symbol? x) - (error 'set-top-level-value! "~s is not a symbol" x)) - ($set-symbol-value! x v))) - -(primitive-set! 'symbol? (lambda (x) (symbol? x))) - -(primitive-set! 'primitive? - (lambda (x) - (unless (symbol? x) - (error 'primitive? "~s is not a symbol" x)) - (procedure? (primitive-ref x)))) - -(primitive-set! 'primitive-ref - (lambda (x) - (unless (symbol? x) - (error 'primitive-ref "~s is not a symbol" x)) - (let ([v (primitive-ref x)]) - (unless (procedure? v) - (error 'primitive-ref "~s is not a primitive" x)) - v))) - -(primitive-set! 'fx+ - (lambda (x y) - (unless (fixnum? x) - (error 'fx+ "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fx+ "~s is not a fixnum" y)) - ($fx+ x y))) - -(primitive-set! 'fx- - (lambda (x y) - (unless (fixnum? x) - (error 'fx- "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fx- "~s is not a fixnum" y)) - ($fx- x y))) - -(primitive-set! 'fx* - (lambda (x y) - (unless (fixnum? x) - (error 'fx* "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fx* "~s is not a fixnum" y)) - ($fx* x y))) - - - -(primitive-set! 'fxquotient - (lambda (x y) - (unless (fixnum? x) - (error 'fxquotient "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fxquotient "~s is not a fixnum" y)) - (when ($fxzero? y) - (error 'fxquotient "zero dividend ~s" y)) - ($fxquotient x y))) - - -(primitive-set! 'fxremainder - (lambda (x y) - (unless (fixnum? x) - (error 'fxremainder "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fxremainder "~s is not a fixnum" y)) - (when ($fxzero? y) - (error 'fxremainder "zero dividend ~s" y)) - (let ([q ($fxquotient x y)]) - ($fx- x ($fx* q y))))) - - -(primitive-set! 'fxmodulo - (lambda (x y) - (unless (fixnum? x) - (error 'fxmodulo "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fxmodulo "~s is not a fixnum" y)) - (when ($fxzero? y) - (error 'fxmodulo "zero dividend ~s" y)) - ($fxmodulo x y))) - - -(primitive-set! 'fxlogor - (lambda (x y) - (unless (fixnum? x) - (error 'fxlogor "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fxlogor "~s is not a fixnum" y)) - ($fxlogor x y))) - -(primitive-set! 'fxlogxor - (lambda (x y) - (unless (fixnum? x) - (error 'fxlogxor "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fxlogxor "~s is not a fixnum" y)) - ($fxlogxor x y))) - -(primitive-set! 'fxlogand - (lambda (x y) - (unless (fixnum? x) - (error 'fxlogand "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fxlogand "~s is not a fixnum" y)) - ($fxlogand x y))) - -(primitive-set! 'fxsra - (lambda (x y) - (unless (fixnum? x) - (error 'fxsra "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fxsra "~s is not a fixnum" y)) - (unless ($fx>= y 0) - (error 'fxsra "negative shift not allowed, got ~s" y)) - ($fxsra x y))) - -(primitive-set! 'fxsll - (lambda (x y) - (unless (fixnum? x) - (error 'fxsll "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fxsll "~s is not a fixnum" y)) - (unless ($fx>= y 0) - (error 'fxsll "negative shift not allowed, got ~s" y)) - ($fxsll x y))) - -(primitive-set! 'fx= - (lambda (x y) - (unless (fixnum? x) - (error 'fx= "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fx= "~s is not a fixnum" y)) - ($fx= x y))) - -(primitive-set! 'fx< - (lambda (x y) - (unless (fixnum? x) - (error 'fx< "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fx< "~s is not a fixnum" y)) - ($fx< x y))) - -(primitive-set! 'fx<= - (lambda (x y) - (unless (fixnum? x) - (error 'fx<= "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fx<= "~s is not a fixnum" y)) - ($fx<= x y))) - -(primitive-set! 'fx> - (lambda (x y) - (unless (fixnum? x) - (error 'fx> "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fx> "~s is not a fixnum" y)) - ($fx> x y))) - -(primitive-set! 'fx>= - (lambda (x y) - (unless (fixnum? x) - (error 'fx>= "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fx>= "~s is not a fixnum" y)) - ($fx>= x y))) - - -(primitive-set! 'char=? - (let () - (define (err x) - (error 'char=? "~s is not a character" x)) - (case-lambda - [(c1 c2) - (if (char? c1) - (if (char? c2) - ($char= c1 c2) - (err c2)) - (err c1))] - [(c1 c2 c3) - (if (char? c1) - (if (char? c2) - (if (char? c3) - (and ($char= c1 c2) - ($char= c2 c3)) - (err c3)) - (err c2)) - (err c1))] - [(c1 . c*) - (if (char? c1) - (let f ([c* c*]) - (or (null? c*) - (let ([c2 ($car c*)]) - (if (char? c2) - (if ($char= c1 c2) - (f ($cdr c*)) - (let g ([c* ($cdr c*)]) - (if (null? c*) - #f - (if (char? ($car c*)) - (g ($cdr c*)) - (err ($car c*)))))) - (err c2))))) - (err c1))]))) - - -(primitive-set! 'char? - (let () - (define (err x) - (error 'char>? "~s is not a character" x)) - (case-lambda - [(c1 c2) - (if (char? c1) - (if (char? c2) - ($char> c1 c2) - (err c2)) - (err c1))] - [(c1 c2 c3) - (if (char? c1) - (if (char? c2) - (if (char? c3) - (and ($char> c1 c2) - ($char> c2 c3)) - (err c3)) - (err c2)) - (err c1))] - [(c1 . c*) - (if (char? c1) - (let f ([c1 c1] [c* c*]) - (or (null? c*) - (let ([c2 ($car c*)]) - (if (char? c2) - (if ($char> c1 c2) - (f c2 ($cdr c*)) - (let g ([c* ($cdr c*)]) - (if (null? c*) - #f - (if (char? ($car c*)) - (g ($cdr c*)) - (err ($car c*)))))) - (err c2))))) - (err c1))]))) - -(primitive-set! 'char>=? - (let () - (define (err x) - (error 'char>=? "~s is not a character" x)) - (case-lambda - [(c1 c2) - (if (char? c1) - (if (char? c2) - ($char>= c1 c2) - (err c2)) - (err c1))] - [(c1 c2 c3) - (if (char? c1) - (if (char? c2) - (if (char? c3) - (and ($char>= c1 c2) - ($char>= c2 c3)) - (err c3)) - (err c2)) - (err c1))] - [(c1 . c*) - (if (char? c1) - (let f ([c1 c1] [c* c*]) - (or (null? c*) - (let ([c2 ($car c*)]) - (if (char? c2) - (if ($char>= c1 c2) - (f c2 ($cdr c*)) - (let g ([c* ($cdr c*)]) - (if (null? c*) - #f - (if (char? ($car c*)) - (g ($cdr c*)) - (err ($car c*)))))) - (err c2))))) - (err c1))]))) - - -(primitive-set! 'cons (lambda (x y) (cons x y))) - -(primitive-set! 'eq? (lambda (x y) (eq? x y))) - -(primitive-set! 'set-car! - (lambda (x y) - (unless (pair? x) - (error 'set-car! "~s is not a pair" x)) - ($set-car! x y))) - -(primitive-set! 'set-cdr! - (lambda (x y) - (unless (pair? x) - (error 'set-cdr! "~s is not a pair" x)) - ($set-cdr! x y))) - -(primitive-set! 'vector-ref - (lambda (v i) - (unless (vector? v) - (error 'vector-ref "~s is not a vector" v)) - (unless (fixnum? i) - (error 'vector-ref "~s is not a valid index" i)) - (unless (and ($fx< i ($vector-length v)) - ($fx<= 0 i)) - (error 'vector-ref "index ~s is out of range for ~s" i v)) - ($vector-ref v i))) - -(primitive-set! 'string-ref - (lambda (s i) - (unless (string? s) - (error 'string-ref "~s is not a string" s)) - (unless (fixnum? i) - (error 'string-ref "~s is not a valid index" i)) - (unless (and ($fx< i ($string-length s)) - ($fx<= 0 i)) - (error 'string-ref "index ~s is out of range for ~s" i s)) - ($string-ref s i))) - -(primitive-set! 'vector-set! - (lambda (v i c) - (unless (vector? v) - (error 'vector-set! "~s is not a vector" v)) - (unless (fixnum? i) - (error 'vector-set! "~s is not a valid index" i)) - (unless (and ($fx< i ($vector-length v)) - ($fx<= 0 i)) - (error 'vector-set! "index ~s is out of range for ~s" i v)) - ($vector-set! v i c))) - - -(primitive-set! 'string-set! - (lambda (s i c) - (unless (string? s) - (error 'string-set! "~s is not a string" s)) - (unless (fixnum? i) - (error 'string-set! "~s is not a valid index" i)) - (unless (and ($fx< i ($string-length s)) - ($fx>= i 0)) - (error 'string-set! "index ~s is out of range for ~s" i s)) - (unless (char? c) - (error 'string-set! "~s is not a character" c)) - ($string-set! s i c))) - -(primitive-set! 'vector - ;;; FIXME: add case-lambda - (letrec ([length - (lambda (ls n) - (cond - [(null? ls) n] - [else (length ($cdr ls) ($fx+ n 1))]))] - [loop - (lambda (v ls i n) - (cond - [($fx= i n) v] - [else - ($vector-set! v i ($car ls)) - (loop v ($cdr ls) ($fx+ i 1) n)]))]) - (lambda ls - (let ([n (length ls 0)]) - (let ([v (make-vector n)]) - (loop v ls 0 n)))))) - -(primitive-set! 'string - ;;; FIXME: add case-lambda - (letrec ([length - (lambda (ls n) - (cond - [(null? ls) n] - [(char? ($car ls)) (length ($cdr ls) ($fx+ n 1))] - [else (error 'string "~s is not a character" ($car ls))]))] - [loop - (lambda (s ls i n) - (cond - [($fx= i n) s] - [else - ($string-set! s i ($car ls)) - (loop s ($cdr ls) ($fx+ i 1) n)]))]) - (lambda ls - (let ([n (length ls 0)]) - (let ([s (make-string n)]) - (loop s ls 0 n)))))) - -(primitive-set! 'list? - (letrec ([race - (lambda (h t) - (if (pair? h) - (let ([h ($cdr h)]) - (if (pair? h) - (and (not (eq? h t)) - (race ($cdr h) ($cdr t))) - (null? h))) - (null? h)))]) - (lambda (x) (race x x)))) - - - -(primitive-set! 'reverse - (letrec ([race - (lambda (h t ls ac) - (if (pair? h) - (let ([h ($cdr h)] [ac (cons ($car h) ac)]) - (if (pair? h) - (if (not (eq? h t)) - (race ($cdr h) ($cdr t) ls (cons ($car h) ac)) - (error 'reverse "~s is a circular list" ls)) - (if (null? h) - ac - (error 'reverse "~s is not a proper list" ls)))) - (if (null? h) - ac - (error 'reverse "~s is not a proper list" ls))))]) - (lambda (x) - (race x x x '())))) - -(primitive-set! 'memq - (letrec ([race - (lambda (h t ls x) - (if (pair? h) - (if (eq? ($car h) x) - h - (let ([h ($cdr h)]) - (if (pair? h) - (if (eq? ($car h) x) - h - (if (not (eq? h t)) - (race ($cdr h) ($cdr t) ls x) - (error 'memq "circular list ~s" ls))) - (if (null? h) - '#f - (error 'memq "~s is not a proper list" ls))))) - (if (null? h) - '#f - (error 'memq "~s is not a proper list" ls))))]) - (lambda (x ls) - (race ls ls ls x)))) - -(primitive-set! 'list->string - (letrec ([race - (lambda (h t ls n) - (if (pair? h) - (let ([h ($cdr h)]) - (if (pair? h) - (if (not (eq? h t)) - (race ($cdr h) ($cdr t) ls ($fx+ n 2)) - (error 'reverse "circular list ~s" ls)) - (if (null? h) - ($fx+ n 1) - (error 'reverse "~s is not a proper list" ls)))) - (if (null? h) - n - (error 'reverse "~s is not a proper list" ls))))] - [fill - (lambda (s i ls) - (cond - [(null? ls) s] - [else - (let ([c ($car ls)]) - (unless (char? c) - (error 'list->string "~s is not a character" c)) - ($string-set! s i c) - (fill s ($fxadd1 i) (cdr ls)))]))]) - (lambda (ls) - (let ([n (race ls ls ls 0)]) - (let ([s ($make-string n)]) - (fill s 0 ls)))))) - -(primitive-set! 'length - (letrec ([race - (lambda (h t ls n) - (if (pair? h) - (let ([h ($cdr h)]) - (if (pair? h) - (if (not (eq? h t)) - (race ($cdr h) ($cdr t) ls ($fx+ n 2)) - (error 'length "circular list ~s" ls)) - (if (null? h) - ($fx+ n 1) - (error 'length "~s is not a proper list" ls)))) - (if (null? h) - n - (error 'length "~s is not a proper list" ls))))]) - (lambda (ls) - (race ls ls ls 0)))) - - -(primitive-set! 'list-ref - (lambda (list index) - (define f - (lambda (ls i) - (cond - [($fxzero? i) - (if (pair? ls) - ($car ls) - (error 'list-ref "index ~s is out of range for ~s" index list))] - [(pair? ls) - (f ($cdr ls) ($fxsub1 i))] - [(null? ls) - (error 'list-rec "index ~s is out of range for ~s" index list)] - [else (error 'list-ref "~s is not a list" list)]))) - (unless (and (fixnum? index) ($fx>= index 0)) - (error 'list-ref "~s is not a valid index" index)) - (f list index))) - - - -;(primitive-set! 'apply -; (letrec ([fix -; (lambda (arg arg*) -; (cond -; [(null? arg*) -; (if (list? arg) -; arg -; (error 'apply "last arg is not a list"))] -; [else -; (cons arg (fix ($car arg*) ($cdr arg*)))]))]) -; (lambda (f arg . arg*) -; (unless (procedure? f) -; (error 'apply "APPLY ~s ~s ~s" f arg arg*)) -; ($apply f (fix arg arg*))))) -; - -;(primitive-set! 'apply -; (letrec ([fix -; (lambda (arg arg*) -; (cond -; [(null? arg*) -; (if (list? arg) -; arg -; (error 'apply "last arg is not a list"))] -; [else -; (cons arg (fix ($car arg*) ($cdr arg*)))]))]) -; (lambda (f arg . arg*) -; (unless (procedure? f) -; (error 'apply "APPLY ~s ~s ~s" f arg arg*)) -; (let ([args (fix arg arg*)]) -; ($apply f args))))) - -(primitive-set! 'apply - (let () - (define (err f ls) - (if (procedure? f) - (error 'apply "not a list") - (error 'apply "~s is not a procedure" f))) - (define (fixandgo f a0 a1 ls p d) - (cond - [(null? ($cdr d)) - (let ([last ($car d)]) - ($set-cdr! p last) - (if (and (procedure? f) (list? last)) - ($apply f a0 a1 ls) - (err f last)))] - [else (fixandgo f a0 a1 ls d ($cdr d))])) - (define apply - (case-lambda - [(f ls) - (if (and (procedure? f) (list? ls)) - ($apply f ls) - (err f ls))] - [(f a0 ls) - (if (and (procedure? f) (list? ls)) - ($apply f a0 ls) - (err f ls))] - [(f a0 a1 ls) - (if (and (procedure? f) (list? ls)) - ($apply f a0 a1 ls) - (err f ls))] - [(f a0 a1 . ls) - (fixandgo f a0 a1 ls ls ($cdr ls))])) - apply)) - - - - - -(primitive-set! 'assq - (letrec ([race - (lambda (x h t ls) - (if (pair? h) - (let ([a ($car h)] [h ($cdr h)]) - (if (pair? a) - (if (eq? ($car a) x) - a - (if (pair? h) - (if (not (eq? h t)) - (let ([a ($car h)]) - (if (pair? a) - (if (eq? ($car a) x) - a - (race x ($cdr h) ($cdr t) ls)) - (error 'assq "malformed alist ~s" - ls))) - (error 'assq "circular list ~s" ls)) - (if (null? h) - #f - (error 'assq "~s is not a proper list" ls)))) - (error 'assq "malformed alist ~s" ls))) - (if (null? h) - #f - (error 'assq "~s is not a proper list" ls))))]) - (lambda (x ls) - (race x ls ls ls)))) - -(primitive-set! 'string->symbol - (lambda (x) - (unless (string? x) - (error 'string->symbol "~s is not a string" x)) - (foreign-call "ik_intern_string" x))) - -(primitive-set! 'oblist - (lambda () - (foreign-call "ik_oblist"))) - -(primitive-set! 'gensym - (case-lambda - [() ($make-symbol #f)] - [(s) - (if (string? s) - ($make-symbol s) - (error 'gensym "~s is not a string" s))])) - -(primitive-set! 'putprop - (lambda (x k v) - (unless (symbol? x) (error 'putprop "~s is not a symbol" x)) - (unless (symbol? k) (error 'putprop "~s is not a symbol" k)) - (let ([p ($symbol-plist x)]) - (cond - [(assq k p) => (lambda (x) (set-cdr! x v))] - [else - ($set-symbol-plist! x (cons (cons k v) p))])))) - -(primitive-set! 'getprop - (lambda (x k) - (unless (symbol? x) (error 'getprop "~s is not a symbol" x)) - (unless (symbol? k) (error 'getprop "~s is not a symbol" k)) - (let ([p ($symbol-plist x)]) - (cond - [(assq k p) => cdr] - [else #f])))) - -(primitive-set! 'remprop - (lambda (x k) - (unless (symbol? x) (error 'remprop "~s is not a symbol" x)) - (unless (symbol? k) (error 'remprop "~s is not a symbol" k)) - (let ([p ($symbol-plist x)]) - (unless (null? p) - (let ([a ($car p)]) - (cond - [(eq? ($car a) k) ($set-symbol-plist! x ($cdr p))] - [else - (let f ([q p] [p ($cdr p)]) - (unless (null? p) - (let ([a ($car p)]) - (cond - [(eq? ($car a) k) - ($set-cdr! q ($cdr p))] - [else - (f p ($cdr p))]))))])))))) - -(primitive-set! 'property-list - (lambda (x) - (unless (symbol? x) - (error 'property-list "~s is not a symbol" x)) - (letrec ([f - (lambda (ls ac) - (cond - [(null? ls) ac] - [else - (let ([a ($car ls)]) - (f ($cdr ls) - (cons ($car a) (cons ($cdr a) ac))))]))]) - (f ($symbol-plist x) '())))) - - -;;X (primitive-set! 'make-parameter -;;X (letrec ([make-param-no-guard -;;X (lambda (x) -;;X (lambda args -;;X (if (null? args) -;;X x -;;X (if (null? ($cdr args)) -;;X (set! x ($car args)) -;;X (error #f "too many arguments to parameter")))))] -;;X [make-param-with-guard -;;X (lambda (x g) -;;X (let ([f -;;X (lambda args -;;X (if (null? args) -;;X x -;;X (if (null? ($cdr args)) -;;X (set! x (g ($car args))) -;;X (error #f "too many arguments to parameter"))))]) -;;X (if (procedure? g) -;;X (begin (set! x (g x)) f) -;;X (error 'make-parameter "not a procedure ~s" g))))]) -;;X (lambda args -;;X (if (pair? args) -;;X (let ([x ($car args)] [args ($cdr args)]) -;;X (if (null? args) -;;X (make-param-no-guard x) -;;X (let ([g ($car args)]) -;;X (if (null? ($cdr args)) -;;X (make-param-with-guard x g) -;;X (error 'make-parameter "too many arguments"))))) -;;X (error 'make-parameter "insufficient arguments"))))) -;;X - -(primitive-set! 'make-parameter - (case-lambda - [(x) - (case-lambda - [() x] - [(v) (set! x v)])] - [(x guard) - (unless (procedure? guard) - (error 'make-parameter "~s is not a procedure" guard)) - (set! x (guard x)) - (case-lambda - [() x] - [(v) (set! x (guard v))])])) - -(let () - (define vector-loop - (lambda (x y i n) - (or ($fx= i n) - (and (equal? ($vector-ref x i) ($vector-ref y i)) - (vector-loop x y ($fxadd1 i) n))))) - (define string-loop - (lambda (x y i n) - (or ($fx= i n) - (and ($char= ($string-ref x i) ($string-ref y i)) - (string-loop x y ($fxadd1 i) n))))) - (define equal? - (lambda (x y) - (cond - [(eq? x y) #t] - [(pair? x) - (and (pair? y) - (equal? ($car x) ($car y)) - (equal? ($cdr x) ($cdr y)))] - [(vector? x) - (and (vector? y) - (let ([n ($vector-length x)]) - (and ($fx= n ($vector-length y)) - (vector-loop x y 0 n))))] - [(string? x) - (and (string? y) - (let ([n ($string-length x)]) - (and ($fx= n ($string-length y)) - (string-loop x y 0 n))))] - [else #f]))) - (primitive-set! 'equal? equal?)) - - -(let () - (define who 'map) - (define len - (lambda (h t n) - (if (pair? h) - (let ([h ($cdr h)]) - (if (pair? h) - (if (eq? h t) - (error who "circular list") - (len ($cdr h) ($cdr t) ($fx+ n 2))) - (if (null? h) - ($fxadd1 n) - (error who "improper list")))) - (if (null? h) - n - (error who "improper list"))))) - (define map1 - (lambda (f a d n) - (cond - [(pair? d) - (if ($fxzero? n) - (error who "list was altered!") - (cons (f a) - (map1 f ($car d) ($cdr d) ($fxsub1 n))))] - [(null? d) - (if ($fxzero? n) - (cons (f a) '()) - (error who "list was altered"))] - [else (error who "list was altered")]))) - (define map2 - (lambda (f a1 a2 d1 d2 n) - (cond - [(pair? d1) - (cond - [(pair? d2) - (if ($fxzero? n) - (error who "list was altered") - (cons (f a1 a2) - (map2 f - ($car d1) ($car d2) - ($cdr d1) ($cdr d2) - ($fxsub1 n))))] - [else (error who "length mismatch")])] - [(null? d1) - (cond - [(null? d2) - (if ($fxzero? n) - (cons (f a1 a2) '()) - (error who "list was altered"))] - [else (error who "length mismatch")])] - [else (error who "list was altered")]))) - (define cars - (lambda (ls*) - (cond - [(null? ls*) '()] - [else - (let ([a (car ls*)]) - (cond - [(pair? a) - (cons (car a) (cars (cdr ls*)))] - [else - (error 'map "length mismatch")]))]))) - (define cdrs - (lambda (ls*) - (cond - [(null? ls*) '()] - [else - (let ([a (car ls*)]) - (cond - [(pair? a) - (cons (cdr a) (cdrs (cdr ls*)))] - [else - (error 'map "length mismatch")]))]))) - (define mapm - (lambda (f ls ls* n) - (cond - [(null? ls) - (if (andmap null? ls*) - (if (fxzero? n) - '() - (error 'map "lists were mutated during operation")) - (error 'map "length mismatch"))] - [(fxzero? n) - (error 'map "lists were mutated during operation")] - [else - (cons - (apply f (car ls) (cars ls*)) - (mapm f (cdr ls) (cdrs ls*) (fxsub1 n)))]))) - (primitive-set! 'map - (case-lambda - [(f ls) - (unless (procedure? f) - (error who "~s is not a procedure" f)) - (cond - [(pair? ls) - (let ([d ($cdr ls)]) - (map1 f ($car ls) d (len d d 0)))] - [(null? ls) '()] - [else (error who "improper list")])] - [(f ls ls2) - (unless (procedure? f) - (error who "~s is not a procedure" f)) - (cond - [(pair? ls) - (if (pair? ls2) - (let ([d ($cdr ls)]) - (map2 f ($car ls) ($car ls2) d ($cdr ls2) (len d d 0))) - (error who "length mismatch"))] - [(null? ls) - (if (null? ls2) - '() - (error who "length mismatch"))] - [else (error who "not a list")])] - [(f ls . ls*) - (unless (procedure? f) - (error who "~s is not a procedure" f)) - (cond - [(pair? ls) - (let ([n (len ls ls 0)]) - (mapm f ls ls* n))] - [(null? ls) - (if (andmap null? ls*) - '() - (error who "length mismatch"))])]))) - - -(let () - (define who 'for-each) - (define len - (lambda (h t n) - (if (pair? h) - (let ([h ($cdr h)]) - (if (pair? h) - (if (eq? h t) - (error who "circular list") - (len ($cdr h) ($cdr t) ($fx+ n 2))) - (if (null? h) - ($fxadd1 n) - (error who "improper list")))) - (if (null? h) - n - (error who "improper list"))))) - (define for-each1 - (lambda (f a d n) - (cond - [(pair? d) - (if ($fxzero? n) - (error who "list was altered!") - (begin - (f a) - (for-each1 f ($car d) ($cdr d) ($fxsub1 n))))] - [(null? d) - (if ($fxzero? n) - (f a) - (error who "list was altered"))] - [else (error who "list was altered")]))) - (define for-each2 - (lambda (f a1 a2 d1 d2 n) - (cond - [(pair? d1) - (cond - [(pair? d2) - (if ($fxzero? n) - (error who "list was altered") - (begin - (f a1 a2) - (for-each2 f - ($car d1) ($car d2) - ($cdr d1) ($cdr d2) - ($fxsub1 n))))] - [else (error who "length mismatch")])] - [(null? d1) - (cond - [(null? d2) - (if ($fxzero? n) - (f a1 a2) - (error who "list was altered"))] - [else (error who "length mismatch")])] - [else (error who "list was altered")]))) - (primitive-set! 'for-each - (case-lambda - [(f ls) - (unless (procedure? f) - (error who "~s is not a procedure" f)) - (cond - [(pair? ls) - (let ([d ($cdr ls)]) - (for-each1 f ($car ls) d (len d d 0)))] - [(null? ls) (void)] - [else (error who "improper list")])] - [(f ls ls2) - (unless (procedure? f) - (error who "~s is not a procedure" f)) - (cond - [(pair? ls) - (if (pair? ls2) - (let ([d ($cdr ls)]) - (for-each2 f - ($car ls) ($car ls2) d ($cdr ls2) (len d d 0))) - (error who "length mismatch"))] - [(null? ls) - (if (null? ls2) - (void) - (error who "length mismatch"))] - [else (error who "not a list")])] - [_ (error who "vararg not supported yet")]))) - - - -(let () - (define who 'andmap) - (define len - (lambda (h t n) - (if (pair? h) - (let ([h ($cdr h)]) - (if (pair? h) - (if (eq? h t) - (error who "circular list") - (len ($cdr h) ($cdr t) ($fx+ n 2))) - (if (null? h) - ($fxadd1 n) - (error who "improper list")))) - (if (null? h) - n - (error who "improper list"))))) - (define andmap1 - (lambda (f a d n) - (cond - [(pair? d) - (if ($fxzero? n) - (error who "list was altered!") - (and (f a) - (andmap1 f ($car d) ($cdr d) ($fxsub1 n))))] - [(null? d) - (if ($fxzero? n) - (f a) - (error who "list was altered"))] - [else (error who "list was altered")]))) - (primitive-set! 'andmap - (case-lambda - [(f ls) - (unless (procedure? f) - (error who "~s is not a procedure" f)) - (cond - [(pair? ls) - (let ([d ($cdr ls)]) - (andmap1 f ($car ls) d (len d d 0)))] - [(null? ls) #t] - [else (error who "improper list")])] - [_ (error who "vararg not supported yet")]))) - - -(let () - (define who 'ormap) - (define len - (lambda (h t n) - (if (pair? h) - (let ([h ($cdr h)]) - (if (pair? h) - (if (eq? h t) - (error who "circular list") - (len ($cdr h) ($cdr t) ($fx+ n 2))) - (if (null? h) - ($fxadd1 n) - (error who "improper list")))) - (if (null? h) - n - (error who "improper list"))))) - (define ormap1 - (lambda (f a d n) - (cond - [(pair? d) - (if ($fxzero? n) - (error who "list was altered!") - (or (f a) - (ormap1 f ($car d) ($cdr d) ($fxsub1 n))))] - [(null? d) - (if ($fxzero? n) - (f a) - (error who "list was altered"))] - [else (error who "list was altered")]))) - (primitive-set! 'ormap - (case-lambda - [(f ls) - (unless (procedure? f) - (error who "~s is not a procedure" f)) - (cond - [(pair? ls) - (let ([d ($cdr ls)]) - (ormap1 f ($car ls) d (len d d 0)))] - [(null? ls) #f] - [else (error who "improper list")])] - [_ (error who "vararg not supported yet")]))) - - - - -(let () - (define reverse - (lambda (h t ls ac) - (if (pair? h) - (let ([h ($cdr h)] [a1 ($car h)]) - (if (pair? h) - (if (not (eq? h t)) - (let ([a2 ($car h)]) - (reverse ($cdr h) ($cdr t) ls (cons a2 (cons a1 ac)))) - (error 'append "circular list ~s" ls)) - (if (null? h) - (cons a1 ac) - (error 'append "~s is not a proper list" ls)))) - (if (null? h) - ac - (error 'append "~s is not a proper list" ls))))) - (define revcons - (lambda (ls ac) - (cond - [(null? ls) ac] - [else - (revcons ($cdr ls) (cons ($car ls) ac))]))) - (define append - (lambda (ls ls*) - (cond - [(null? ls*) ls] - [else - (revcons (reverse ls ls ls '()) - (append ($car ls*) ($cdr ls*)))]))) - (primitive-set! 'append - (lambda (ls . ls*) - (append ls ls*)))) - - -(primitive-set! 'list->vector - (letrec ([race - (lambda (h t ls n) - (if (pair? h) - (let ([h ($cdr h)]) - (if (pair? h) - (if (not (eq? h t)) - (race ($cdr h) ($cdr t) ls ($fx+ n 2)) - (error 'list->vector "circular list ~s" ls)) - (if (null? h) - ($fx+ n 1) - (error 'list->vector "~s is not a proper list" ls)))) - (if (null? h) - n - (error 'list->vector "~s is not a proper list" ls))))] - [fill - (lambda (v i ls) - (cond - [(null? ls) v] - [else - (let ([c ($car ls)]) - ($vector-set! v i c) - (fill v ($fxadd1 i) (cdr ls)))]))]) - (lambda (ls) - (let ([n (race ls ls ls 0)]) - (let ([v (make-vector n)]) - (fill v 0 ls)))))) - - -(let () - (define f - (lambda (v i ls) - (cond - [($fx< i 0) ls] - [else - (f v ($fxsub1 i) (cons ($vector-ref v i) ls))]))) - (primitive-set! 'vector->list - (lambda (v) - (if (vector? v) - (let ([n ($vector-length v)]) - (if ($fxzero? n) - '() - (f v ($fxsub1 n) '()))) - (error 'vector->list "~s is not a vector" v))))) - -(let () - (define f - (lambda (n fill ls) - (cond - [($fxzero? n) ls] - [else - (f ($fxsub1 n) fill (cons fill ls))]))) - (primitive-set! 'make-list - (case-lambda - [(n) - (if (and (fixnum? n) ($fx>= n 0)) - (f n (void) '()) - (error 'make-list "~s is not a valid length" n))] - [(n fill) - (if (and (fixnum? n) ($fx>= n 0)) - (f n fill '()) - (error 'make-list "~s is not a valid length" n))]))) - -(primitive-set! 'list (lambda x x)) - -(primitive-set! 'uuid - (lambda () - (let ([s (make-string 36)]) - (foreign-call "ik_uuid" s)))) - -(primitive-set! 'gensym->unique-string - (lambda (x) - (unless (symbol? x) - (error 'gensym->unique-string "~s is not a gensym" x)) - (let ([us ($symbol-unique-string x)]) - (cond - [(string? us) us] - [(eq? us #t) - (error 'gensym->unique-string "~s is not a gensym" x)] - [else - (let ([id (uuid)]) - ($set-symbol-unique-string! x id) - id)])))) - -(primitive-set! 'gensym-prefix - (make-parameter - "g" - (lambda (x) - (unless (string? x) - (error 'gensym-prefix "~s is not a string" x)) - x))) - -(primitive-set! 'gensym-count - (make-parameter - 0 - (lambda (x) - (unless (and (fixnum? x) ($fx>= x 0)) - (error 'gensym-count "~s is not a valid count" x)) - x))) - -(primitive-set! 'print-gensym - (make-parameter - #t - (lambda (x) - (unless (boolean? x) - (error 'print-gensym "~s is not a boolean" x)) - x))) - -(primitive-set! 'make-hash-table - (lambda () - (make-hash-table))) - -(primitive-set! 'hash-table? - (lambda (x) - (hash-table? x))) - -(primitive-set! 'get-hash-table - (lambda (h k v) - (foreign-call "ik_get_hash_table" h k v))) - -(primitive-set! 'put-hash-table! - (lambda (h k v) - (foreign-call "ik_put_hash_table" h k v))) - diff --git a/src/libcore-6.2.ss b/src/libcore-6.2.ss deleted file mode 100644 index b222960..0000000 --- a/src/libcore-6.2.ss +++ /dev/null @@ -1,1628 +0,0 @@ - -;;; 6.2 * added bwp-object?, weak-cons, weak-pair? -;;; * pointer-value -;;; 6.1: * added uses of case-lambda to replace the ugly code -;;; 6.0: * basic version working - - -(primitive-set! 'call-with-values - ($make-call-with-values-procedure)) - -(primitive-set! 'values - ($make-values-procedure)) - -(primitive-set! 'exit - (case-lambda - [() (exit 0)] - [(status) (foreign-call "exit" status)])) - -(primitive-set! 'eof-object - (lambda () (eof-object))) - -(primitive-set! 'void - (lambda () (void))) - -(primitive-set! 'eof-object? - (lambda (x) (eof-object? x))) - -(primitive-set! 'fxadd1 - (lambda (n) - (unless (fixnum? n) - (error 'fxadd1 "~s is not a fixnum" n)) - ($fxadd1 n))) - -(primitive-set! 'fxsub1 - (lambda (n) - (unless (fixnum? n) - (error 'fxsub1 "~s is not a fixnum" n)) - ($fxsub1 n))) - -(primitive-set! 'integer->char - (lambda (n) - (unless (fixnum? n) - (error 'integer->char "~s is not a fixnum" n)) - (unless (and ($fx>= n 0) - ($fx<= n 255)) - (error 'integer->char "~s is out of range[0..255]" n)) - ($fixnum->char n))) - -(primitive-set! 'char->integer - (lambda (x) - (unless (char? x) - (error 'char->integer "~s is not a character" x)) - ($char->fixnum x))) - -(primitive-set! 'fxlognot - (lambda (x) - (unless (fixnum? x) - (error 'fxlognot "~s is not a fixnum" x)) - ($fxlognot x))) - -(primitive-set! 'fixnum? (lambda (x) (fixnum? x))) -(primitive-set! 'immediate? (lambda (x) (immediate? x))) - -(primitive-set! 'fxzero? - (lambda (x) - (unless (fixnum? x) - (error 'fxzero? "~s is not a fixnum" x)) - ($fxzero? x))) - -(primitive-set! 'boolean? (lambda (x) (boolean? x))) - -(primitive-set! 'char? (lambda (x) (char? x))) - -(primitive-set! 'vector? (lambda (x) (vector? x))) - -(primitive-set! 'string? (lambda (x) (string? x))) - -(primitive-set! 'procedure? (lambda (x) (procedure? x))) - -(primitive-set! 'null? (lambda (x) (null? x))) - -(primitive-set! 'pair? (lambda (x) (pair? x))) - -(let () - (define fill! - (lambda (v i n fill) - (cond - [($fx= i n) v] - [else - ($vector-set! v i fill) - (fill! v ($fx+ i 1) n fill)]))) - (define make-vector - (case-lambda - [(n) (make-vector n (void))] - [(n fill) - (unless (and (fixnum? n) (fx>= n 0)) - (error 'make-vector "~s is not a valid length" n)) - (fill! ($make-vector n) 0 n fill)])) - (primitive-set! 'make-vector make-vector)) - -(primitive-set! 'vector-length - (lambda (x) - (unless (vector? x) - (error 'vector-length "~s is not a vector" x)) - ($vector-length x))) - -(let () - (define fill! - (lambda (s i n c) - (cond - [($fx= i n) s] - [else - ($string-set! s i c) - (fill! s ($fx+ i 1) n c)]))) - (define make-string - (case-lambda - [(n) - (unless (and (fixnum? n) (fx>= n 0)) - (error 'make-string "~s is not a valid length" n)) - ($make-string n)] - [(n c) - (unless (and (fixnum? n) (fx>= n 0)) - (error 'make-string "~s is not a valid length" n)) - (unless (char? c) - (error 'make-string "~s is not a character" c)) - (fill! ($make-string n) 0 n c)])) - (primitive-set! 'make-string make-string)) - - -(primitive-set! 'string-length - (lambda (x) - (unless (string? x) - (error 'string-length "~s is not a string" x)) - ($string-length x))) - -(primitive-set! 'string->list - (lambda (x) - (unless (string? x) - (error 'string->list "~s is not a string" x)) - (let f ([x x] [i ($string-length x)] [ac '()]) - (cond - [($fxzero? i) ac] - [else - (let ([i ($fxsub1 i)]) - (f x i (cons ($string-ref x i) ac)))])))) - - -(let () - (define bstring=? - (lambda (s1 s2 i j) - (or ($fx= i j) - (and ($char= ($string-ref s1 i) ($string-ref s2 i)) - (bstring=? s1 s2 ($fxadd1 i) j))))) - (define check-strings-and-return-false - (lambda (s*) - (cond - [(null? s*) #f] - [(string? ($car s*)) - (check-strings-and-return-false ($cdr s*))] - [else (err ($car s*))]))) - (define strings=? - (lambda (s s* n) - (or (null? s*) - (let ([a ($car s*)]) - (unless (string? a) - (error 'string=? "~s is not a string" a)) - (if ($fx= n ($string-length a)) - (and (strings=? s ($cdr s*) n) - (bstring=? s a 0 n)) - (check-strings-and-return-false ($cdr s*))))))) - (define (err x) - (error 'string=? "~s is not a string" x)) - (primitive-set! 'string=? - (case-lambda - [(s s1) - (if (string? s) - (if (string? s1) - (let ([n ($string-length s)]) - (and ($fx= n ($string-length s1)) - (bstring=? s s1 0 n))) - (err s1)) - (err s))] - [(s . s*) - (if (string? s) - (strings=? s s* ($string-length s)) - (err s))]))) - - - -(let () - ;; FIXME: make nonconsing on 0,1,2, and 3 args - (define length* - (lambda (s* n) - (cond - [(null? s*) n] - [else - (let ([a ($car s*)]) - (unless (string? a) - (error 'string-append "~s is not a string" a)) - (length* ($cdr s*) ($fx+ n ($string-length a))))]))) - (define fill-string - (lambda (s a si sj ai) - (unless ($fx= si sj) - ($string-set! s si ($string-ref a ai)) - (fill-string s a ($fxadd1 si) sj ($fxadd1 ai))))) - (define fill-strings - (lambda (s s* i) - (cond - [(null? s*) s] - [else - (let ([a ($car s*)]) - (let ([n ($string-length a)]) - (let ([j ($fx+ i n)]) - (fill-string s a i j 0) - (fill-strings s ($cdr s*) j))))]))) - (primitive-set! 'string-append - (lambda s* - (let ([n (length* s* 0)]) - (let ([s ($make-string n)]) - (fill-strings s s* 0)))))) - - -(let () - (define fill - (lambda (s d si sj di) - (cond - [($fx= si sj) d] - [else - ($string-set! d di ($string-ref s si)) - (fill s d ($fxadd1 si) sj ($fxadd1 di))]))) - (primitive-set! 'substring - (lambda (s n m) - (unless (string? s) - (error 'substring "~s is not a string" s)) - (let ([len ($string-length s)]) - (unless (and (fixnum? n) - ($fx>= n 0) - ($fx< n len)) - (error 'substring "~s is not a valid start index for ~s" n s)) - (unless (and (fixnum? m) - ($fx>= m 0) - ($fx<= m len)) - (error 'substring "~s is not a valid end index for ~s" m s)) - (let ([len ($fx- m n)]) - (if ($fx<= len 0) - "" - (fill s ($make-string len) n m 0))))))) - -(primitive-set! 'not (lambda (x) (not x))) - -(primitive-set! 'symbol->string - (lambda (x) - (unless (symbol? x) - (error 'symbol->string "~s is not a symbol" x)) - (let ([str ($symbol-string x)]) - (or str - (let ([ct (gensym-count)]) - (let ([str (string-append (gensym-prefix) (fixnum->string ct))]) - ($set-symbol-string! x str) - (gensym-count ($fxadd1 ct)) - str)))))) - -(primitive-set! 'gensym? - (lambda (x) - (and (symbol? x) - (let ([s ($symbol-unique-string x)]) - (and s #t))))) - -(let () - (define f - (lambda (n i j) - (cond - [($fxzero? n) - (values (make-string i) j)] - [else - (let ([q ($fxquotient n 10)]) - (call-with-values - (lambda () (f q ($fxadd1 i) j)) - (lambda (str j) - (let ([r ($fx- n ($fx* q 10))]) - (string-set! str j - ($fixnum->char ($fx+ r ($char->fixnum #\0)))) - (values str ($fxadd1 j))))))]))) - (primitive-set! 'fixnum->string - (lambda (x) - (unless (fixnum? x) (error 'fixnum->string "~s is not a fixnum" x)) - (cond - [($fxzero? x) "0"] - [($fx> x 0) - (call-with-values - (lambda () (f x 0 0)) - (lambda (str j) str))] - [($fx= x -536870912) "-536870912"] - [else - (call-with-values - (lambda () (f ($fx- 0 x) 1 1)) - (lambda (str j) - ($string-set! str 0 #\-) - str))])))) - -(primitive-set! 'top-level-value - (lambda (x) - (unless (symbol? x) - (error 'top-level-value "~s is not a symbol" x)) - (let ([v ($symbol-value x)]) - (when ($unbound-object? v) - (error 'top-level-value "unbound variable ~s" x)) - v))) - -(primitive-set! 'top-level-bound? - (lambda (x) - (unless (symbol? x) - (error 'top-level-bound? "~s is not a symbol" x)) - (not ($unbound-object? ($symbol-value x))))) - -(primitive-set! 'set-top-level-value! - (lambda (x v) - (unless (symbol? x) - (error 'set-top-level-value! "~s is not a symbol" x)) - ($set-symbol-value! x v))) - -(primitive-set! 'symbol? (lambda (x) (symbol? x))) - -(primitive-set! 'primitive? - (lambda (x) - (unless (symbol? x) - (error 'primitive? "~s is not a symbol" x)) - (procedure? (primitive-ref x)))) - -(primitive-set! 'primitive-ref - (lambda (x) - (unless (symbol? x) - (error 'primitive-ref "~s is not a symbol" x)) - (let ([v (primitive-ref x)]) - (unless (procedure? v) - (error 'primitive-ref "~s is not a primitive" x)) - v))) - -(primitive-set! 'primitive-set! - (lambda (x v) - (unless (symbol? x) - (error 'primitive-set! "~s is not a symbol" x)) - (primitive-set! x v) - (set-top-level-value! x v))) - - - - - -(primitive-set! 'fx+ - (lambda (x y) - (unless (fixnum? x) - (error 'fx+ "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fx+ "~s is not a fixnum" y)) - ($fx+ x y))) - -(primitive-set! 'fx- - (lambda (x y) - (unless (fixnum? x) - (error 'fx- "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fx- "~s is not a fixnum" y)) - ($fx- x y))) - -(primitive-set! 'fx* - (lambda (x y) - (unless (fixnum? x) - (error 'fx* "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fx* "~s is not a fixnum" y)) - ($fx* x y))) - - - -(primitive-set! 'fxquotient - (lambda (x y) - (unless (fixnum? x) - (error 'fxquotient "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fxquotient "~s is not a fixnum" y)) - (when ($fxzero? y) - (error 'fxquotient "zero dividend ~s" y)) - ($fxquotient x y))) - - -(primitive-set! 'fxremainder - (lambda (x y) - (unless (fixnum? x) - (error 'fxremainder "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fxremainder "~s is not a fixnum" y)) - (when ($fxzero? y) - (error 'fxremainder "zero dividend ~s" y)) - (let ([q ($fxquotient x y)]) - ($fx- x ($fx* q y))))) - - -(primitive-set! 'fxmodulo - (lambda (x y) - (unless (fixnum? x) - (error 'fxmodulo "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fxmodulo "~s is not a fixnum" y)) - (when ($fxzero? y) - (error 'fxmodulo "zero dividend ~s" y)) - ($fxmodulo x y))) - - -(primitive-set! 'fxlogor - (lambda (x y) - (unless (fixnum? x) - (error 'fxlogor "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fxlogor "~s is not a fixnum" y)) - ($fxlogor x y))) - -(primitive-set! 'fxlogxor - (lambda (x y) - (unless (fixnum? x) - (error 'fxlogxor "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fxlogxor "~s is not a fixnum" y)) - ($fxlogxor x y))) - -(primitive-set! 'fxlogand - (lambda (x y) - (unless (fixnum? x) - (error 'fxlogand "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fxlogand "~s is not a fixnum" y)) - ($fxlogand x y))) - -(primitive-set! 'fxsra - (lambda (x y) - (unless (fixnum? x) - (error 'fxsra "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fxsra "~s is not a fixnum" y)) - (unless ($fx>= y 0) - (error 'fxsra "negative shift not allowed, got ~s" y)) - ($fxsra x y))) - -(primitive-set! 'fxsll - (lambda (x y) - (unless (fixnum? x) - (error 'fxsll "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fxsll "~s is not a fixnum" y)) - (unless ($fx>= y 0) - (error 'fxsll "negative shift not allowed, got ~s" y)) - ($fxsll x y))) - -(primitive-set! 'fx= - (lambda (x y) - (unless (fixnum? x) - (error 'fx= "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fx= "~s is not a fixnum" y)) - ($fx= x y))) - -(primitive-set! 'fx< - (lambda (x y) - (unless (fixnum? x) - (error 'fx< "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fx< "~s is not a fixnum" y)) - ($fx< x y))) - -(primitive-set! 'fx<= - (lambda (x y) - (unless (fixnum? x) - (error 'fx<= "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fx<= "~s is not a fixnum" y)) - ($fx<= x y))) - -(primitive-set! 'fx> - (lambda (x y) - (unless (fixnum? x) - (error 'fx> "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fx> "~s is not a fixnum" y)) - ($fx> x y))) - -(primitive-set! 'fx>= - (lambda (x y) - (unless (fixnum? x) - (error 'fx>= "~s is not a fixnum" x)) - (unless (fixnum? y) - (error 'fx>= "~s is not a fixnum" y)) - ($fx>= x y))) - - -(primitive-set! 'char=? - (let () - (define (err x) - (error 'char=? "~s is not a character" x)) - (case-lambda - [(c1 c2) - (if (char? c1) - (if (char? c2) - ($char= c1 c2) - (err c2)) - (err c1))] - [(c1 c2 c3) - (if (char? c1) - (if (char? c2) - (if (char? c3) - (and ($char= c1 c2) - ($char= c2 c3)) - (err c3)) - (err c2)) - (err c1))] - [(c1 . c*) - (if (char? c1) - (let f ([c* c*]) - (or (null? c*) - (let ([c2 ($car c*)]) - (if (char? c2) - (if ($char= c1 c2) - (f ($cdr c*)) - (let g ([c* ($cdr c*)]) - (if (null? c*) - #f - (if (char? ($car c*)) - (g ($cdr c*)) - (err ($car c*)))))) - (err c2))))) - (err c1))]))) - - -(primitive-set! 'char? - (let () - (define (err x) - (error 'char>? "~s is not a character" x)) - (case-lambda - [(c1 c2) - (if (char? c1) - (if (char? c2) - ($char> c1 c2) - (err c2)) - (err c1))] - [(c1 c2 c3) - (if (char? c1) - (if (char? c2) - (if (char? c3) - (and ($char> c1 c2) - ($char> c2 c3)) - (err c3)) - (err c2)) - (err c1))] - [(c1 . c*) - (if (char? c1) - (let f ([c1 c1] [c* c*]) - (or (null? c*) - (let ([c2 ($car c*)]) - (if (char? c2) - (if ($char> c1 c2) - (f c2 ($cdr c*)) - (let g ([c* ($cdr c*)]) - (if (null? c*) - #f - (if (char? ($car c*)) - (g ($cdr c*)) - (err ($car c*)))))) - (err c2))))) - (err c1))]))) - -(primitive-set! 'char>=? - (let () - (define (err x) - (error 'char>=? "~s is not a character" x)) - (case-lambda - [(c1 c2) - (if (char? c1) - (if (char? c2) - ($char>= c1 c2) - (err c2)) - (err c1))] - [(c1 c2 c3) - (if (char? c1) - (if (char? c2) - (if (char? c3) - (and ($char>= c1 c2) - ($char>= c2 c3)) - (err c3)) - (err c2)) - (err c1))] - [(c1 . c*) - (if (char? c1) - (let f ([c1 c1] [c* c*]) - (or (null? c*) - (let ([c2 ($car c*)]) - (if (char? c2) - (if ($char>= c1 c2) - (f c2 ($cdr c*)) - (let g ([c* ($cdr c*)]) - (if (null? c*) - #f - (if (char? ($car c*)) - (g ($cdr c*)) - (err ($car c*)))))) - (err c2))))) - (err c1))]))) - - -(primitive-set! 'cons (lambda (x y) (cons x y))) - -(primitive-set! 'eq? (lambda (x y) (eq? x y))) - -(primitive-set! 'set-car! - (lambda (x y) - (unless (pair? x) - (error 'set-car! "~s is not a pair" x)) - ($set-car! x y))) - -(primitive-set! 'set-cdr! - (lambda (x y) - (unless (pair? x) - (error 'set-cdr! "~s is not a pair" x)) - ($set-cdr! x y))) - -(primitive-set! 'vector-ref - (lambda (v i) - (unless (vector? v) - (error 'vector-ref "~s is not a vector" v)) - (unless (fixnum? i) - (error 'vector-ref "~s is not a valid index" i)) - (unless (and ($fx< i ($vector-length v)) - ($fx<= 0 i)) - (error 'vector-ref "index ~s is out of range for ~s" i v)) - ($vector-ref v i))) - -(primitive-set! 'string-ref - (lambda (s i) - (unless (string? s) - (error 'string-ref "~s is not a string" s)) - (unless (fixnum? i) - (error 'string-ref "~s is not a valid index" i)) - (unless (and ($fx< i ($string-length s)) - ($fx<= 0 i)) - (error 'string-ref "index ~s is out of range for ~s" i s)) - ($string-ref s i))) - -(primitive-set! 'vector-set! - (lambda (v i c) - (unless (vector? v) - (error 'vector-set! "~s is not a vector" v)) - (unless (fixnum? i) - (error 'vector-set! "~s is not a valid index" i)) - (unless (and ($fx< i ($vector-length v)) - ($fx<= 0 i)) - (error 'vector-set! "index ~s is out of range for ~s" i v)) - ($vector-set! v i c))) - - -(primitive-set! 'string-set! - (lambda (s i c) - (unless (string? s) - (error 'string-set! "~s is not a string" s)) - (unless (fixnum? i) - (error 'string-set! "~s is not a valid index" i)) - (unless (and ($fx< i ($string-length s)) - ($fx>= i 0)) - (error 'string-set! "index ~s is out of range for ~s" i s)) - (unless (char? c) - (error 'string-set! "~s is not a character" c)) - ($string-set! s i c))) - -(primitive-set! 'vector - ;;; FIXME: add case-lambda - (letrec ([length - (lambda (ls n) - (cond - [(null? ls) n] - [else (length ($cdr ls) ($fx+ n 1))]))] - [loop - (lambda (v ls i n) - (cond - [($fx= i n) v] - [else - ($vector-set! v i ($car ls)) - (loop v ($cdr ls) ($fx+ i 1) n)]))]) - (lambda ls - (let ([n (length ls 0)]) - (let ([v (make-vector n)]) - (loop v ls 0 n)))))) - -(primitive-set! 'string - ;;; FIXME: add case-lambda - (letrec ([length - (lambda (ls n) - (cond - [(null? ls) n] - [(char? ($car ls)) (length ($cdr ls) ($fx+ n 1))] - [else (error 'string "~s is not a character" ($car ls))]))] - [loop - (lambda (s ls i n) - (cond - [($fx= i n) s] - [else - ($string-set! s i ($car ls)) - (loop s ($cdr ls) ($fx+ i 1) n)]))]) - (lambda ls - (let ([n (length ls 0)]) - (let ([s (make-string n)]) - (loop s ls 0 n)))))) - -(primitive-set! 'list? - (letrec ([race - (lambda (h t) - (if (pair? h) - (let ([h ($cdr h)]) - (if (pair? h) - (and (not (eq? h t)) - (race ($cdr h) ($cdr t))) - (null? h))) - (null? h)))]) - (lambda (x) (race x x)))) - - - -(primitive-set! 'reverse - (letrec ([race - (lambda (h t ls ac) - (if (pair? h) - (let ([h ($cdr h)] [ac (cons ($car h) ac)]) - (if (pair? h) - (if (not (eq? h t)) - (race ($cdr h) ($cdr t) ls (cons ($car h) ac)) - (error 'reverse "~s is a circular list" ls)) - (if (null? h) - ac - (error 'reverse "~s is not a proper list" ls)))) - (if (null? h) - ac - (error 'reverse "~s is not a proper list" ls))))]) - (lambda (x) - (race x x x '())))) - -(primitive-set! 'memq - (letrec ([race - (lambda (h t ls x) - (if (pair? h) - (if (eq? ($car h) x) - h - (let ([h ($cdr h)]) - (if (pair? h) - (if (eq? ($car h) x) - h - (if (not (eq? h t)) - (race ($cdr h) ($cdr t) ls x) - (error 'memq "circular list ~s" ls))) - (if (null? h) - '#f - (error 'memq "~s is not a proper list" ls))))) - (if (null? h) - '#f - (error 'memq "~s is not a proper list" ls))))]) - (lambda (x ls) - (race ls ls ls x)))) - -(primitive-set! 'memv memq) - -(primitive-set! 'list->string - (letrec ([race - (lambda (h t ls n) - (if (pair? h) - (let ([h ($cdr h)]) - (if (pair? h) - (if (not (eq? h t)) - (race ($cdr h) ($cdr t) ls ($fx+ n 2)) - (error 'reverse "circular list ~s" ls)) - (if (null? h) - ($fx+ n 1) - (error 'reverse "~s is not a proper list" ls)))) - (if (null? h) - n - (error 'reverse "~s is not a proper list" ls))))] - [fill - (lambda (s i ls) - (cond - [(null? ls) s] - [else - (let ([c ($car ls)]) - (unless (char? c) - (error 'list->string "~s is not a character" c)) - ($string-set! s i c) - (fill s ($fxadd1 i) (cdr ls)))]))]) - (lambda (ls) - (let ([n (race ls ls ls 0)]) - (let ([s ($make-string n)]) - (fill s 0 ls)))))) - -(primitive-set! 'length - (letrec ([race - (lambda (h t ls n) - (if (pair? h) - (let ([h ($cdr h)]) - (if (pair? h) - (if (not (eq? h t)) - (race ($cdr h) ($cdr t) ls ($fx+ n 2)) - (error 'length "circular list ~s" ls)) - (if (null? h) - ($fx+ n 1) - (error 'length "~s is not a proper list" ls)))) - (if (null? h) - n - (error 'length "~s is not a proper list" ls))))]) - (lambda (ls) - (race ls ls ls 0)))) - - -(primitive-set! 'list-ref - (lambda (list index) - (define f - (lambda (ls i) - (cond - [($fxzero? i) - (if (pair? ls) - ($car ls) - (error 'list-ref "index ~s is out of range for ~s" index list))] - [(pair? ls) - (f ($cdr ls) ($fxsub1 i))] - [(null? ls) - (error 'list-rec "index ~s is out of range for ~s" index list)] - [else (error 'list-ref "~s is not a list" list)]))) - (unless (and (fixnum? index) ($fx>= index 0)) - (error 'list-ref "~s is not a valid index" index)) - (f list index))) - - - -;(primitive-set! 'apply -; (letrec ([fix -; (lambda (arg arg*) -; (cond -; [(null? arg*) -; (if (list? arg) -; arg -; (error 'apply "last arg is not a list"))] -; [else -; (cons arg (fix ($car arg*) ($cdr arg*)))]))]) -; (lambda (f arg . arg*) -; (unless (procedure? f) -; (error 'apply "APPLY ~s ~s ~s" f arg arg*)) -; ($apply f (fix arg arg*))))) -; - -;(primitive-set! 'apply -; (letrec ([fix -; (lambda (arg arg*) -; (cond -; [(null? arg*) -; (if (list? arg) -; arg -; (error 'apply "last arg is not a list"))] -; [else -; (cons arg (fix ($car arg*) ($cdr arg*)))]))]) -; (lambda (f arg . arg*) -; (unless (procedure? f) -; (error 'apply "APPLY ~s ~s ~s" f arg arg*)) -; (let ([args (fix arg arg*)]) -; ($apply f args))))) - -(primitive-set! 'apply - (let () - (define (err f ls) - (if (procedure? f) - (error 'apply "not a list") - (error 'apply "~s is not a procedure" f))) - (define (fixandgo f a0 a1 ls p d) - (cond - [(null? ($cdr d)) - (let ([last ($car d)]) - ($set-cdr! p last) - (if (and (procedure? f) (list? last)) - ($apply f a0 a1 ls) - (err f last)))] - [else (fixandgo f a0 a1 ls d ($cdr d))])) - (define apply - (case-lambda - [(f ls) - (if (and (procedure? f) (list? ls)) - ($apply f ls) - (err f ls))] - [(f a0 ls) - (if (and (procedure? f) (list? ls)) - ($apply f a0 ls) - (err f ls))] - [(f a0 a1 ls) - (if (and (procedure? f) (list? ls)) - ($apply f a0 a1 ls) - (err f ls))] - [(f a0 a1 . ls) - (fixandgo f a0 a1 ls ls ($cdr ls))])) - apply)) - - - - - -(primitive-set! 'assq - (letrec ([race - (lambda (x h t ls) - (if (pair? h) - (let ([a ($car h)] [h ($cdr h)]) - (if (pair? a) - (if (eq? ($car a) x) - a - (if (pair? h) - (if (not (eq? h t)) - (let ([a ($car h)]) - (if (pair? a) - (if (eq? ($car a) x) - a - (race x ($cdr h) ($cdr t) ls)) - (error 'assq "malformed alist ~s" - ls))) - (error 'assq "circular list ~s" ls)) - (if (null? h) - #f - (error 'assq "~s is not a proper list" ls)))) - (error 'assq "malformed alist ~s" ls))) - (if (null? h) - #f - (error 'assq "~s is not a proper list" ls))))]) - (lambda (x ls) - (race x ls ls ls)))) - -(primitive-set! 'string->symbol - (lambda (x) - (unless (string? x) - (error 'string->symbol "~s is not a string" x)) - (foreign-call "ik_intern_string" x))) - -(primitive-set! 'oblist - (lambda () - (foreign-call "ik_oblist"))) - -(primitive-set! 'gensym - (case-lambda - [() ($make-symbol #f)] - [(s) - (if (string? s) - ($make-symbol s) - (error 'gensym "~s is not a string" s))])) - -(primitive-set! 'putprop - (lambda (x k v) - (unless (symbol? x) (error 'putprop "~s is not a symbol" x)) - (unless (symbol? k) (error 'putprop "~s is not a symbol" k)) - (let ([p ($symbol-plist x)]) - (cond - [(assq k p) => (lambda (x) (set-cdr! x v))] - [else - ($set-symbol-plist! x (cons (cons k v) p))])))) - -(primitive-set! 'getprop - (lambda (x k) - (unless (symbol? x) (error 'getprop "~s is not a symbol" x)) - (unless (symbol? k) (error 'getprop "~s is not a symbol" k)) - (let ([p ($symbol-plist x)]) - (cond - [(assq k p) => cdr] - [else #f])))) - -(primitive-set! 'remprop - (lambda (x k) - (unless (symbol? x) (error 'remprop "~s is not a symbol" x)) - (unless (symbol? k) (error 'remprop "~s is not a symbol" k)) - (let ([p ($symbol-plist x)]) - (unless (null? p) - (let ([a ($car p)]) - (cond - [(eq? ($car a) k) ($set-symbol-plist! x ($cdr p))] - [else - (let f ([q p] [p ($cdr p)]) - (unless (null? p) - (let ([a ($car p)]) - (cond - [(eq? ($car a) k) - ($set-cdr! q ($cdr p))] - [else - (f p ($cdr p))]))))])))))) - -(primitive-set! 'property-list - (lambda (x) - (unless (symbol? x) - (error 'property-list "~s is not a symbol" x)) - (letrec ([f - (lambda (ls ac) - (cond - [(null? ls) ac] - [else - (let ([a ($car ls)]) - (f ($cdr ls) - (cons ($car a) (cons ($cdr a) ac))))]))]) - (f ($symbol-plist x) '())))) - - -;;X (primitive-set! 'make-parameter -;;X (letrec ([make-param-no-guard -;;X (lambda (x) -;;X (lambda args -;;X (if (null? args) -;;X x -;;X (if (null? ($cdr args)) -;;X (set! x ($car args)) -;;X (error #f "too many arguments to parameter")))))] -;;X [make-param-with-guard -;;X (lambda (x g) -;;X (let ([f -;;X (lambda args -;;X (if (null? args) -;;X x -;;X (if (null? ($cdr args)) -;;X (set! x (g ($car args))) -;;X (error #f "too many arguments to parameter"))))]) -;;X (if (procedure? g) -;;X (begin (set! x (g x)) f) -;;X (error 'make-parameter "not a procedure ~s" g))))]) -;;X (lambda args -;;X (if (pair? args) -;;X (let ([x ($car args)] [args ($cdr args)]) -;;X (if (null? args) -;;X (make-param-no-guard x) -;;X (let ([g ($car args)]) -;;X (if (null? ($cdr args)) -;;X (make-param-with-guard x g) -;;X (error 'make-parameter "too many arguments"))))) -;;X (error 'make-parameter "insufficient arguments"))))) -;;X - -(primitive-set! 'make-parameter - (case-lambda - [(x) - (case-lambda - [() x] - [(v) (set! x v)])] - [(x guard) - (unless (procedure? guard) - (error 'make-parameter "~s is not a procedure" guard)) - (set! x (guard x)) - (case-lambda - [() x] - [(v) (set! x (guard v))])])) - -(let () - (define vector-loop - (lambda (x y i n) - (or ($fx= i n) - (and (equal? ($vector-ref x i) ($vector-ref y i)) - (vector-loop x y ($fxadd1 i) n))))) - (define string-loop - (lambda (x y i n) - (or ($fx= i n) - (and ($char= ($string-ref x i) ($string-ref y i)) - (string-loop x y ($fxadd1 i) n))))) - (define equal? - (lambda (x y) - (cond - [(eq? x y) #t] - [(pair? x) - (and (pair? y) - (equal? ($car x) ($car y)) - (equal? ($cdr x) ($cdr y)))] - [(vector? x) - (and (vector? y) - (let ([n ($vector-length x)]) - (and ($fx= n ($vector-length y)) - (vector-loop x y 0 n))))] - [(string? x) - (and (string? y) - (let ([n ($string-length x)]) - (and ($fx= n ($string-length y)) - (string-loop x y 0 n))))] - [else #f]))) - (primitive-set! 'equal? equal?)) - - -(let () - (define who 'map) - (define len - (lambda (h t n) - (if (pair? h) - (let ([h ($cdr h)]) - (if (pair? h) - (if (eq? h t) - (error who "circular list") - (len ($cdr h) ($cdr t) ($fx+ n 2))) - (if (null? h) - ($fxadd1 n) - (error who "improper list")))) - (if (null? h) - n - (error who "improper list"))))) - (define map1 - (lambda (f a d n) - (cond - [(pair? d) - (if ($fxzero? n) - (error who "list was altered!") - (cons (f a) - (map1 f ($car d) ($cdr d) ($fxsub1 n))))] - [(null? d) - (if ($fxzero? n) - (cons (f a) '()) - (error who "list was altered"))] - [else (error who "list was altered")]))) - (define map2 - (lambda (f a1 a2 d1 d2 n) - (cond - [(pair? d1) - (cond - [(pair? d2) - (if ($fxzero? n) - (error who "list was altered") - (cons (f a1 a2) - (map2 f - ($car d1) ($car d2) - ($cdr d1) ($cdr d2) - ($fxsub1 n))))] - [else (error who "length mismatch")])] - [(null? d1) - (cond - [(null? d2) - (if ($fxzero? n) - (cons (f a1 a2) '()) - (error who "list was altered"))] - [else (error who "length mismatch")])] - [else (error who "list was altered")]))) - (define cars - (lambda (ls*) - (cond - [(null? ls*) '()] - [else - (let ([a (car ls*)]) - (cond - [(pair? a) - (cons (car a) (cars (cdr ls*)))] - [else - (error 'map "length mismatch")]))]))) - (define cdrs - (lambda (ls*) - (cond - [(null? ls*) '()] - [else - (let ([a (car ls*)]) - (cond - [(pair? a) - (cons (cdr a) (cdrs (cdr ls*)))] - [else - (error 'map "length mismatch")]))]))) - (define mapm - (lambda (f ls ls* n) - (cond - [(null? ls) - (if (andmap null? ls*) - (if (fxzero? n) - '() - (error 'map "lists were mutated during operation")) - (error 'map "length mismatch"))] - [(fxzero? n) - (error 'map "lists were mutated during operation")] - [else - (cons - (apply f (car ls) (cars ls*)) - (mapm f (cdr ls) (cdrs ls*) (fxsub1 n)))]))) - (primitive-set! 'map - (case-lambda - [(f ls) - (unless (procedure? f) - (error who "~s is not a procedure" f)) - (cond - [(pair? ls) - (let ([d ($cdr ls)]) - (map1 f ($car ls) d (len d d 0)))] - [(null? ls) '()] - [else (error who "improper list")])] - [(f ls ls2) - (unless (procedure? f) - (error who "~s is not a procedure" f)) - (cond - [(pair? ls) - (if (pair? ls2) - (let ([d ($cdr ls)]) - (map2 f ($car ls) ($car ls2) d ($cdr ls2) (len d d 0))) - (error who "length mismatch"))] - [(null? ls) - (if (null? ls2) - '() - (error who "length mismatch"))] - [else (error who "not a list")])] - [(f ls . ls*) - (unless (procedure? f) - (error who "~s is not a procedure" f)) - (cond - [(pair? ls) - (let ([n (len ls ls 0)]) - (mapm f ls ls* n))] - [(null? ls) - (if (andmap null? ls*) - '() - (error who "length mismatch"))])]))) - - -(let () - (define who 'for-each) - (define len - (lambda (h t n) - (if (pair? h) - (let ([h ($cdr h)]) - (if (pair? h) - (if (eq? h t) - (error who "circular list") - (len ($cdr h) ($cdr t) ($fx+ n 2))) - (if (null? h) - ($fxadd1 n) - (error who "improper list")))) - (if (null? h) - n - (error who "improper list"))))) - (define for-each1 - (lambda (f a d n) - (cond - [(pair? d) - (if ($fxzero? n) - (error who "list was altered!") - (begin - (f a) - (for-each1 f ($car d) ($cdr d) ($fxsub1 n))))] - [(null? d) - (if ($fxzero? n) - (f a) - (error who "list was altered"))] - [else (error who "list was altered")]))) - (define for-each2 - (lambda (f a1 a2 d1 d2 n) - (cond - [(pair? d1) - (cond - [(pair? d2) - (if ($fxzero? n) - (error who "list was altered") - (begin - (f a1 a2) - (for-each2 f - ($car d1) ($car d2) - ($cdr d1) ($cdr d2) - ($fxsub1 n))))] - [else (error who "length mismatch")])] - [(null? d1) - (cond - [(null? d2) - (if ($fxzero? n) - (f a1 a2) - (error who "list was altered"))] - [else (error who "length mismatch")])] - [else (error who "list was altered")]))) - (primitive-set! 'for-each - (case-lambda - [(f ls) - (unless (procedure? f) - (error who "~s is not a procedure" f)) - (cond - [(pair? ls) - (let ([d ($cdr ls)]) - (for-each1 f ($car ls) d (len d d 0)))] - [(null? ls) (void)] - [else (error who "improper list")])] - [(f ls ls2) - (unless (procedure? f) - (error who "~s is not a procedure" f)) - (cond - [(pair? ls) - (if (pair? ls2) - (let ([d ($cdr ls)]) - (for-each2 f - ($car ls) ($car ls2) d ($cdr ls2) (len d d 0))) - (error who "length mismatch"))] - [(null? ls) - (if (null? ls2) - (void) - (error who "length mismatch"))] - [else (error who "not a list")])] - [_ (error who "vararg not supported yet")]))) - - - -(let () - (define who 'andmap) - (define len - (lambda (h t n) - (if (pair? h) - (let ([h ($cdr h)]) - (if (pair? h) - (if (eq? h t) - (error who "circular list") - (len ($cdr h) ($cdr t) ($fx+ n 2))) - (if (null? h) - ($fxadd1 n) - (error who "improper list")))) - (if (null? h) - n - (error who "improper list"))))) - (define andmap1 - (lambda (f a d n) - (cond - [(pair? d) - (if ($fxzero? n) - (error who "list was altered!") - (and (f a) - (andmap1 f ($car d) ($cdr d) ($fxsub1 n))))] - [(null? d) - (if ($fxzero? n) - (f a) - (error who "list was altered"))] - [else (error who "list was altered")]))) - (primitive-set! 'andmap - (case-lambda - [(f ls) - (unless (procedure? f) - (error who "~s is not a procedure" f)) - (cond - [(pair? ls) - (let ([d ($cdr ls)]) - (andmap1 f ($car ls) d (len d d 0)))] - [(null? ls) #t] - [else (error who "improper list")])] - [_ (error who "vararg not supported yet")]))) - - -(let () - (define who 'ormap) - (define len - (lambda (h t n) - (if (pair? h) - (let ([h ($cdr h)]) - (if (pair? h) - (if (eq? h t) - (error who "circular list") - (len ($cdr h) ($cdr t) ($fx+ n 2))) - (if (null? h) - ($fxadd1 n) - (error who "improper list")))) - (if (null? h) - n - (error who "improper list"))))) - (define ormap1 - (lambda (f a d n) - (cond - [(pair? d) - (if ($fxzero? n) - (error who "list was altered!") - (or (f a) - (ormap1 f ($car d) ($cdr d) ($fxsub1 n))))] - [(null? d) - (if ($fxzero? n) - (f a) - (error who "list was altered"))] - [else (error who "list was altered")]))) - (primitive-set! 'ormap - (case-lambda - [(f ls) - (unless (procedure? f) - (error who "~s is not a procedure" f)) - (cond - [(pair? ls) - (let ([d ($cdr ls)]) - (ormap1 f ($car ls) d (len d d 0)))] - [(null? ls) #f] - [else (error who "improper list")])] - [_ (error who "vararg not supported yet")]))) - - - - -(let () - (define reverse - (lambda (h t ls ac) - (if (pair? h) - (let ([h ($cdr h)] [a1 ($car h)]) - (if (pair? h) - (if (not (eq? h t)) - (let ([a2 ($car h)]) - (reverse ($cdr h) ($cdr t) ls (cons a2 (cons a1 ac)))) - (error 'append "circular list ~s" ls)) - (if (null? h) - (cons a1 ac) - (error 'append "~s is not a proper list" ls)))) - (if (null? h) - ac - (error 'append "~s is not a proper list" ls))))) - (define revcons - (lambda (ls ac) - (cond - [(null? ls) ac] - [else - (revcons ($cdr ls) (cons ($car ls) ac))]))) - (define append - (lambda (ls ls*) - (cond - [(null? ls*) ls] - [else - (revcons (reverse ls ls ls '()) - (append ($car ls*) ($cdr ls*)))]))) - (primitive-set! 'append - (lambda (ls . ls*) - (append ls ls*)))) - - -(primitive-set! 'list->vector - (letrec ([race - (lambda (h t ls n) - (if (pair? h) - (let ([h ($cdr h)]) - (if (pair? h) - (if (not (eq? h t)) - (race ($cdr h) ($cdr t) ls ($fx+ n 2)) - (error 'list->vector "circular list ~s" ls)) - (if (null? h) - ($fx+ n 1) - (error 'list->vector "~s is not a proper list" ls)))) - (if (null? h) - n - (error 'list->vector "~s is not a proper list" ls))))] - [fill - (lambda (v i ls) - (cond - [(null? ls) v] - [else - (let ([c ($car ls)]) - ($vector-set! v i c) - (fill v ($fxadd1 i) (cdr ls)))]))]) - (lambda (ls) - (let ([n (race ls ls ls 0)]) - (let ([v (make-vector n)]) - (fill v 0 ls)))))) - - -(let () - (define f - (lambda (v i ls) - (cond - [($fx< i 0) ls] - [else - (f v ($fxsub1 i) (cons ($vector-ref v i) ls))]))) - (primitive-set! 'vector->list - (lambda (v) - (if (vector? v) - (let ([n ($vector-length v)]) - (if ($fxzero? n) - '() - (f v ($fxsub1 n) '()))) - (error 'vector->list "~s is not a vector" v))))) - -(let () - (define f - (lambda (n fill ls) - (cond - [($fxzero? n) ls] - [else - (f ($fxsub1 n) fill (cons fill ls))]))) - (primitive-set! 'make-list - (case-lambda - [(n) - (if (and (fixnum? n) ($fx>= n 0)) - (f n (void) '()) - (error 'make-list "~s is not a valid length" n))] - [(n fill) - (if (and (fixnum? n) ($fx>= n 0)) - (f n fill '()) - (error 'make-list "~s is not a valid length" n))]))) - -(primitive-set! 'list (lambda x x)) - -(primitive-set! 'uuid - (lambda () - (let ([s (make-string 36)]) - (foreign-call "ik_uuid" s)))) - -(primitive-set! 'gensym->unique-string - (lambda (x) - (unless (symbol? x) - (error 'gensym->unique-string "~s is not a gensym" x)) - (let ([us ($symbol-unique-string x)]) - (cond - [(string? us) us] - [(eq? us #t) - (error 'gensym->unique-string "~s is not a gensym" x)] - [else - (let ([id (uuid)]) - ($set-symbol-unique-string! x id) - id)])))) - -(primitive-set! 'gensym-prefix - (make-parameter - "g" - (lambda (x) - (unless (string? x) - (error 'gensym-prefix "~s is not a string" x)) - x))) - -(primitive-set! 'gensym-count - (make-parameter - 0 - (lambda (x) - (unless (and (fixnum? x) ($fx>= x 0)) - (error 'gensym-count "~s is not a valid count" x)) - x))) - -(primitive-set! 'print-gensym - (make-parameter - #t - (lambda (x) - (unless (boolean? x) - (error 'print-gensym "~s is not a boolean" x)) - x))) - -;; X (primitive-set! 'make-hash-table -;; X (lambda () -;; X (make-hash-table))) -;; X -;; X (primitive-set! 'hash-table? -;; X (lambda (x) -;; X (hash-table? x))) -;; X -;; X (primitive-set! 'get-hash-table -;; X (lambda (h k v) -;; X (foreign-call "ik_get_hash_table" h k v))) -;; X -;; X (primitive-set! 'put-hash-table! -;; X (lambda (h k v) -;; X (foreign-call "ik_put_hash_table" h k v))) - -(primitive-set! 'bwp-object? - (lambda (x) - (bwp-object? x))) - -(primitive-set! 'weak-cons - (lambda (a d) - (foreign-call "ikrt_weak_cons" a d))) - -(primitive-set! 'weak-pair? - (lambda (x) - (and (pair? x) - (foreign-call "ikrt_is_weak_pair" x)))) - -(primitive-set! 'pointer-value - (lambda (x) - (pointer-value x))) - diff --git a/src/libcore-6.9.ss b/src/libcore-6.9.ss index 680b691..5a655b2 100644 --- a/src/libcore-6.9.ss +++ b/src/libcore-6.9.ss @@ -1036,7 +1036,9 @@ [(s) (if (string? s) ($make-symbol s) - (error 'gensym "~s is not a string" s))])) + (if (symbol? s) + ($make-symbol ($symbol-string s)) + (error 'gensym "~s is neither a string nor a symbol" s)))])) (primitive-set! 'putprop (lambda (x k v) diff --git a/src/libcore.fasl b/src/libcore.fasl index 13bff9c..c6b5b55 100644 Binary files a/src/libcore.fasl and b/src/libcore.fasl differ diff --git a/src/libcxr.fasl b/src/libcxr.fasl index 0405654..fa9ce73 100644 Binary files a/src/libcxr.fasl and b/src/libcxr.fasl differ diff --git a/src/libexpand-6.0.ss b/src/libexpand-6.0.ss deleted file mode 100644 index ea4127d..0000000 --- a/src/libexpand-6.0.ss +++ /dev/null @@ -1,1061 +0,0 @@ - -;;; Extended: cond case - -;;; -;;; -;;; Expand : Scheme -> Core Scheme -;;; -;;; ::= (quote datum) -;;; | -;;; | (if ) -;;; | (set! ) -;;; | (begin ...) -;;; | (letrec ([ ] ...) ...) -;;; | (lambda ...) -;;; | ( ...) -;;; | (#primitive| ) -;;; | ( ...) -;;; ::= () -;;; | -;;; | ( . ) -;;; ::= void | memv | top-level-value | set-top-level-value! -;;; | primitive-set! '| foreign-call | $apply -;;; -;;; -;;; Handled keywords: -;;; Core: lambda set! if quote begin define -;;; Extended: let let* letrec letrec* when unless or and cond case -;;; define-record record-case - - -(let () - (define *keyword* (gensym "*keyword*")) - (define build-void - (lambda () - (build-application (build-primref 'void) '()))) - (define build-primref - (lambda (x) - (list '|#primitive| x))) - (define build-global-assignment - (lambda (x val) - (list 'set-top-level-value! - (build-constant x) val))) - (define build-foreign-call - (lambda (name rand*) - (cons 'foreign-call - (cons name rand*)))) - (define build-apply - (lambda (proc rand*) - (cons '$apply - (cons proc rand*)))) - (define build-global-reference - (lambda (x) - (list 'top-level-value (build-constant x)))) - (define build-memv - (lambda (x ls) - (list 'memv x ls))) - (define build-application - (lambda (fun arg*) - (cons fun arg*))) - (define build-sequence - (lambda (a b) - (let ([a* - (if (and (pair? a) (eq? (car a) 'begin)) - (cdr a) - (list a))] - [b* - (if (and (pair? b) (eq? (car b) 'begin)) - (cdr b) - (list b))]) - (cons 'begin (append a* b*))))) - (define sequence - (lambda args - (if (null? args) - (build-void) - (let f ([a (car args)] [args (cdr args)]) - (cond - [(null? args) a] - [else - (build-sequence a (f (car args) (cdr args)))]))))) - (define build-constant - (lambda (x) (list 'quote x))) - (define build-lexical-reference - (lambda (x) x)) - (define build-lexical-assignment - (lambda (lhs rhs) - (list 'set! lhs rhs))) - (define build-conditional - (lambda (test conseq altern) - (list 'if test conseq altern))) - (define build-function - (lambda (fml* body) - (list 'lambda fml* body))) - (define build-assignments - (lambda (lhs* rhs* body) - (cond - [(null? lhs*) body] - [else - (build-sequence - (build-lexical-assignment (car lhs*) (car rhs*)) - (build-assignments (cdr lhs*) (cdr rhs*) body))]))) - (define build-letrec - (lambda (lhs* rhs* body) - (if (null? lhs*) - body - (let ([g* (map (lambda (x) (gensym)) lhs*)]) - (build-let lhs* (map (lambda (x) (build-void)) lhs*) - (build-let g* rhs* - (build-assignments lhs* g* body))))))) - (define build-letrec* - (lambda (lhs* rhs* body) - (if (null? lhs*) - body - (build-let lhs* (map (lambda (x) (build-void)) lhs*) - (build-assignments lhs* rhs* body))))) - (define build-let - (lambda (lhs* rhs* body) - (build-application - (build-function lhs* body) - rhs*))) - (define build-let* - (lambda (lhs* rhs* body) - (cond - [(null? lhs*) body] - [else - (build-let (list (car lhs*)) (list (car rhs*)) - (build-let* (cdr lhs*) (cdr rhs*) body))]))) - ;;; builds - (define keyword? - (lambda (x) (getprop x *keyword*))) - (define self-evaluating? - (lambda (x) - (or (immediate? x) (string? x)))) - (define syntax-error - (lambda (x) - (error 'expand "invalid syntax ~s" x))) - (define empty-env '()) - (define E* - (lambda (x* env) - (cond - [(null? x*) '()] - [else - (cons (E (car x*) env) (E* (cdr x*) env))]))) - (define lookup - (lambda (x env) - (cond - [(assq x env) => cdr] - [else #f]))) - (define bug - (lambda (str . args) - (error 'bug "~a ~a" str args))) - ;;; - (define E-quote - (lambda (d env x) - (unless (fx= (length d) 1) - (syntax-error x)) - (build-constant (car d)))) - ;;; - (define E-if - (lambda (d env x) - (let ([n (length d)]) - (cond - [(fx= n 2) - (build-conditional - (E (car d) env) - (E (cadr d) env) - (build-void))] - [(fx= n 3) - (build-conditional - (E (car d) env) - (E (cadr d) env) - (E (caddr d) env))] - [else (syntax-error x)])))) - ;;; - (define E-set! - (lambda (d env x) - (unless (fx= (length d) 2) (syntax-error x)) - (let ([lhs (car d)] [rhs (cadr d)]) - (unless (symbol? lhs) (syntax-error x)) - (cond - [(lookup lhs env) => - (lambda (b) - (build-lexical-assignment b (E rhs env)))] - [(keyword? lhs) (syntax-error x)] - [else - (build-global-assignment lhs (E rhs env))])))) - ;;; - (define E-begin - (lambda (d env x) - (unless (fx>= (length d) 1) - (syntax-error x)) - (E-begin^ (car d) (cdr d) env))) - (define E-begin^ - (lambda (a d env) - (cond - [(null? d) (E a env)] - [else - (build-sequence - (E a env) - (E-begin^ (car d) (cdr d) env))]))) - ;;; - (define E-named-let - (lambda (name d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([bindings (car d)] [body* (cdr d)]) - (verify-bindings bindings x) - (let ([lhs* (map car bindings)] - [rhs* (map cadr bindings)]) - (verify-fml* lhs* x) - (let ([rator - (let ([gname (gensym)] - [nlhs* (map (lambda (x) (gensym)) lhs*)]) - (let ([env - (extend-env-fml* lhs* nlhs* - (cons (cons name gname) env))]) - (let ([body (E-internal body* env x)]) - (let ([fun (build-function nlhs* body)]) - (build-letrec - (list gname) - (list fun) - (build-lexical-reference gname))))))] - [rand* (map (lambda (x) (E x env)) rhs*)]) - (build-application rator rand*)))))) - ;;; - (define E-let - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([bindings (car d)] [body* (cdr d)]) - (cond - [(symbol? bindings) - (E-named-let bindings body* env x)] - [else - (verify-bindings bindings x) - (let ([lhs* (map car bindings)] - [rhs* (map cadr bindings)]) - (verify-fml* lhs* x) - (let ([nlhs* (map (lambda (x) (gensym)) lhs*)]) - (let ([nrhs* (map (lambda (x) (E x env)) rhs*)]) - (let ([env (extend-env-fml* lhs* nlhs* env)]) - (build-let nlhs* nrhs* (E-internal body* env x))))))])))) - (define verify-bindings - (lambda (b* x) - (unless (list? b*) (syntax-error x)) - (for-each - (lambda (b) - (unless (and (list? b) - (fx= (length b) 2) - (symbol? (car b))) - (syntax-error x))) - b*))) - ;;; - (define E-let* - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([bindings (car d)] [body* (cdr d)]) - (verify-bindings bindings x) - (let ([lhs* (map car bindings)] - [rhs* (map cadr bindings)]) - (let ([nlhs* (map (lambda (x) (gensym)) lhs*)]) - (let f ([lhs* lhs*] [nlhs* nlhs*] [rhs* rhs*] [env env]) - (cond - [(null? lhs*) (E-internal body* env x)] - [else - (build-let (list (car nlhs*)) - (list (E (car rhs*) env)) - (f (cdr lhs*) (cdr nlhs*) (cdr rhs*) - (cons (cons (car lhs*) (car nlhs*)) env)))]))))))) - ;;; - (define E-letrec - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([bindings (car d)] [body* (cdr d)]) - (verify-bindings bindings x) - (let ([lhs* (map car bindings)] - [rhs* (map cadr bindings)]) - (verify-fml* lhs* x) - (let ([nlhs* (map (lambda (x) (gensym)) lhs*)]) - (let ([env (extend-env-fml* lhs* nlhs* env)]) - (let ([nrhs* (map (lambda (x) (E x env)) rhs*)]) - (build-letrec nlhs* nrhs* (E-internal body* env x))))))))) - ;;; - (define E-letrec* - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([bindings (car d)] [body* (cdr d)]) - (verify-bindings bindings x) - (let ([lhs* (map car bindings)] - [rhs* (map cadr bindings)]) - (verify-fml* lhs* x) - (let ([nlhs* (map (lambda (x) (gensym)) lhs*)]) - (let ([env (extend-env-fml* lhs* nlhs* env)]) - (let ([nrhs* (map (lambda (x) (E x env)) rhs*)]) - (build-letrec* nlhs* nrhs* (E-internal body* env x))))))))) - ;;; - (define E-let-values - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([bindings (car d)] [body* (cdr d)]) - (unless (list? bindings) (syntax-error x)) - (let f ([bindings bindings] [nenv env]) - (cond - [(null? bindings) (E-internal body* nenv x)] - [else - (let ([b (car bindings)]) - (unless (and (list? b) (fx= (length b) 2)) - (syntax-error x)) - (let ([fml* (car b)] [rhs (cadr b)]) - (verify-fml* fml* x) - (let ([nfml* (gen-fml* fml*)]) - (let ([nenv (extend-env-fml* fml* nfml* nenv)]) - (build-application - (build-primref 'call-with-values) - (list (build-function '() - (E rhs env)) - (build-function nfml* - (f (cdr bindings) nenv))))))))]))))) - ;;; - (define E-parameterize - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([bindings (car d)] [body* (cdr d)]) - (cond - [(null? bindings) - (E-internal body* env x)] - [else - (unless (and (list? bindings) - (andmap (lambda (b) - (and (list? b) (fx= (length b) 2))) - bindings)) - (syntax-error x)) - (let ([lhs* (map car bindings)] [rhs* (map cadr bindings)]) - (let ([nlhs* (map (lambda (x) (gensym)) lhs*)] - [nrhs* (map (lambda (x) (gensym)) lhs*)] - [swap (gensym)] - [t* (map (lambda (x) (gensym)) lhs*)]) - (build-let - (append nlhs* nrhs*) - (map (lambda (x) (E x env)) - (append lhs* rhs*)) - (build-let - (list swap) - (list - (build-function '() - (apply sequence - (map (lambda (t lhs/rhs) - ;;; FIXME: vararg map - (define nlhs (car lhs/rhs)) - (define nrhs (cdr lhs/rhs)) - (build-let - (list t) - (list (build-application - (build-lexical-reference nlhs) - '())) - (build-sequence - (build-application - (build-lexical-reference nlhs) - (list (build-lexical-reference nrhs))) - (build-lexical-assignment - nrhs - (build-lexical-reference t))))) - t* (map cons nlhs* nrhs*))))) - (build-application - (build-primref 'dynamic-wind) - (list - (build-lexical-reference swap) - (build-function - '() - (E-internal body* env x)) - (build-lexical-reference swap)))))))])))) - ;;; - (define E-lambda - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([fml* (car d)] [body* (cdr d)]) - (verify-fml* fml* x) - (let ([nfml* (gen-fml* fml*)]) - (let ([env (extend-env-fml* fml* nfml* env)]) - (build-function - nfml* - (E-internal body* env x))))))) - (define verify-fml* - (lambda (fml* x) - (let ([g (gensym)]) - (let f ([fml* fml*]) - (cond - [(pair? fml*) - (let ([a (car fml*)]) - (unless (symbol? a) (syntax-error x)) - (when (getprop a g) (syntax-error x)) - (putprop a g a) - (f (cdr fml*)) - (remprop a g))] - [(symbol? fml*) - (when (getprop fml* g) (syntax-error x))] - [(null? fml*) (void)] - [else (syntax-error x)]))))) - (define gen-fml* - (lambda (fml*) - (cond - [(pair? fml*) - (cons (gensym) (gen-fml* (cdr fml*)))] - [(symbol? fml*) (gensym)] - [else '()]))) - (define extend-env-fml* - (lambda (fml* nfml* env) - (cond - [(pair? fml*) - (cons (cons (car fml*) (car nfml*)) - (extend-env-fml* (cdr fml*) (cdr nfml*) env))] - [(symbol? fml*) - (cons (cons fml* nfml*) env)] - [else env]))) - ;;; - (define E-internal - (lambda (body* env x) - (let f ([a (car body*)] [body* (cdr body*)] [lhs* '()] [rhs* '()]) - (cond - [(and (pair? a) (symbol? (car a))) - (let ([fst (car a)]) - (cond - [(or (memq fst lhs*) (lookup a env)) - (E-internal-done a body* lhs* rhs* env)] - [(keyword? fst) - (cond - [(eq? fst 'begin) - (let ([d (cdr a)]) - (unless (list? d) (syntax-error x)) - (let ([body* (append d body*)]) - (if (null? body*) - (syntax-error x) - (f (car body*) (cdr body*) lhs* rhs*))))] - [(eq? fst 'define) - (let ([def (parse-define (cdr a) env fst)]) - (f (car body*) (cdr body*) - (cons (car def) lhs*) - (cons (cdr def) rhs*)))] - [else (E-internal-done a body* lhs* rhs* env)])] - [else (E-internal-done a body* lhs* rhs* env)]))] - [else (E-internal-done a body* lhs* rhs* env)])))) - (define parse-define - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([fst (car d)] [rest (cdr d)]) - (cond - [(symbol? fst) - (unless (fx= (length rest) 1) (syntax-error x)) - (list fst 'expr (car rest))] - [(pair? fst) - (unless (symbol? (car fst)) (syntax-error x)) - (verify-fml* (cdr fst) x) - (list (car fst) 'defun (cdr fst) rest)] - [else (syntax-error x)])))) - (define E-def - (lambda (x env) - (let ([type (car x)]) - (cond - [(eq? type 'expr) (E (cadr x) env)] - [(eq? type 'defun) - (let ([fml* (cadr x)] [body* (caddr x)]) - (let ([nfml* (gen-fml* fml*)]) - (let ([env (extend-env-fml* fml* nfml* env)]) - (build-function nfml* - (E-internal body* env x)))))] - [else (bug "invalid type" x)])))) - (define E-internal-done - (lambda (a d lhs* rhs* env) - (if (null? lhs*) - (E-begin^ a d env) - (let ([nlhs* (map (lambda (x) (gensym)) lhs*)]) - (let ([env (append (map cons lhs* nlhs*) env)]) - (let ([nrhs* (map (lambda (x) (E-def x env)) rhs*)]) - (build-letrec* nlhs* nrhs* (E-begin^ a d env)))))))) - ;;; - (define E-when - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([test (car d)] [body* (cdr d)]) - (build-conditional - (E test env) - (E-begin^ (car body*) (cdr body*) env) - (build-void))))) - ;;; - (define E-unless - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([test (car d)] [body* (cdr d)]) - (build-conditional - (E test env) - (build-void) - (E-begin^ (car body*) (cdr body*) env))))) - ;;; - (define E-or - (lambda (d env x) - (cond - [(null? d) (build-constant #f)] - [(null? (cdr d)) (E (car d) env)] - [else - (let ([t (gensym)]) - (build-let (list t) (list (E (car d) env)) - (build-conditional - (build-lexical-reference t) - (build-lexical-reference t) - (E-or (cdr d) env x))))]))) - ;;; - (define E-and - (lambda (d env x) - (cond - [(null? d) (build-constant #t)] - [(null? (cdr d)) (E (car d) env)] - [else - (build-conditional - (E (car d) env) - (E-and (cdr d) env x) - (build-constant #f))]))) - ;;; - (define E-case - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([val (car d)] [cls* (cdr d)]) - (let ([g (gensym)]) - (build-let (list g) - (list (E val env)) - (E-case-cls* g (car cls*) (cdr cls*) env x)))))) - (define E-case-cls* - (lambda (g cls cls* env x) - (cond - [(null? cls*) (E-case-cls-last g cls env x)] - [else - (unless (and (list? cls) (fx>= (length cls) 2)) - (syntax-error x)) - (let ([ls (car cls)] [b* (cdr cls)]) - (unless (list? ls) (syntax-error x)) - (build-conditional - (build-memv (build-lexical-reference g) - (build-constant ls)) - (E-begin^ (car b*) (cdr b*) env) - (E-case-cls* g (car cls*) (cdr cls*) env x)))]))) - (define E-case-cls-last - (lambda (g cls env x) - (unless (and (list? cls) (fx>= (length cls) 2)) - (syntax-error x)) - (let ([fst (car cls)] [b* (cdr cls)]) - (cond - [(and (eq? fst 'else) - (not (lookup fst env))) - (E-begin^ (car b*) (cdr b*) env)] - [(list? fst) - (build-conditional - (build-memv (build-lexical-reference g) - (build-constant fst)) - (E-begin^ (car b*) (cdr b*) env) - (build-void))] - [else (syntax-error x)])))) - ;;; - (define E-cond - (lambda (d env x) - (unless (fx>= (length d) 1) (syntax-error x)) - (E-cond-cls* (car d) (cdr d) env x))) - (define E-cond-cls* - (lambda (cls cls* env x) - (cond - [(null? cls*) (E-cond-cls-last cls env x)] - [else - (E-cond-cls cls env x - (E-cond-cls* (car cls*) (cdr cls*) env x))]))) - (define E-cond-cls - (lambda (cls env x k) - (unless (list? cls) (syntax-error x)) - (let ([n (length cls)]) - (unless (fx>= n 1) (syntax-error x)) - (cond - [(fx= n 1) - (let ([g (gensym)]) - (build-let (list g) - (list (E (car cls) env)) - (build-conditional - (build-lexical-reference g) - (build-lexical-reference g) - k)))] - [(and (fx= n 3) - (eq? (cadr cls) '=>) - (not (lookup '=> env))) - (let ([g (gensym)]) - (build-let (list g) - (list (E (car cls) env)) - (build-conditional - (build-lexical-reference g) - (build-application - (E (caddr cls) env) - (list (build-lexical-reference g))) - k)))] - [else - (let ([test (car cls)] [body* (cdr cls)]) - (build-conditional - (E test env) - (E-begin^ (car body*) (cdr body*) env) - k))])))) - (define E-cond-cls-last - (lambda (cls env x) - (unless (list? cls) (syntax-error x)) - (cond - [(and (fx>= (length cls) 2) - (eq? (car cls) 'else) - (not (lookup 'else env))) - (let ([body* (cdr cls)]) - (E-begin^ (car body*) (cdr body*) env))] - [else (E-cond-cls cls env x (build-void))]))) - ;;; - (define E-quasiquote - (lambda (d env x) - (unless (fx= (length d) 1) (syntax-error x)) - (let ([expr (car d)]) - (Eqq expr 0 env x - (lambda (what expr^) - (case what - [(splice) (syntax-error x)] - [(unquot) expr^] - [(quoted) expr^] - [else (error 'quasiquote "what ~s" what)])))))) - (define qqmacro? - (lambda (sym expr env) - (and (pair? expr) - (eq? (car expr) sym) - (let ([d (cdr expr)]) - (and (pair? d) (null? (cdr d)))) - (not (lookup sym env))))) - (define Eqq - (lambda (x depth env orig k) - (cond - [(qqmacro? 'unquote x env) - (if (fx= depth 0) - (k 'unquot (E (cadr x) env)) - (Eqq (cadr x) (fx- depth 1) env orig - (lambda (what v) - (case what - [(splice) - (k 'unquot (qqbuild 'cons (build-constant 'unquote) v))] - [(unquot) - (k 'unquot (qqbuild 'list (build-constant 'unquote) v))] - [(quoted) - (k 'quoted (build-constant x))] - [else (error 'quasiquote "what ~s" what)]))))] - [(qqmacro? 'unquote-splicing x env) - (if (fx= depth 0) - (k 'splice (E (cadr x) env)) - (Eqq (cadr x) (fx- depth 1) env orig - (lambda (what v) - (case what - [(splice) - (k 'splice - (qqbuild 'cons (build-constant 'unquote-splicing) v))] - [(unquot) - (k 'splice - (qqbuild 'list (build-constant 'unquote-splicing) v))] - [(quoted) - (k 'quoted (build-constant x))] - [else (error 'quasiquote "what ~s" what)]))))] - [(qqmacro? 'quasiquote x env) - (Eqq (cadr x) (fx+ depth 1) env orig - (lambda (what v) - (case what - [(splice) - (k 'unquot - (qqbuild 'cons (build-constant 'quasiquote) v))] - [(unquot) - (k 'unquot - (qqbuild 'list (build-constant 'quasiquote) v))] - [(quoted) - (k 'quoted (build-constant x))] - [else (error 'quasiquote "what ~s" what)])))] - [(pair? x) - (Eqq (car x) depth env orig - (lambda (what-a v-a) - (Eqq (cdr x) depth env orig - (lambda (what-d v-d) - (case what-a - [(splice) - (case what-d - [(splice) (syntax-error x)] - [(unquot) - (k 'unquot (qqbuild 'append v-a v-d))] - [(quoted) - (k 'unquot (qqbuild 'append v-a v-d))] - [else (error 'quasiquote "what ~s" what-d)])] - [(unquot) - (case what-d - [(splice) (syntax-error x)] - [(unquot) - (k 'unquot (qqbuild 'cons v-a v-d))] - [(quoted) - (k 'unquot (qqbuild 'cons v-a v-d))] - [else (error 'quasiquote "what ~s" what-d)])] - [(quoted) - (case what-d - [(splice) (syntax-error x)] - [(unquot) - (k 'unquot (qqbuild 'cons v-a v-d))] - [(quoted) - (k 'quoted (build-constant x))] - [else (error 'quasiquote "what ~s" what-d)])] - [else (error 'quasiquote "what ~s" what-a)])))))] - [(vector? x) - (let () - (define vmap-list - (lambda (i ac) - (cond - [(fx= i -1) - (k 'unquot (qqbuild 'list->vector ac))] - [else - (Eqq (vector-ref x i) depth env orig - (lambda (what vi) - (case what - [(splice) - (vmap-list (fx- i 1) - (qqbuild 'append vi ac))] - [(unquot) - (vmap-list (fx- i 1) (qqbuild 'cons vi ac))] - [(quoted) - (vmap-list (fx- i 1) (qqbuild 'cons vi ac))] - [else (error 'quasiquote "what ~s" what)])))]))) - (define vmap-vec - (lambda (i ac) - (cond - [(fx= i -1) - (k 'unquot - (build-application - (build-primref 'vector) - ac))] - [else - (Eqq (vector-ref x i) depth env orig - (lambda (what vi) - (case what - [(splice) - (vmap-list (fx- i 1) - (qqbuild 'append vi - (build-application - (build-primref 'list) - ac)))] - [(unquot) - (vmap-vec (fx- i 1) (cons vi ac))] - [(quoted) - (vmap-vec (fx- i 1) (cons vi ac))] - [else (error 'quasiquote "what ~s" what)])))]))) - (define vmap-const - (lambda (i ac) - (cond - [(fx= i -1) (k 'quoted (build-constant x))] - [else - (Eqq (vector-ref x i) depth env orig - (lambda (what vi) - (case what - [(splice) - (if (null? ac) - (vmap-list (fx- i 1) vi) - (vmap-list (fx- i 1) - (qqbuild 'append vi (build-constant ac))))] - [(unquot) - (vmap-vec (fx- i 1) - (cons vi (map build-constant ac)))] - [(quoted) - (vmap-const (fx- i 1) - (cons (vector-ref x i) ac))] - [else (error 'quasiquote "what ~s" what)])))]))) - (vmap-const (fx- (vector-length x) 1) '()))] - [else (k 'quoted (build-constant x))]))) - (define qqbuild - (lambda (prim . args) - (build-application - (build-primref prim) - args))) - ;;; - (define E-record-case - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([val (car d)] [cls* (cdr d)]) - (let ([g (gensym)]) - (build-let - (list g) - (list (E val env)) - (E-record-case-cls* (car cls*) (cdr cls*) g env x)))))) - (define E-record-case-cls* - (lambda (cls cls* v env x) - (cond - [(null? cls*) (E-record-case-last-cls cls v env x)] - [else - (E-record-case-cls cls v env x - (E-record-case-cls* (car cls*) (cdr cls*) v env x))]))) - (define E-record-case-cls - (lambda (cls v env x k) - (unless (and (list? cls) (fx>= (length cls) 2)) - (syntax-error x)) - (let ([pat (car cls)] [body* (cdr cls)]) - (unless (and (list? pat) (andmap symbol? pat) (fx>= (length pat) 1)) - (syntax-error x)) - (let ([rtd-name (car pat)] [vars (cdr pat)]) - (cond - [(lookup rtd-name env) (syntax-error x)] - [(getprop rtd-name *keyword*) => - (lambda (type) - (unless (and (pair? type) (eq? (car type) '$rtd)) - (syntax-error x)) - (let ([rtd (cdr type)] - [lhs* (map (lambda (x) (gensym)) vars)]) - (build-conditional - (build-application - (build-application - (build-primref 'record-predicate) - (list (build-constant rtd))) - (list (build-lexical-reference v))) - (build-let - lhs* - (map (lambda (i) - (build-application - (build-application - (build-primref 'record-field-accessor) - (list (build-constant rtd) - (build-constant i))) - (list (build-lexical-reference v)))) - (enumerate lhs*)) - (E-begin^ (car body*) (cdr body*) - (extend-env-fml* vars lhs* env))) - k)))] - [else (syntax-error x)]))))) - (define E-record-case-last-cls - (lambda (cls v env x) - (unless (and (list? cls) (fx>= (length cls) 2)) - (syntax-error x)) - (let ([pat (car cls)] [body* (cdr cls)]) - (cond - [(and (eq? pat 'else) (not (lookup 'else env))) - (E-begin^ (car body*) (cdr body*) env)] - [else - (E-record-case-cls cls v env x - (build-application - (build-primref 'error) - (list - (build-constant 'record-case) - (build-constant "unmatched ~s in ~s") - (build-lexical-reference v) - (build-constant x))))])))) - ;;; - (define E-foreign-call - (lambda (d env x) - (unless (fx>= (length d) 1) (syntax-error x)) - (build-foreign-call - (E (car d) env) - (map (lambda (x) (E x env)) (cdr d))))) - ;;; - (define E-primref - (lambda (d env x) - (unless (fx= (length d) 1) (syntax-error x)) - (let ([sym (car d)]) - (unless (symbol? sym) (syntax-error x)) - (cond - [(primitive? sym) (build-primref sym)] - [else (syntax-error x)])))) - ;;; - (define E-apply - (lambda (d env x) - (unless (fx>= (length d) 1) (syntax-error x)) - (build-apply - (E (car d) env) - (map (lambda (x) (E x env)) (cdr d))))) - ;;; - (define E - (lambda (x env) - (cond - [(self-evaluating? x) (build-constant x)] - [(symbol? x) - (cond - [(lookup x env) => - (lambda (b) - (build-lexical-reference b))] - [(keyword? x) - (syntax-error x)] - [else - (build-global-reference x)])] - [(pair? x) - (let ([a (car x)] [d (cdr x)]) - (unless (list? d) (syntax-error x)) - (cond - [(symbol? a) - (cond - [(lookup a env) => - (lambda (b) - (build-application - (build-lexical-reference b) - (E* d env)))] - [(keyword? a) - (cond - [(eq? a 'quote) (E-quote d env x)] - [(eq? a 'if) (E-if d env x)] - [(eq? a 'set!) (E-set! d env x)] - [(eq? a 'begin) (E-begin d env x)] - [(eq? a 'lambda) (E-lambda d env x)] - [(eq? a 'let) (E-let d env x)] - [(eq? a 'letrec) (E-letrec d env x)] - [(eq? a 'let*) (E-let* d env x)] - [(eq? a 'letrec*) (E-letrec* d env x)] - [(eq? a 'when) (E-when d env x)] - [(eq? a 'unless) (E-unless d env x)] - [(eq? a 'or) (E-or d env x)] - [(eq? a 'and) (E-and d env x)] - [(eq? a 'case) (E-case d env x)] - [(eq? a 'cond) (E-cond d env x)] - [(eq? a 'let-values) (E-let-values d env x)] - [(eq? a 'quasiquote) (E-quasiquote d env x)] - [(eq? a 'parameterize) (E-parameterize d env x)] - [(eq? a 'record-case) (E-record-case d env x)] - [(eq? a 'foreign-call) (E-foreign-call d env x)] - [(eq? a '|#primitive|) (E-primref d env x)] - [(eq? a '$apply) (E-apply d env x)] - [else (syntax-error x)])] - [else - (build-application - (build-global-reference a) - (E* d env))])] - [else - (build-application - (E a env) - (E* d env))]))] - [else (syntax-error x)]))) - ;;; - (define E*-top - (lambda (x x*) - (cond - [(null? x*) (E-top x)] - [else - (let ([x (E-top x)]) - (build-sequence x (E*-top (car x*) (cdr x*))))]))) - ;;; - (define E-top-level-define - (lambda (d ctxt) - (let ([def (parse-define d empty-env ctxt)]) - (let ([lhs (car def)] [rhs (cdr def)]) - (remprop lhs *keyword*) - (build-global-assignment lhs - (E-def rhs empty-env)))))) - ;;; - (define enumerate - (lambda (ls) - (let f ([ls ls] [i 0]) - (cond - [(null? ls) '()] - [else (cons i (f (cdr ls) (fxadd1 i)))])))) - (define E-top-level-define-record - (lambda (d x) - (unless (fx= (length d) 2) (syntax-error x)) - (let ([name (car d)] [fields (cadr d)]) - (unless (symbol? name) (syntax-error x)) - (unless (and (list? fields) - (andmap symbol? fields)) - (syntax-error x)) - (let ([str (symbol->string name)]) - (let ([rtd (make-record-type str fields)]) - (let ([constructor - (string->symbol (string-append "make-" str))] - [predicate - (string->symbol (string-append str "?"))] - [accessors - (map (lambda (field) - (string->symbol - (string-append str "-" (symbol->string field)))) - fields)] - [mutators - (map (lambda (field) - (string->symbol - (string-append "set-" str "-" - (symbol->string field) - "!"))) - fields)]) - (for-each - (lambda (x) (remprop x *keyword*)) - (cons constructor - (cons predicate - (append accessors mutators)))) - (putprop name *keyword* (cons '$rtd rtd)) - (sequence - (build-global-assignment - constructor - (build-application - (build-primref 'record-constructor) - (list (build-constant rtd)))) - (build-global-assignment - predicate - (build-application - (build-primref 'record-predicate) - (list (build-constant rtd)))) - (apply sequence - (map (lambda (accessor i) - (build-global-assignment - accessor - (build-application - (build-primref 'record-field-accessor) - (list (build-constant rtd) - (build-constant i))))) - accessors - (enumerate fields))) - (apply sequence - (map (lambda (mutator i) - (build-global-assignment - mutator - (build-application - (build-primref 'record-field-mutator) - (list (build-constant rtd) - (build-constant i))))) - mutators - (enumerate fields))) - ))))))) - ;;; - (define E-top - (lambda (x) - (cond - [(self-evaluating? x) - (build-constant x)] - [(symbol? x) - (when (keyword? x) (syntax-error x)) - (build-global-reference x)] - [(pair? x) - (let ([a (car x)] [d (cdr x)]) - (unless (list? d) (syntax-error x)) - (cond - [(and (symbol? a) (keyword? a)) - (cond - [(eq? a 'begin) - (if (null? d) - (build-void) - (E*-top (car d) (cdr d)))] - [(eq? a 'define) - (E-top-level-define d x)] - [(eq? a 'define-record) - (E-top-level-define-record d x)] - [else (E x empty-env)])] - [else - (build-application - (E a empty-env) - (E* d empty-env))]))] - [else (syntax-error x)]))) - ;;; - (primitive-set! 'core-expand E-top) - ;;; - (primitive-set! 'current-expand - (make-parameter - core-expand - (lambda (x) - (unless (procedure? x) - (error 'current-expand "~s is not a procedure" x)) - x))) - ;;; - (primitive-set! 'expand - (lambda (x) - ((current-expand) x))) - ;;; - (for-each - (lambda (x) - (putprop x *keyword* x)) - '(lambda set! let let* letrec letrec* if quote when unless set! begin - define or and cond case foreign-call $apply |#primitive| - define-record record-case - quasiquote unquote unquote-splicing let-values parameterize - ))) - diff --git a/src/libexpand-6.1.ss b/src/libexpand-6.1.ss deleted file mode 100644 index 5d7b137..0000000 --- a/src/libexpand-6.1.ss +++ /dev/null @@ -1,1074 +0,0 @@ - -;;; 6.1: case-lambda -;;; -;;; Extended: cond case - -;;; -;;; -;;; Expand : Scheme -> Core Scheme -;;; -;;; ::= (quote datum) -;;; | -;;; | (if ) -;;; | (set! ) -;;; | (begin ...) -;;; | (letrec ([ ] ...) ...) -;;; | (lambda ...) -;;; | ( ...) -;;; | (#primitive| ) -;;; | ( ...) -;;; ::= () -;;; | -;;; | ( . ) -;;; ::= void | memv | top-level-value | set-top-level-value! -;;; | primitive-set! '| foreign-call | $apply -;;; -;;; -;;; Handled keywords: -;;; Core: case-lambda lambda set! if quote begin define -;;; Extended: let let* letrec letrec* when unless or and cond case -;;; define-record record-case - - -(let () - (define *keyword* (gensym "*keyword*")) - (define build-void - (lambda () - (build-application (build-primref 'void) '()))) - (define build-primref - (lambda (x) - (list '|#primitive| x))) - (define build-global-assignment - (lambda (x val) - (list 'set-top-level-value! - (build-constant x) val))) - (define build-foreign-call - (lambda (name rand*) - (cons 'foreign-call - (cons name rand*)))) - (define build-apply - (lambda (proc rand*) - (cons '$apply - (cons proc rand*)))) - (define build-global-reference - (lambda (x) - (list 'top-level-value (build-constant x)))) - (define build-memv - (lambda (x ls) - (list 'memv x ls))) - (define build-application - (lambda (fun arg*) - (cons fun arg*))) - (define build-sequence - (lambda (a b) - (let ([a* - (if (and (pair? a) (eq? (car a) 'begin)) - (cdr a) - (list a))] - [b* - (if (and (pair? b) (eq? (car b) 'begin)) - (cdr b) - (list b))]) - (cons 'begin (append a* b*))))) - (define sequence - (lambda args - (if (null? args) - (build-void) - (let f ([a (car args)] [args (cdr args)]) - (cond - [(null? args) a] - [else - (build-sequence a (f (car args) (cdr args)))]))))) - (define build-constant - (lambda (x) (list 'quote x))) - (define build-lexical-reference - (lambda (x) x)) - (define build-lexical-assignment - (lambda (lhs rhs) - (list 'set! lhs rhs))) - (define build-conditional - (lambda (test conseq altern) - (list 'if test conseq altern))) - (define build-function - (lambda (fml* body) - (build-case-lambda (list (list fml* body))))) - (define build-case-lambda - (lambda (cases) - (cons 'case-lambda cases))) - (define build-assignments - (lambda (lhs* rhs* body) - (cond - [(null? lhs*) body] - [else - (build-sequence - (build-lexical-assignment (car lhs*) (car rhs*)) - (build-assignments (cdr lhs*) (cdr rhs*) body))]))) - (define build-letrec - (lambda (lhs* rhs* body) - (if (null? lhs*) - body - (let ([g* (map (lambda (x) (gensym)) lhs*)]) - (build-let lhs* (map (lambda (x) (build-void)) lhs*) - (build-let g* rhs* - (build-assignments lhs* g* body))))))) - (define build-letrec* - (lambda (lhs* rhs* body) - (if (null? lhs*) - body - (build-let lhs* (map (lambda (x) (build-void)) lhs*) - (build-assignments lhs* rhs* body))))) - (define build-let - (lambda (lhs* rhs* body) - (build-application - (build-function lhs* body) - rhs*))) - (define build-let* - (lambda (lhs* rhs* body) - (cond - [(null? lhs*) body] - [else - (build-let (list (car lhs*)) (list (car rhs*)) - (build-let* (cdr lhs*) (cdr rhs*) body))]))) - ;;; builds - (define keyword? - (lambda (x) (getprop x *keyword*))) - (define self-evaluating? - (lambda (x) - (or (immediate? x) (string? x)))) - (define syntax-error - (lambda (x) - (error 'expand "invalid syntax ~s" x))) - (define empty-env '()) - (define E* - (lambda (x* env) - (cond - [(null? x*) '()] - [else - (cons (E (car x*) env) (E* (cdr x*) env))]))) - (define lookup - (lambda (x env) - (cond - [(assq x env) => cdr] - [else #f]))) - (define bug - (lambda (str . args) - (error 'bug "~a ~a" str args))) - ;;; - (define E-quote - (lambda (d env x) - (unless (fx= (length d) 1) - (syntax-error x)) - (build-constant (car d)))) - ;;; - (define E-if - (lambda (d env x) - (let ([n (length d)]) - (cond - [(fx= n 2) - (build-conditional - (E (car d) env) - (E (cadr d) env) - (build-void))] - [(fx= n 3) - (build-conditional - (E (car d) env) - (E (cadr d) env) - (E (caddr d) env))] - [else (syntax-error x)])))) - ;;; - (define E-set! - (lambda (d env x) - (unless (fx= (length d) 2) (syntax-error x)) - (let ([lhs (car d)] [rhs (cadr d)]) - (unless (symbol? lhs) (syntax-error x)) - (cond - [(lookup lhs env) => - (lambda (b) - (build-lexical-assignment b (E rhs env)))] - [(keyword? lhs) (syntax-error x)] - [else - (build-global-assignment lhs (E rhs env))])))) - ;;; - (define E-begin - (lambda (d env x) - (unless (fx>= (length d) 1) - (syntax-error x)) - (E-begin^ (car d) (cdr d) env))) - (define E-begin^ - (lambda (a d env) - (cond - [(null? d) (E a env)] - [else - (build-sequence - (E a env) - (E-begin^ (car d) (cdr d) env))]))) - ;;; - (define E-named-let - (lambda (name d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([bindings (car d)] [body* (cdr d)]) - (verify-bindings bindings x) - (let ([lhs* (map car bindings)] - [rhs* (map cadr bindings)]) - (verify-fml* lhs* x) - (let ([rator - (let ([gname (gensym)] - [nlhs* (map (lambda (x) (gensym)) lhs*)]) - (let ([env - (extend-env-fml* lhs* nlhs* - (cons (cons name gname) env))]) - (let ([body (E-internal body* env x)]) - (let ([fun (build-function nlhs* body)]) - (build-letrec - (list gname) - (list fun) - (build-lexical-reference gname))))))] - [rand* (map (lambda (x) (E x env)) rhs*)]) - (build-application rator rand*)))))) - ;;; - (define E-let - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([bindings (car d)] [body* (cdr d)]) - (cond - [(symbol? bindings) - (E-named-let bindings body* env x)] - [else - (verify-bindings bindings x) - (let ([lhs* (map car bindings)] - [rhs* (map cadr bindings)]) - (verify-fml* lhs* x) - (let ([nlhs* (map (lambda (x) (gensym)) lhs*)]) - (let ([nrhs* (map (lambda (x) (E x env)) rhs*)]) - (let ([env (extend-env-fml* lhs* nlhs* env)]) - (build-let nlhs* nrhs* (E-internal body* env x))))))])))) - (define verify-bindings - (lambda (b* x) - (unless (list? b*) (syntax-error x)) - (for-each - (lambda (b) - (unless (and (list? b) - (fx= (length b) 2) - (symbol? (car b))) - (syntax-error x))) - b*))) - ;;; - (define E-let* - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([bindings (car d)] [body* (cdr d)]) - (verify-bindings bindings x) - (let ([lhs* (map car bindings)] - [rhs* (map cadr bindings)]) - (let ([nlhs* (map (lambda (x) (gensym)) lhs*)]) - (let f ([lhs* lhs*] [nlhs* nlhs*] [rhs* rhs*] [env env]) - (cond - [(null? lhs*) (E-internal body* env x)] - [else - (build-let (list (car nlhs*)) - (list (E (car rhs*) env)) - (f (cdr lhs*) (cdr nlhs*) (cdr rhs*) - (cons (cons (car lhs*) (car nlhs*)) env)))]))))))) - ;;; - (define E-letrec - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([bindings (car d)] [body* (cdr d)]) - (verify-bindings bindings x) - (let ([lhs* (map car bindings)] - [rhs* (map cadr bindings)]) - (verify-fml* lhs* x) - (let ([nlhs* (map (lambda (x) (gensym)) lhs*)]) - (let ([env (extend-env-fml* lhs* nlhs* env)]) - (let ([nrhs* (map (lambda (x) (E x env)) rhs*)]) - (build-letrec nlhs* nrhs* (E-internal body* env x))))))))) - ;;; - (define E-letrec* - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([bindings (car d)] [body* (cdr d)]) - (verify-bindings bindings x) - (let ([lhs* (map car bindings)] - [rhs* (map cadr bindings)]) - (verify-fml* lhs* x) - (let ([nlhs* (map (lambda (x) (gensym)) lhs*)]) - (let ([env (extend-env-fml* lhs* nlhs* env)]) - (let ([nrhs* (map (lambda (x) (E x env)) rhs*)]) - (build-letrec* nlhs* nrhs* (E-internal body* env x))))))))) - ;;; - (define E-let-values - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([bindings (car d)] [body* (cdr d)]) - (unless (list? bindings) (syntax-error x)) - (let f ([bindings bindings] [nenv env]) - (cond - [(null? bindings) (E-internal body* nenv x)] - [else - (let ([b (car bindings)]) - (unless (and (list? b) (fx= (length b) 2)) - (syntax-error x)) - (let ([fml* (car b)] [rhs (cadr b)]) - (verify-fml* fml* x) - (let ([nfml* (gen-fml* fml*)]) - (let ([nenv (extend-env-fml* fml* nfml* nenv)]) - (build-application - (build-primref 'call-with-values) - (list (build-function '() - (E rhs env)) - (build-function nfml* - (f (cdr bindings) nenv))))))))]))))) - ;;; - (define E-parameterize - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([bindings (car d)] [body* (cdr d)]) - (cond - [(null? bindings) - (E-internal body* env x)] - [else - (unless (and (list? bindings) - (andmap (lambda (b) - (and (list? b) (fx= (length b) 2))) - bindings)) - (syntax-error x)) - (let ([lhs* (map car bindings)] [rhs* (map cadr bindings)]) - (let ([nlhs* (map (lambda (x) (gensym)) lhs*)] - [nrhs* (map (lambda (x) (gensym)) lhs*)] - [swap (gensym)] - [t* (map (lambda (x) (gensym)) lhs*)]) - (build-let - (append nlhs* nrhs*) - (map (lambda (x) (E x env)) - (append lhs* rhs*)) - (build-let - (list swap) - (list - (build-function '() - (apply sequence - (map (lambda (t lhs/rhs) - ;;; FIXME: vararg map - (define nlhs (car lhs/rhs)) - (define nrhs (cdr lhs/rhs)) - (build-let - (list t) - (list (build-application - (build-lexical-reference nlhs) - '())) - (build-sequence - (build-application - (build-lexical-reference nlhs) - (list (build-lexical-reference nrhs))) - (build-lexical-assignment - nrhs - (build-lexical-reference t))))) - t* (map cons nlhs* nrhs*))))) - (build-application - (build-primref 'dynamic-wind) - (list - (build-lexical-reference swap) - (build-function - '() - (E-internal body* env x)) - (build-lexical-reference swap)))))))])))) - ;;; - (define E-lambda - (lambda (d env x) - (build-case-lambda - (list ((lambda-clause env x) d))))) - (define (lambda-clause env x) - (lambda (d) - (unless (and (list? d) (fx>= (length d) 2)) (syntax-error x)) - (let ([fml* (car d)] [body* (cdr d)]) - (verify-fml* fml* x) - (let ([nfml* (gen-fml* fml*)]) - (let ([env (extend-env-fml* fml* nfml* env)]) - (list nfml* (E-internal body* env x))))))) - (define E-case-lambda - (lambda (d env x) - (unless (fx>= (length d) 1) (syntax-error x)) - (build-case-lambda - (map (lambda-clause env x) d)))) - (define verify-fml* - (lambda (fml* x) - (let ([g (gensym)]) - (let f ([fml* fml*]) - (cond - [(pair? fml*) - (let ([a (car fml*)]) - (unless (symbol? a) (syntax-error x)) - (when (getprop a g) (syntax-error x)) - (putprop a g a) - (f (cdr fml*)) - (remprop a g))] - [(symbol? fml*) - (when (getprop fml* g) (syntax-error x))] - [(null? fml*) (void)] - [else (syntax-error x)]))))) - (define gen-fml* - (lambda (fml*) - (cond - [(pair? fml*) - (cons (gensym) (gen-fml* (cdr fml*)))] - [(symbol? fml*) (gensym)] - [else '()]))) - (define extend-env-fml* - (lambda (fml* nfml* env) - (cond - [(pair? fml*) - (cons (cons (car fml*) (car nfml*)) - (extend-env-fml* (cdr fml*) (cdr nfml*) env))] - [(symbol? fml*) - (cons (cons fml* nfml*) env)] - [else env]))) - ;;; - (define E-internal - (lambda (body* env x) - (let f ([a (car body*)] [body* (cdr body*)] [lhs* '()] [rhs* '()]) - (cond - [(and (pair? a) (symbol? (car a))) - (let ([fst (car a)]) - (cond - [(or (memq fst lhs*) (lookup a env)) - (E-internal-done a body* lhs* rhs* env)] - [(keyword? fst) - (cond - [(eq? fst 'begin) - (let ([d (cdr a)]) - (unless (list? d) (syntax-error x)) - (let ([body* (append d body*)]) - (if (null? body*) - (syntax-error x) - (f (car body*) (cdr body*) lhs* rhs*))))] - [(eq? fst 'define) - (let ([def (parse-define (cdr a) env fst)]) - (f (car body*) (cdr body*) - (cons (car def) lhs*) - (cons (cdr def) rhs*)))] - [else (E-internal-done a body* lhs* rhs* env)])] - [else (E-internal-done a body* lhs* rhs* env)]))] - [else (E-internal-done a body* lhs* rhs* env)])))) - (define parse-define - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([fst (car d)] [rest (cdr d)]) - (cond - [(symbol? fst) - (unless (fx= (length rest) 1) (syntax-error x)) - (list fst 'expr (car rest))] - [(pair? fst) - (unless (symbol? (car fst)) (syntax-error x)) - (verify-fml* (cdr fst) x) - (list (car fst) 'defun (cdr fst) rest)] - [else (syntax-error x)])))) - (define E-def - (lambda (x env) - (let ([type (car x)]) - (cond - [(eq? type 'expr) (E (cadr x) env)] - [(eq? type 'defun) - (let ([fml* (cadr x)] [body* (caddr x)]) - (let ([nfml* (gen-fml* fml*)]) - (let ([env (extend-env-fml* fml* nfml* env)]) - (build-function nfml* - (E-internal body* env x)))))] - [else (bug "invalid type" x)])))) - (define E-internal-done - (lambda (a d lhs* rhs* env) - (if (null? lhs*) - (E-begin^ a d env) - (let ([nlhs* (map (lambda (x) (gensym)) lhs*)]) - (let ([env (append (map cons lhs* nlhs*) env)]) - (let ([nrhs* (map (lambda (x) (E-def x env)) rhs*)]) - (build-letrec* nlhs* nrhs* (E-begin^ a d env)))))))) - ;;; - (define E-when - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([test (car d)] [body* (cdr d)]) - (build-conditional - (E test env) - (E-begin^ (car body*) (cdr body*) env) - (build-void))))) - ;;; - (define E-unless - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([test (car d)] [body* (cdr d)]) - (build-conditional - (E test env) - (build-void) - (E-begin^ (car body*) (cdr body*) env))))) - ;;; - (define E-or - (lambda (d env x) - (cond - [(null? d) (build-constant #f)] - [(null? (cdr d)) (E (car d) env)] - [else - (let ([t (gensym)]) - (build-let (list t) (list (E (car d) env)) - (build-conditional - (build-lexical-reference t) - (build-lexical-reference t) - (E-or (cdr d) env x))))]))) - ;;; - (define E-and - (lambda (d env x) - (cond - [(null? d) (build-constant #t)] - [(null? (cdr d)) (E (car d) env)] - [else - (build-conditional - (E (car d) env) - (E-and (cdr d) env x) - (build-constant #f))]))) - ;;; - (define E-case - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([val (car d)] [cls* (cdr d)]) - (let ([g (gensym)]) - (build-let (list g) - (list (E val env)) - (E-case-cls* g (car cls*) (cdr cls*) env x)))))) - (define E-case-cls* - (lambda (g cls cls* env x) - (cond - [(null? cls*) (E-case-cls-last g cls env x)] - [else - (unless (and (list? cls) (fx>= (length cls) 2)) - (syntax-error x)) - (let ([ls (car cls)] [b* (cdr cls)]) - (unless (list? ls) (syntax-error x)) - (build-conditional - (build-memv (build-lexical-reference g) - (build-constant ls)) - (E-begin^ (car b*) (cdr b*) env) - (E-case-cls* g (car cls*) (cdr cls*) env x)))]))) - (define E-case-cls-last - (lambda (g cls env x) - (unless (and (list? cls) (fx>= (length cls) 2)) - (syntax-error x)) - (let ([fst (car cls)] [b* (cdr cls)]) - (cond - [(and (eq? fst 'else) - (not (lookup fst env))) - (E-begin^ (car b*) (cdr b*) env)] - [(list? fst) - (build-conditional - (build-memv (build-lexical-reference g) - (build-constant fst)) - (E-begin^ (car b*) (cdr b*) env) - (build-void))] - [else (syntax-error x)])))) - ;;; - (define E-cond - (lambda (d env x) - (unless (fx>= (length d) 1) (syntax-error x)) - (E-cond-cls* (car d) (cdr d) env x))) - (define E-cond-cls* - (lambda (cls cls* env x) - (cond - [(null? cls*) (E-cond-cls-last cls env x)] - [else - (E-cond-cls cls env x - (E-cond-cls* (car cls*) (cdr cls*) env x))]))) - (define E-cond-cls - (lambda (cls env x k) - (unless (list? cls) (syntax-error x)) - (let ([n (length cls)]) - (unless (fx>= n 1) (syntax-error x)) - (cond - [(fx= n 1) - (let ([g (gensym)]) - (build-let (list g) - (list (E (car cls) env)) - (build-conditional - (build-lexical-reference g) - (build-lexical-reference g) - k)))] - [(and (fx= n 3) - (eq? (cadr cls) '=>) - (not (lookup '=> env))) - (let ([g (gensym)]) - (build-let (list g) - (list (E (car cls) env)) - (build-conditional - (build-lexical-reference g) - (build-application - (E (caddr cls) env) - (list (build-lexical-reference g))) - k)))] - [else - (let ([test (car cls)] [body* (cdr cls)]) - (build-conditional - (E test env) - (E-begin^ (car body*) (cdr body*) env) - k))])))) - (define E-cond-cls-last - (lambda (cls env x) - (unless (list? cls) (syntax-error x)) - (cond - [(and (fx>= (length cls) 2) - (eq? (car cls) 'else) - (not (lookup 'else env))) - (let ([body* (cdr cls)]) - (E-begin^ (car body*) (cdr body*) env))] - [else (E-cond-cls cls env x (build-void))]))) - ;;; - (define E-quasiquote - (lambda (d env x) - (unless (fx= (length d) 1) (syntax-error x)) - (let ([expr (car d)]) - (Eqq expr 0 env x - (lambda (what expr^) - (case what - [(splice) (syntax-error x)] - [(unquot) expr^] - [(quoted) expr^] - [else (error 'quasiquote "what ~s" what)])))))) - (define qqmacro? - (lambda (sym expr env) - (and (pair? expr) - (eq? (car expr) sym) - (let ([d (cdr expr)]) - (and (pair? d) (null? (cdr d)))) - (not (lookup sym env))))) - (define Eqq - (lambda (x depth env orig k) - (cond - [(qqmacro? 'unquote x env) - (if (fx= depth 0) - (k 'unquot (E (cadr x) env)) - (Eqq (cadr x) (fx- depth 1) env orig - (lambda (what v) - (case what - [(splice) - (k 'unquot (qqbuild 'cons (build-constant 'unquote) v))] - [(unquot) - (k 'unquot (qqbuild 'list (build-constant 'unquote) v))] - [(quoted) - (k 'quoted (build-constant x))] - [else (error 'quasiquote "what ~s" what)]))))] - [(qqmacro? 'unquote-splicing x env) - (if (fx= depth 0) - (k 'splice (E (cadr x) env)) - (Eqq (cadr x) (fx- depth 1) env orig - (lambda (what v) - (case what - [(splice) - (k 'splice - (qqbuild 'cons (build-constant 'unquote-splicing) v))] - [(unquot) - (k 'splice - (qqbuild 'list (build-constant 'unquote-splicing) v))] - [(quoted) - (k 'quoted (build-constant x))] - [else (error 'quasiquote "what ~s" what)]))))] - [(qqmacro? 'quasiquote x env) - (Eqq (cadr x) (fx+ depth 1) env orig - (lambda (what v) - (case what - [(splice) - (k 'unquot - (qqbuild 'cons (build-constant 'quasiquote) v))] - [(unquot) - (k 'unquot - (qqbuild 'list (build-constant 'quasiquote) v))] - [(quoted) - (k 'quoted (build-constant x))] - [else (error 'quasiquote "what ~s" what)])))] - [(pair? x) - (Eqq (car x) depth env orig - (lambda (what-a v-a) - (Eqq (cdr x) depth env orig - (lambda (what-d v-d) - (case what-a - [(splice) - (case what-d - [(splice) (syntax-error x)] - [(unquot) - (k 'unquot (qqbuild 'append v-a v-d))] - [(quoted) - (k 'unquot (qqbuild 'append v-a v-d))] - [else (error 'quasiquote "what ~s" what-d)])] - [(unquot) - (case what-d - [(splice) (syntax-error x)] - [(unquot) - (k 'unquot (qqbuild 'cons v-a v-d))] - [(quoted) - (k 'unquot (qqbuild 'cons v-a v-d))] - [else (error 'quasiquote "what ~s" what-d)])] - [(quoted) - (case what-d - [(splice) (syntax-error x)] - [(unquot) - (k 'unquot (qqbuild 'cons v-a v-d))] - [(quoted) - (k 'quoted (build-constant x))] - [else (error 'quasiquote "what ~s" what-d)])] - [else (error 'quasiquote "what ~s" what-a)])))))] - [(vector? x) - (let () - (define vmap-list - (lambda (i ac) - (cond - [(fx= i -1) - (k 'unquot (qqbuild 'list->vector ac))] - [else - (Eqq (vector-ref x i) depth env orig - (lambda (what vi) - (case what - [(splice) - (vmap-list (fx- i 1) - (qqbuild 'append vi ac))] - [(unquot) - (vmap-list (fx- i 1) (qqbuild 'cons vi ac))] - [(quoted) - (vmap-list (fx- i 1) (qqbuild 'cons vi ac))] - [else (error 'quasiquote "what ~s" what)])))]))) - (define vmap-vec - (lambda (i ac) - (cond - [(fx= i -1) - (k 'unquot - (build-application - (build-primref 'vector) - ac))] - [else - (Eqq (vector-ref x i) depth env orig - (lambda (what vi) - (case what - [(splice) - (vmap-list (fx- i 1) - (qqbuild 'append vi - (build-application - (build-primref 'list) - ac)))] - [(unquot) - (vmap-vec (fx- i 1) (cons vi ac))] - [(quoted) - (vmap-vec (fx- i 1) (cons vi ac))] - [else (error 'quasiquote "what ~s" what)])))]))) - (define vmap-const - (lambda (i ac) - (cond - [(fx= i -1) (k 'quoted (build-constant x))] - [else - (Eqq (vector-ref x i) depth env orig - (lambda (what vi) - (case what - [(splice) - (if (null? ac) - (vmap-list (fx- i 1) vi) - (vmap-list (fx- i 1) - (qqbuild 'append vi (build-constant ac))))] - [(unquot) - (vmap-vec (fx- i 1) - (cons vi (map build-constant ac)))] - [(quoted) - (vmap-const (fx- i 1) - (cons (vector-ref x i) ac))] - [else (error 'quasiquote "what ~s" what)])))]))) - (vmap-const (fx- (vector-length x) 1) '()))] - [else (k 'quoted (build-constant x))]))) - (define qqbuild - (lambda (prim . args) - (build-application - (build-primref prim) - args))) - ;;; - (define E-record-case - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([val (car d)] [cls* (cdr d)]) - (let ([g (gensym)]) - (build-let - (list g) - (list (E val env)) - (E-record-case-cls* (car cls*) (cdr cls*) g env x)))))) - (define E-record-case-cls* - (lambda (cls cls* v env x) - (cond - [(null? cls*) (E-record-case-last-cls cls v env x)] - [else - (E-record-case-cls cls v env x - (E-record-case-cls* (car cls*) (cdr cls*) v env x))]))) - (define E-record-case-cls - (lambda (cls v env x k) - (unless (and (list? cls) (fx>= (length cls) 2)) - (syntax-error x)) - (let ([pat (car cls)] [body* (cdr cls)]) - (unless (and (list? pat) (andmap symbol? pat) (fx>= (length pat) 1)) - (syntax-error x)) - (let ([rtd-name (car pat)] [vars (cdr pat)]) - (cond - [(lookup rtd-name env) (syntax-error x)] - [(getprop rtd-name *keyword*) => - (lambda (type) - (unless (and (pair? type) (eq? (car type) '$rtd)) - (syntax-error x)) - (let ([rtd (cdr type)] - [lhs* (map (lambda (x) (gensym)) vars)]) - (build-conditional - (build-application - (build-application - (build-primref 'record-predicate) - (list (build-constant rtd))) - (list (build-lexical-reference v))) - (build-let - lhs* - (map (lambda (i) - (build-application - (build-application - (build-primref 'record-field-accessor) - (list (build-constant rtd) - (build-constant i))) - (list (build-lexical-reference v)))) - (enumerate lhs*)) - (E-begin^ (car body*) (cdr body*) - (extend-env-fml* vars lhs* env))) - k)))] - [else (syntax-error x)]))))) - (define E-record-case-last-cls - (lambda (cls v env x) - (unless (and (list? cls) (fx>= (length cls) 2)) - (syntax-error x)) - (let ([pat (car cls)] [body* (cdr cls)]) - (cond - [(and (eq? pat 'else) (not (lookup 'else env))) - (E-begin^ (car body*) (cdr body*) env)] - [else - (E-record-case-cls cls v env x - (build-application - (build-primref 'error) - (list - (build-constant 'record-case) - (build-constant "unmatched ~s in ~s") - (build-lexical-reference v) - (build-constant x))))])))) - ;;; - (define E-foreign-call - (lambda (d env x) - (unless (fx>= (length d) 1) (syntax-error x)) - (build-foreign-call - (E (car d) env) - (map (lambda (x) (E x env)) (cdr d))))) - ;;; - (define E-primref - (lambda (d env x) - (unless (fx= (length d) 1) (syntax-error x)) - (let ([sym (car d)]) - (unless (symbol? sym) (syntax-error x)) - (cond - [(primitive? sym) (build-primref sym)] - [else (syntax-error x)])))) - ;;; - (define E-apply - (lambda (d env x) - (unless (fx>= (length d) 1) (syntax-error x)) - (build-apply - (E (car d) env) - (map (lambda (x) (E x env)) (cdr d))))) - ;;; - (define E - (lambda (x env) - (cond - [(self-evaluating? x) (build-constant x)] - [(symbol? x) - (cond - [(lookup x env) => - (lambda (b) - (build-lexical-reference b))] - [(keyword? x) - (syntax-error x)] - [else - (build-global-reference x)])] - [(pair? x) - (let ([a (car x)] [d (cdr x)]) - (unless (list? d) (syntax-error x)) - (cond - [(symbol? a) - (cond - [(lookup a env) => - (lambda (b) - (build-application - (build-lexical-reference b) - (E* d env)))] - [(keyword? a) - (cond - [(eq? a 'quote) (E-quote d env x)] - [(eq? a 'if) (E-if d env x)] - [(eq? a 'set!) (E-set! d env x)] - [(eq? a 'begin) (E-begin d env x)] - [(eq? a 'lambda) (E-lambda d env x)] - [(eq? a 'case-lambda) (E-case-lambda d env x)] - [(eq? a 'let) (E-let d env x)] - [(eq? a 'letrec) (E-letrec d env x)] - [(eq? a 'let*) (E-let* d env x)] - [(eq? a 'letrec*) (E-letrec* d env x)] - [(eq? a 'when) (E-when d env x)] - [(eq? a 'unless) (E-unless d env x)] - [(eq? a 'or) (E-or d env x)] - [(eq? a 'and) (E-and d env x)] - [(eq? a 'case) (E-case d env x)] - [(eq? a 'cond) (E-cond d env x)] - [(eq? a 'let-values) (E-let-values d env x)] - [(eq? a 'quasiquote) (E-quasiquote d env x)] - [(eq? a 'parameterize) (E-parameterize d env x)] - [(eq? a 'record-case) (E-record-case d env x)] - [(eq? a 'foreign-call) (E-foreign-call d env x)] - [(eq? a '|#primitive|) (E-primref d env x)] - [(eq? a '$apply) (E-apply d env x)] - [else (syntax-error x)])] - [else - (build-application - (build-global-reference a) - (E* d env))])] - [else - (build-application - (E a env) - (E* d env))]))] - [else (syntax-error x)]))) - ;;; - (define E*-top - (lambda (x x*) - (cond - [(null? x*) (E-top x)] - [else - (let ([x (E-top x)]) - (build-sequence x (E*-top (car x*) (cdr x*))))]))) - ;;; - (define E-top-level-define - (lambda (d ctxt) - (let ([def (parse-define d empty-env ctxt)]) - (let ([lhs (car def)] [rhs (cdr def)]) - (remprop lhs *keyword*) - (build-global-assignment lhs - (E-def rhs empty-env)))))) - ;;; - (define enumerate - (lambda (ls) - (let f ([ls ls] [i 0]) - (cond - [(null? ls) '()] - [else (cons i (f (cdr ls) (fxadd1 i)))])))) - (define E-top-level-define-record - (lambda (d x) - (unless (fx= (length d) 2) (syntax-error x)) - (let ([name (car d)] [fields (cadr d)]) - (unless (symbol? name) (syntax-error x)) - (unless (and (list? fields) - (andmap symbol? fields)) - (syntax-error x)) - (let ([str (symbol->string name)]) - (let ([rtd (make-record-type str fields)]) - (let ([constructor - (string->symbol (string-append "make-" str))] - [predicate - (string->symbol (string-append str "?"))] - [accessors - (map (lambda (field) - (string->symbol - (string-append str "-" (symbol->string field)))) - fields)] - [mutators - (map (lambda (field) - (string->symbol - (string-append "set-" str "-" - (symbol->string field) - "!"))) - fields)]) - (for-each - (lambda (x) (remprop x *keyword*)) - (cons constructor - (cons predicate - (append accessors mutators)))) - (putprop name *keyword* (cons '$rtd rtd)) - (sequence - (build-global-assignment - constructor - (build-application - (build-primref 'record-constructor) - (list (build-constant rtd)))) - (build-global-assignment - predicate - (build-application - (build-primref 'record-predicate) - (list (build-constant rtd)))) - (apply sequence - (map (lambda (accessor i) - (build-global-assignment - accessor - (build-application - (build-primref 'record-field-accessor) - (list (build-constant rtd) - (build-constant i))))) - accessors - (enumerate fields))) - (apply sequence - (map (lambda (mutator i) - (build-global-assignment - mutator - (build-application - (build-primref 'record-field-mutator) - (list (build-constant rtd) - (build-constant i))))) - mutators - (enumerate fields))) - ))))))) - ;;; - (define E-top - (lambda (x) - (cond - [(self-evaluating? x) - (build-constant x)] - [(symbol? x) - (when (keyword? x) (syntax-error x)) - (build-global-reference x)] - [(pair? x) - (let ([a (car x)] [d (cdr x)]) - (unless (list? d) (syntax-error x)) - (cond - [(and (symbol? a) (keyword? a)) - (cond - [(eq? a 'begin) - (if (null? d) - (build-void) - (E*-top (car d) (cdr d)))] - [(eq? a 'define) - (E-top-level-define d x)] - [(eq? a 'define-record) - (E-top-level-define-record d x)] - [else (E x empty-env)])] - [else - (build-application - (E a empty-env) - (E* d empty-env))]))] - [else (syntax-error x)]))) - ;;; - (primitive-set! 'core-expand E-top) - ;;; - (primitive-set! 'current-expand - (make-parameter - core-expand - (lambda (x) - (unless (procedure? x) - (error 'current-expand "~s is not a procedure" x)) - x))) - ;;; - (primitive-set! 'expand - (lambda (x) - ((current-expand) x))) - ;;; - (for-each - (lambda (x) - (putprop x *keyword* x)) - '(lambda set! let let* letrec letrec* if quote when unless set! begin - case-lambda define or and cond case foreign-call $apply |#primitive| - define-record record-case - quasiquote unquote unquote-splicing let-values parameterize - ))) - diff --git a/src/libexpand-6.2.ss b/src/libexpand-6.2.ss deleted file mode 100644 index 11af1d9..0000000 --- a/src/libexpand-6.2.ss +++ /dev/null @@ -1,1099 +0,0 @@ - -;;; 6.2: internal define-record (not yet working) -;;; 6.1: case-lambda - -;;; Extended: cond case - -;;; -;;; -;;; Expand : Scheme -> Core Scheme -;;; -;;; ::= (quote datum) -;;; | -;;; | (if ) -;;; | (set! ) -;;; | (begin ...) -;;; | (letrec ([ ] ...) ...) -;;; | (lambda ...) -;;; | ( ...) -;;; | (#primitive| ) -;;; | ( ...) -;;; ::= () -;;; | -;;; | ( . ) -;;; ::= void | memv | top-level-value | set-top-level-value! -;;; | primitive-set! '| foreign-call | $apply -;;; -;;; -;;; Handled keywords: -;;; Core: case-lambda lambda set! if quote begin define -;;; Extended: let let* letrec letrec* when unless or and cond case -;;; define-record record-case - - -(let () - (define *interaction-environment* (gensym "*interaction-environment*")) - (define *scheme-environment* (gensym "*scheme-environment*")) - (define build-void - (lambda () - (build-application (build-primref 'void) '()))) - (define build-primref - (lambda (x) - (list '|#primitive| x))) - (define build-global-assignment - (lambda (x val) - (list 'set-top-level-value! - (build-constant x) val))) - (define build-foreign-call - (lambda (name rand*) - (cons 'foreign-call - (cons name rand*)))) - (define build-apply - (lambda (proc rand*) - (cons '$apply - (cons proc rand*)))) - (define build-global-reference - (lambda (x) - (list 'top-level-value (build-constant x)))) - (define build-memv - (lambda (x ls) - (list 'memv x ls))) - (define build-application - (lambda (fun arg*) - (cons fun arg*))) - (define build-sequence - (lambda (a b) - (let ([a* - (if (and (pair? a) (eq? (car a) 'begin)) - (cdr a) - (list a))] - [b* - (if (and (pair? b) (eq? (car b) 'begin)) - (cdr b) - (list b))]) - (cons 'begin (append a* b*))))) - (define sequence - (lambda args - (if (null? args) - (build-void) - (let f ([a (car args)] [args (cdr args)]) - (cond - [(null? args) a] - [else - (build-sequence a (f (car args) (cdr args)))]))))) - (define build-constant - (lambda (x) (list 'quote x))) - (define build-lexical-reference - (lambda (x) x)) - (define build-lexical-assignment - (lambda (lhs rhs) - (list 'set! lhs rhs))) - (define build-conditional - (lambda (test conseq altern) - (list 'if test conseq altern))) - (define build-function - (lambda (fml* body) - (build-case-lambda (list (list fml* body))))) - (define build-case-lambda - (lambda (cases) - (cons 'case-lambda cases))) - (define build-assignments - (lambda (lhs* rhs* body) - (cond - [(null? lhs*) body] - [else - (build-sequence - (build-lexical-assignment (car lhs*) (car rhs*)) - (build-assignments (cdr lhs*) (cdr rhs*) body))]))) - (define build-letrec - (lambda (lhs* rhs* body) - (if (null? lhs*) - body - (let ([g* (map (lambda (x) (gensym)) lhs*)]) - (build-let lhs* (map (lambda (x) (build-void)) lhs*) - (build-let g* rhs* - (build-assignments lhs* g* body))))))) - (define build-letrec* - (lambda (lhs* rhs* body) - (if (null? lhs*) - body - (build-let lhs* (map (lambda (x) (build-void)) lhs*) - (build-assignments lhs* rhs* body))))) - (define build-let - (lambda (lhs* rhs* body) - (build-application - (build-function lhs* body) - rhs*))) - (define build-let* - (lambda (lhs* rhs* body) - (cond - [(null? lhs*) body] - [else - (build-let (list (car lhs*)) (list (car rhs*)) - (build-let* (cdr lhs*) (cdr rhs*) body))]))) - ;;; builds - (define keyword? - (lambda (x) (getprop x *interaction-environment*))) - (define self-evaluating? - (lambda (x) - (or (immediate? x) (string? x)))) - (define syntax-error - (lambda (x) - (error 'expand "invalid syntax ~s" x))) - (define empty-env '()) - (define E* - (lambda (x* env) - (cond - [(null? x*) '()] - [else - (cons (E (car x*) env) (E* (cdr x*) env))]))) - (define lookup - (lambda (x env) - (cond - [(assq x env) => - (lambda (x) - (let ([d (cdr x)]) - (cond - [(symbol? d) (cons 'lexical d)] - [(and (pair? d) (eq? (car d) *interaction-environment*)) - (cons 'macro (cdr d))] - [else (error 'expand "BUG in lookup ~s" x)])))] - [(keyword? x) => (lambda (x) (cons 'macro x))] - [else (cons 'global x)]))) - (define bug - (lambda (str . args) - (error 'bug "~a ~a" str args))) - ;;; - (define E-quote - (lambda (d env x) - (unless (fx= (length d) 1) - (syntax-error x)) - (build-constant (car d)))) - ;;; - (define E-if - (lambda (d env x) - (let ([n (length d)]) - (cond - [(fx= n 2) - (build-conditional - (E (car d) env) - (E (cadr d) env) - (build-void))] - [(fx= n 3) - (build-conditional - (E (car d) env) - (E (cadr d) env) - (E (caddr d) env))] - [else (syntax-error x)])))) - ;;; - (define E-set! - (lambda (d env x) - (unless (fx= (length d) 2) (syntax-error x)) - (let ([lhs (car d)] [rhs (cadr d)]) - (unless (symbol? lhs) (syntax-error x)) - (let ([b (lookup lhs env)]) - (case (car b) - [(lexical) - (build-lexical-assignment (cdr b) (E rhs env))] - [(global) - (build-global-assignment (cdr b) (E rhs env))] - [else (syntax-error x)]))))) - ;;; - (define E-begin - (lambda (d env x) - (unless (fx>= (length d) 1) - (syntax-error x)) - (E-begin^ (car d) (cdr d) env))) - (define E-begin^ - (lambda (a d env) - (cond - [(null? d) (E a env)] - [else - (build-sequence - (E a env) - (E-begin^ (car d) (cdr d) env))]))) - ;;; - (define E-named-let - (lambda (name d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([bindings (car d)] [body* (cdr d)]) - (verify-bindings bindings x) - (let ([lhs* (map car bindings)] - [rhs* (map cadr bindings)]) - (verify-fml* lhs* x) - (let ([rator - (let ([gname (gensym)] - [nlhs* (map (lambda (x) (gensym)) lhs*)]) - (let ([env - (extend-env-fml* lhs* nlhs* - (cons (cons name gname) env))]) - (let ([body (E-internal body* env x)]) - (let ([fun (build-function nlhs* body)]) - (build-letrec - (list gname) - (list fun) - (build-lexical-reference gname))))))] - [rand* (map (lambda (x) (E x env)) rhs*)]) - (build-application rator rand*)))))) - ;;; - (define E-let - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([bindings (car d)] [body* (cdr d)]) - (cond - [(symbol? bindings) - (E-named-let bindings body* env x)] - [else - (verify-bindings bindings x) - (let ([lhs* (map car bindings)] - [rhs* (map cadr bindings)]) - (verify-fml* lhs* x) - (let ([nlhs* (map (lambda (x) (gensym)) lhs*)]) - (let ([nrhs* (map (lambda (x) (E x env)) rhs*)]) - (let ([env (extend-env-fml* lhs* nlhs* env)]) - (build-let nlhs* nrhs* (E-internal body* env x))))))])))) - (define verify-bindings - (lambda (b* x) - (unless (list? b*) (syntax-error x)) - (for-each - (lambda (b) - (unless (and (list? b) - (fx= (length b) 2) - (symbol? (car b))) - (syntax-error x))) - b*))) - ;;; - (define E-let* - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([bindings (car d)] [body* (cdr d)]) - (verify-bindings bindings x) - (let ([lhs* (map car bindings)] - [rhs* (map cadr bindings)]) - (let ([nlhs* (map (lambda (x) (gensym)) lhs*)]) - (let f ([lhs* lhs*] [nlhs* nlhs*] [rhs* rhs*] [env env]) - (cond - [(null? lhs*) (E-internal body* env x)] - [else - (build-let (list (car nlhs*)) - (list (E (car rhs*) env)) - (f (cdr lhs*) (cdr nlhs*) (cdr rhs*) - (cons (cons (car lhs*) (car nlhs*)) env)))]))))))) - ;;; - (define E-letrec - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([bindings (car d)] [body* (cdr d)]) - (verify-bindings bindings x) - (let ([lhs* (map car bindings)] - [rhs* (map cadr bindings)]) - (verify-fml* lhs* x) - (let ([nlhs* (map (lambda (x) (gensym)) lhs*)]) - (let ([env (extend-env-fml* lhs* nlhs* env)]) - (let ([nrhs* (map (lambda (x) (E x env)) rhs*)]) - (build-letrec nlhs* nrhs* (E-internal body* env x))))))))) - ;;; - (define E-letrec* - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([bindings (car d)] [body* (cdr d)]) - (verify-bindings bindings x) - (let ([lhs* (map car bindings)] - [rhs* (map cadr bindings)]) - (verify-fml* lhs* x) - (let ([nlhs* (map (lambda (x) (gensym)) lhs*)]) - (let ([env (extend-env-fml* lhs* nlhs* env)]) - (let ([nrhs* (map (lambda (x) (E x env)) rhs*)]) - (build-letrec* nlhs* nrhs* (E-internal body* env x))))))))) - ;;; - (define E-let-values - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([bindings (car d)] [body* (cdr d)]) - (unless (list? bindings) (syntax-error x)) - (let f ([bindings bindings] [nenv env]) - (cond - [(null? bindings) (E-internal body* nenv x)] - [else - (let ([b (car bindings)]) - (unless (and (list? b) (fx= (length b) 2)) - (syntax-error x)) - (let ([fml* (car b)] [rhs (cadr b)]) - (verify-fml* fml* x) - (let ([nfml* (gen-fml* fml*)]) - (let ([nenv (extend-env-fml* fml* nfml* nenv)]) - (build-application - (build-primref 'call-with-values) - (list (build-function '() - (E rhs env)) - (build-function nfml* - (f (cdr bindings) nenv))))))))]))))) - ;;; - (define E-parameterize - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([bindings (car d)] [body* (cdr d)]) - (cond - [(null? bindings) - (E-internal body* env x)] - [else - (unless (and (list? bindings) - (andmap (lambda (b) - (and (list? b) (fx= (length b) 2))) - bindings)) - (syntax-error x)) - (let ([lhs* (map car bindings)] [rhs* (map cadr bindings)]) - (let ([nlhs* (map (lambda (x) (gensym)) lhs*)] - [nrhs* (map (lambda (x) (gensym)) lhs*)] - [swap (gensym)] - [t* (map (lambda (x) (gensym)) lhs*)]) - (build-let - (append nlhs* nrhs*) - (map (lambda (x) (E x env)) - (append lhs* rhs*)) - (build-let - (list swap) - (list - (build-function '() - (apply sequence - (map (lambda (t lhs/rhs) - ;;; FIXME: vararg map - (define nlhs (car lhs/rhs)) - (define nrhs (cdr lhs/rhs)) - (build-let - (list t) - (list (build-application - (build-lexical-reference nlhs) - '())) - (build-sequence - (build-application - (build-lexical-reference nlhs) - (list (build-lexical-reference nrhs))) - (build-lexical-assignment - nrhs - (build-lexical-reference t))))) - t* (map cons nlhs* nrhs*))))) - (build-application - (build-primref 'dynamic-wind) - (list - (build-lexical-reference swap) - (build-function - '() - (E-internal body* env x)) - (build-lexical-reference swap)))))))])))) - ;;; - (define E-lambda - (lambda (d env x) - (build-case-lambda - (list ((lambda-clause env x) d))))) - (define (lambda-clause env x) - (lambda (d) - (unless (and (list? d) (fx>= (length d) 2)) (syntax-error x)) - (let ([fml* (car d)] [body* (cdr d)]) - (verify-fml* fml* x) - (let ([nfml* (gen-fml* fml*)]) - (let ([env (extend-env-fml* fml* nfml* env)]) - (list nfml* (E-internal body* env x))))))) - (define E-case-lambda - (lambda (d env x) - (unless (fx>= (length d) 1) (syntax-error x)) - (build-case-lambda - (map (lambda-clause env x) d)))) - (define verify-fml* - (lambda (fml* x) - (let ([g (gensym)]) - (let f ([fml* fml*]) - (cond - [(pair? fml*) - (let ([a (car fml*)]) - (unless (symbol? a) (syntax-error x)) - (when (getprop a g) (syntax-error x)) - (putprop a g a) - (f (cdr fml*)) - (remprop a g))] - [(symbol? fml*) - (when (getprop fml* g) (syntax-error x))] - [(null? fml*) (void)] - [else (syntax-error x)]))))) - (define gen-fml* - (lambda (fml*) - (cond - [(pair? fml*) - (cons (gensym) (gen-fml* (cdr fml*)))] - [(symbol? fml*) (gensym)] - [else '()]))) - (define extend-env-fml* - (lambda (fml* nfml* env) - (cond - [(pair? fml*) - (cons (cons (car fml*) (car nfml*)) - (extend-env-fml* (cdr fml*) (cdr nfml*) env))] - [(symbol? fml*) - (cons (cons fml* nfml*) env)] - [else env]))) - ;;; - (define E-internal - (lambda (body* env x) - (let f ([a (car body*)] [body* (cdr body*)] [lhs* '()] [rhs* '()]) - (cond - [(and (pair? a) (symbol? (car a))) - (let ([fst (car a)]) - (if (memq fst lhs*) - (E-internal-done a body* lhs* rhs* env) - (let ([b (lookup fst env)]) - (case (car b) - [(lexical global) - (E-internal-done a body* lhs* rhs* env)] - [(macro) - (case fst - [(begin) - (let ([d (cdr a)]) - (unless (list? d) (syntax-error x)) - (let ([body* (append d body*)]) - (if (null? body*) - (syntax-error x) - (f (car body*) (cdr body*) lhs* rhs*))))] - [(define) - (let ([def (parse-define (cdr a) env fst)]) - (f (car body*) (cdr body*) - (cons (car def) lhs*) - (cons (cdr def) rhs*)))] - [else - (E-internal-done a body* lhs* rhs* env)])] - [else (syntax-error x)]))))] - [else (E-internal-done a body* lhs* rhs* env)])))) - (define parse-define - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([fst (car d)] [rest (cdr d)]) - (cond - [(symbol? fst) - (unless (fx= (length rest) 1) (syntax-error x)) - (list fst 'expr (car rest))] - [(pair? fst) - (unless (symbol? (car fst)) (syntax-error x)) - (verify-fml* (cdr fst) x) - (list (car fst) 'defun (cdr fst) rest)] - [else (syntax-error x)])))) - (define E-def - (lambda (x env) - (let ([type (car x)]) - (cond - [(eq? type 'expr) (E (cadr x) env)] - [(eq? type 'defun) - (let ([fml* (cadr x)] [body* (caddr x)]) - (let ([nfml* (gen-fml* fml*)]) - (let ([env (extend-env-fml* fml* nfml* env)]) - (build-function nfml* - (E-internal body* env x)))))] - [else (bug "invalid type" x)])))) - (define E-internal-done - (lambda (a d lhs* rhs* env) - (if (null? lhs*) - (E-begin^ a d env) - (let ([nlhs* (map (lambda (x) (gensym)) lhs*)]) - (let ([env (append (map cons lhs* nlhs*) env)]) - (let ([nrhs* (map (lambda (x) (E-def x env)) rhs*)]) - (build-letrec* nlhs* nrhs* (E-begin^ a d env)))))))) - ;;; - (define E-when - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([test (car d)] [body* (cdr d)]) - (build-conditional - (E test env) - (E-begin^ (car body*) (cdr body*) env) - (build-void))))) - ;;; - (define E-unless - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([test (car d)] [body* (cdr d)]) - (build-conditional - (E test env) - (build-void) - (E-begin^ (car body*) (cdr body*) env))))) - ;;; - (define E-or - (lambda (d env x) - (cond - [(null? d) (build-constant #f)] - [(null? (cdr d)) (E (car d) env)] - [else - (let ([t (gensym)]) - (build-let (list t) (list (E (car d) env)) - (build-conditional - (build-lexical-reference t) - (build-lexical-reference t) - (E-or (cdr d) env x))))]))) - ;;; - (define E-and - (lambda (d env x) - (cond - [(null? d) (build-constant #t)] - [(null? (cdr d)) (E (car d) env)] - [else - (build-conditional - (E (car d) env) - (E-and (cdr d) env x) - (build-constant #f))]))) - ;;; - (define E-case - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([val (car d)] [cls* (cdr d)]) - (let ([g (gensym)]) - (build-let (list g) - (list (E val env)) - (E-case-cls* g (car cls*) (cdr cls*) env x)))))) - (define E-case-cls* - (lambda (g cls cls* env x) - (cond - [(null? cls*) (E-case-cls-last g cls env x)] - [else - (unless (and (list? cls) (fx>= (length cls) 2)) - (syntax-error x)) - (let ([ls (car cls)] [b* (cdr cls)]) - (unless (list? ls) (syntax-error x)) - (build-conditional - (build-memv (build-lexical-reference g) - (build-constant ls)) - (E-begin^ (car b*) (cdr b*) env) - (E-case-cls* g (car cls*) (cdr cls*) env x)))]))) - (define E-case-cls-last - (lambda (g cls env x) - (unless (and (list? cls) (fx>= (length cls) 2)) - (syntax-error x)) - (let ([fst (car cls)] [b* (cdr cls)]) - (cond - [(and (eq? fst 'else) - (eq? (car (lookup 'else env)) 'global)) - (E-begin^ (car b*) (cdr b*) env)] - [(list? fst) - (build-conditional - (build-memv (build-lexical-reference g) - (build-constant fst)) - (E-begin^ (car b*) (cdr b*) env) - (build-void))] - [else (syntax-error x)])))) - ;;; - (define E-cond - (lambda (d env x) - (unless (fx>= (length d) 1) (syntax-error x)) - (E-cond-cls* (car d) (cdr d) env x))) - (define E-cond-cls* - (lambda (cls cls* env x) - (cond - [(null? cls*) (E-cond-cls-last cls env x)] - [else - (E-cond-cls cls env x - (E-cond-cls* (car cls*) (cdr cls*) env x))]))) - (define E-cond-cls - (lambda (cls env x k) - (unless (list? cls) (syntax-error x)) - (let ([n (length cls)]) - (unless (fx>= n 1) (syntax-error x)) - (cond - [(fx= n 1) - (let ([g (gensym)]) - (build-let (list g) - (list (E (car cls) env)) - (build-conditional - (build-lexical-reference g) - (build-lexical-reference g) - k)))] - [(and (fx= n 3) - (eq? (cadr cls) '=>) - (eq? (car (lookup '=> env)) 'global)) - (let ([g (gensym)]) - (build-let (list g) - (list (E (car cls) env)) - (build-conditional - (build-lexical-reference g) - (build-application - (E (caddr cls) env) - (list (build-lexical-reference g))) - k)))] - [else - (let ([test (car cls)] [body* (cdr cls)]) - (build-conditional - (E test env) - (E-begin^ (car body*) (cdr body*) env) - k))])))) - (define E-cond-cls-last - (lambda (cls env x) - (unless (list? cls) (syntax-error x)) - (cond - [(and (fx>= (length cls) 2) - (eq? (car cls) 'else) - (eq? (car (lookup 'else env)) 'global)) - (let ([body* (cdr cls)]) - (E-begin^ (car body*) (cdr body*) env))] - [else (E-cond-cls cls env x (build-void))]))) - ;;; - (define E-quasiquote - (lambda (d env x) - (unless (fx= (length d) 1) (syntax-error x)) - (let ([expr (car d)]) - (Eqq expr 0 env x - (lambda (what expr^) - (case what - [(splice) (syntax-error x)] - [(unquot) expr^] - [(quoted) expr^] - [else (error 'quasiquote "what ~s" what)])))))) - (define qqmacro? - (lambda (sym expr env) - (and (pair? expr) - (eq? (car expr) sym) - (let ([d (cdr expr)]) - (and (pair? d) (null? (cdr d)))) - (memq (car (lookup sym env)) '(global macro))))) - (define Eqq - (lambda (x depth env orig k) - (cond - [(qqmacro? 'unquote x env) - (if (fx= depth 0) - (k 'unquot (E (cadr x) env)) - (Eqq (cadr x) (fx- depth 1) env orig - (lambda (what v) - (case what - [(splice) - (k 'unquot (qqbuild 'cons (build-constant 'unquote) v))] - [(unquot) - (k 'unquot (qqbuild 'list (build-constant 'unquote) v))] - [(quoted) - (k 'quoted (build-constant x))] - [else (error 'quasiquote "what ~s" what)]))))] - [(qqmacro? 'unquote-splicing x env) - (if (fx= depth 0) - (k 'splice (E (cadr x) env)) - (Eqq (cadr x) (fx- depth 1) env orig - (lambda (what v) - (case what - [(splice) - (k 'splice - (qqbuild 'cons (build-constant 'unquote-splicing) v))] - [(unquot) - (k 'splice - (qqbuild 'list (build-constant 'unquote-splicing) v))] - [(quoted) - (k 'quoted (build-constant x))] - [else (error 'quasiquote "what ~s" what)]))))] - [(qqmacro? 'quasiquote x env) - (Eqq (cadr x) (fx+ depth 1) env orig - (lambda (what v) - (case what - [(splice) - (k 'unquot - (qqbuild 'cons (build-constant 'quasiquote) v))] - [(unquot) - (k 'unquot - (qqbuild 'list (build-constant 'quasiquote) v))] - [(quoted) - (k 'quoted (build-constant x))] - [else (error 'quasiquote "what ~s" what)])))] - [(pair? x) - (Eqq (car x) depth env orig - (lambda (what-a v-a) - (Eqq (cdr x) depth env orig - (lambda (what-d v-d) - (case what-a - [(splice) - (case what-d - [(splice) (syntax-error x)] - [(unquot) - (k 'unquot (qqbuild 'append v-a v-d))] - [(quoted) - (k 'unquot (qqbuild 'append v-a v-d))] - [else (error 'quasiquote "what ~s" what-d)])] - [(unquot) - (case what-d - [(splice) (syntax-error x)] - [(unquot) - (k 'unquot (qqbuild 'cons v-a v-d))] - [(quoted) - (k 'unquot (qqbuild 'cons v-a v-d))] - [else (error 'quasiquote "what ~s" what-d)])] - [(quoted) - (case what-d - [(splice) (syntax-error x)] - [(unquot) - (k 'unquot (qqbuild 'cons v-a v-d))] - [(quoted) - (k 'quoted (build-constant x))] - [else (error 'quasiquote "what ~s" what-d)])] - [else (error 'quasiquote "what ~s" what-a)])))))] - [(vector? x) - (let () - (define vmap-list - (lambda (i ac) - (cond - [(fx= i -1) - (k 'unquot (qqbuild 'list->vector ac))] - [else - (Eqq (vector-ref x i) depth env orig - (lambda (what vi) - (case what - [(splice) - (vmap-list (fx- i 1) - (qqbuild 'append vi ac))] - [(unquot) - (vmap-list (fx- i 1) (qqbuild 'cons vi ac))] - [(quoted) - (vmap-list (fx- i 1) (qqbuild 'cons vi ac))] - [else (error 'quasiquote "what ~s" what)])))]))) - (define vmap-vec - (lambda (i ac) - (cond - [(fx= i -1) - (k 'unquot - (build-application - (build-primref 'vector) - ac))] - [else - (Eqq (vector-ref x i) depth env orig - (lambda (what vi) - (case what - [(splice) - (vmap-list (fx- i 1) - (qqbuild 'append vi - (build-application - (build-primref 'list) - ac)))] - [(unquot) - (vmap-vec (fx- i 1) (cons vi ac))] - [(quoted) - (vmap-vec (fx- i 1) (cons vi ac))] - [else (error 'quasiquote "what ~s" what)])))]))) - (define vmap-const - (lambda (i ac) - (cond - [(fx= i -1) (k 'quoted (build-constant x))] - [else - (Eqq (vector-ref x i) depth env orig - (lambda (what vi) - (case what - [(splice) - (if (null? ac) - (vmap-list (fx- i 1) vi) - (vmap-list (fx- i 1) - (qqbuild 'append vi (build-constant ac))))] - [(unquot) - (vmap-vec (fx- i 1) - (cons vi (map build-constant ac)))] - [(quoted) - (vmap-const (fx- i 1) - (cons (vector-ref x i) ac))] - [else (error 'quasiquote "what ~s" what)])))]))) - (vmap-const (fx- (vector-length x) 1) '()))] - [else (k 'quoted (build-constant x))]))) - (define qqbuild - (lambda (prim . args) - (build-application - (build-primref prim) - args))) - ;;; - (define E-record-case - (lambda (d env x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([val (car d)] [cls* (cdr d)]) - (let ([g (gensym)]) - (build-let - (list g) - (list (E val env)) - (E-record-case-cls* (car cls*) (cdr cls*) g env x)))))) - (define E-record-case-cls* - (lambda (cls cls* v env x) - (cond - [(null? cls*) (E-record-case-last-cls cls v env x)] - [else - (E-record-case-cls cls v env x - (E-record-case-cls* (car cls*) (cdr cls*) v env x))]))) - (define E-record-case-cls - (lambda (cls v env x k) - (unless (and (list? cls) (fx>= (length cls) 2)) - (syntax-error x)) - (let ([pat (car cls)] [body* (cdr cls)]) - (unless (and (list? pat) (andmap symbol? pat) (fx>= (length pat) 1)) - (syntax-error x)) - (let ([rtd-name (car pat)] [vars (cdr pat)]) - (let ([b (lookup rtd-name env)]) - (case (car b) - [(macro) - (unless (and (pair? (cdr b)) (eq? '$rtd (cadr b))) - (syntax-error x)) - (let ([rtd (cddr b)] - [lhs* (map (lambda (x) (gensym)) vars)]) - (build-conditional - (build-application - (build-application - (build-primref 'record-predicate) - (list (build-constant rtd))) - (list (build-lexical-reference v))) - (build-let - lhs* - (map (lambda (i) - (build-application - (build-application - (build-primref 'record-field-accessor) - (list (build-constant rtd) - (build-constant i))) - (list (build-lexical-reference v)))) - (enumerate lhs*)) - (E-begin^ (car body*) (cdr body*) - (extend-env-fml* vars lhs* env))) - k))] - [else (syntax-error x)])))))) - (define E-record-case-last-cls - (lambda (cls v env x) - (unless (and (list? cls) (fx>= (length cls) 2)) - (syntax-error x)) - (let ([pat (car cls)] [body* (cdr cls)]) - (cond - [(and (eq? pat 'else) - (eq? (car (lookup 'else env)) 'global)) - (E-begin^ (car body*) (cdr body*) env)] - [else - (E-record-case-cls cls v env x - (build-application - (build-primref 'error) - (list - (build-constant 'record-case) - (build-constant "unmatched ~s in ~s") - (build-lexical-reference v) - (build-constant x))))])))) - ;;; - (define E-foreign-call - (lambda (d env x) - (unless (fx>= (length d) 1) (syntax-error x)) - (build-foreign-call - (E (car d) env) - (map (lambda (x) (E x env)) (cdr d))))) - ;;; - (define E-primref - (lambda (d env x) - (unless (fx= (length d) 1) (syntax-error x)) - (let ([sym (car d)]) - (unless (symbol? sym) (syntax-error x)) - (cond - [(primitive? sym) (build-primref sym)] - [else (syntax-error x)])))) - ;;; - (define E-apply - (lambda (d env x) - (unless (fx>= (length d) 1) (syntax-error x)) - (build-apply - (E (car d) env) - (map (lambda (x) (E x env)) (cdr d))))) - ;;; - (define E-define-record - (lambda (d env x) - (error 'E-define-record "not yet"))) - - (define E-macro-call - (lambda (a d env x) - (case a - [(quote) (E-quote d env x)] - [(if) (E-if d env x)] - [(set!) (E-set! d env x)] - [(begin) (E-begin d env x)] - [(lambda) (E-lambda d env x)] - [(case-lambda) (E-case-lambda d env x)] - [(let) (E-let d env x)] - [(letrec) (E-letrec d env x)] - [(let*) (E-let* d env x)] - [(letrec*) (E-letrec* d env x)] - [(when) (E-when d env x)] - [(unless) (E-unless d env x)] - [(or) (E-or d env x)] - [(and) (E-and d env x)] - [(case) (E-case d env x)] - [(cond) (E-cond d env x)] - [(let-values) (E-let-values d env x)] - [(quasiquote) (E-quasiquote d env x)] - [(parameterize) (E-parameterize d env x)] - [(define-record) (E-define-record d env x)] - [(record-case) (E-record-case d env x)] - [(foreign-call) (E-foreign-call d env x)] - [(|#primitive|) (E-primref d env x)] - [($apply) (E-apply d env x)] - [else (syntax-error x)]))) - ;;; - (define E - (lambda (x env) - (cond - [(self-evaluating? x) (build-constant x)] - [(symbol? x) - (let ([b (lookup x env)]) - (case (car b) - [(lexical) - (build-lexical-reference (cdr b))] - [(global) - (build-global-reference (cdr b))] - [else (syntax-error x)]))] - [(pair? x) - (let ([a (car x)] [d (cdr x)]) - (unless (list? d) (syntax-error x)) - (cond - [(symbol? a) - (let ([b (lookup a env)]) - (case (car b) - [(lexical) - (build-application - (build-lexical-reference (cdr b)) - (E* d env))] - [(global) - (build-application - (build-global-reference (cdr b)) - (E* d env))] - [(macro) - (E-macro-call a d env x)] - [else (syntax-error x)]))] - [else - (build-application - (E a env) - (E* d env))]))] - [else (syntax-error x)]))) - ;;; - (define E*-top - (lambda (x x*) - (cond - [(null? x*) (E-top x)] - [else - (let ([x (E-top x)]) - (build-sequence x (E*-top (car x*) (cdr x*))))]))) - ;;; - (define E-top-level-define - (lambda (d ctxt) - (let ([def (parse-define d empty-env ctxt)]) - (let ([lhs (car def)] [rhs (cdr def)]) - (remprop lhs *interaction-environment*) - (build-global-assignment lhs - (E-def rhs empty-env)))))) - ;;; - (define enumerate - (lambda (ls) - (let f ([ls ls] [i 0]) - (cond - [(null? ls) '()] - [else (cons i (f (cdr ls) (fxadd1 i)))])))) - (define E-top-level-define-record - (lambda (d x) - (unless (fx= (length d) 2) (syntax-error x)) - (let ([name (car d)] [fields (cadr d)]) - (unless (symbol? name) (syntax-error x)) - (unless (and (list? fields) - (andmap symbol? fields)) - (syntax-error x)) - (let ([str (symbol->string name)]) - (let ([rtd (make-record-type str fields)]) - (let ([constructor - (string->symbol (string-append "make-" str))] - [predicate - (string->symbol (string-append str "?"))] - [accessors - (map (lambda (field) - (string->symbol - (string-append str "-" (symbol->string field)))) - fields)] - [mutators - (map (lambda (field) - (string->symbol - (string-append "set-" str "-" - (symbol->string field) - "!"))) - fields)]) - (for-each - (lambda (x) (remprop x *interaction-environment*)) - (cons constructor - (cons predicate - (append accessors mutators)))) - (putprop name *interaction-environment* (cons '$rtd rtd)) - (sequence - (build-global-assignment - constructor - (build-application - (build-primref 'record-constructor) - (list (build-constant rtd)))) - (build-global-assignment - predicate - (build-application - (build-primref 'record-predicate) - (list (build-constant rtd)))) - (apply sequence - (map (lambda (accessor i) - (build-global-assignment - accessor - (build-application - (build-primref 'record-field-accessor) - (list (build-constant rtd) - (build-constant i))))) - accessors - (enumerate fields))) - (apply sequence - (map (lambda (mutator i) - (build-global-assignment - mutator - (build-application - (build-primref 'record-field-mutator) - (list (build-constant rtd) - (build-constant i))))) - mutators - (enumerate fields))) - ))))))) - ;;; - (define E-top - (lambda (x) - (cond - [(self-evaluating? x) - (build-constant x)] - [(symbol? x) - (when (keyword? x) (syntax-error x)) - (build-global-reference x)] - [(pair? x) - (let ([a (car x)] [d (cdr x)]) - (unless (list? d) (syntax-error x)) - (cond - [(and (symbol? a) (keyword? a)) - (cond - [(eq? a 'begin) - (if (null? d) - (build-void) - (E*-top (car d) (cdr d)))] - [(eq? a 'define) - (E-top-level-define d x)] - [(eq? a 'define-record) - (E-top-level-define-record d x)] - [else (E x empty-env)])] - [else - (build-application - (E a empty-env) - (E* d empty-env))]))] - [else (syntax-error x)]))) - ;;; - (primitive-set! 'core-expand E-top) - ;;; - (primitive-set! 'current-expand - (make-parameter - core-expand - (lambda (x) - (unless (procedure? x) - (error 'current-expand "~s is not a procedure" x)) - x))) - ;;; - (primitive-set! 'expand - (lambda (x) - ((current-expand) x))) - ;;; - (for-each - (lambda (x) - (putprop x *interaction-environment* x)) - '(lambda set! let let* letrec letrec* if quote when unless set! begin - case-lambda define or and cond case foreign-call $apply |#primitive| - define-record record-case - quasiquote unquote unquote-splicing let-values parameterize - ))) - - - diff --git a/src/libfasl-6.0.ss b/src/libfasl-6.0.ss deleted file mode 100644 index 3ed6c7d..0000000 --- a/src/libfasl-6.0.ss +++ /dev/null @@ -1,261 +0,0 @@ - -;;; FASL -;;; -;;; A fasl object is a header followed by one or more objects followed by an -;;; end-of-fasl marker -;;; -;;; The header is the string "#@IK01" -;;; The end of fasl marker is "@" -;;; -;;; An object is either: -;;; "N" : denoting the empty list -;;; "T" : denoting #t -;;; "F" : denoting #f -;;; "E" : denoting the end of file object -;;; "U" : denoting the unspecified value -;;; "I" + 4-bytes : denoting a fixnum (in host byte order) -;;; "C" + 1-byte : denoting a character -;;; "P" + object1 + object2 : a pair -;;; "V" + 4-bytes(n) + object ... : a vector of length n followed by n -;;; objects -;;; "S" + 4-bytes(n) + char ... : a string -;;; "M" + symbol-name : a symbol -;;; "G" + pretty-name + unique-name : a gensym -;;; "R" + rtd-name + rtd-symbol + field-count + field-names -;;; "{" + field-count + rtd + fields -;;; ">" + 4-bytes(i) : mark the next object with index i -;;; "<" + 4-bytes(i) : dereference the object marked with index i -;;; - - -(let () - (define write-fixnum - (lambda (x p) - (unless (fixnum? x) (error 'write-fixnum "not a fixnum ~s" x)) - (write-char (integer->char (fxsll (fxlogand x #x3F) 2)) p) - (write-char (integer->char (fxlogand (fxsra x 6) #xFF)) p) - (write-char (integer->char (fxlogand (fxsra x 14) #xFF)) p) - (write-char (integer->char (fxlogand (fxsra x 22) #xFF)) p))) - (define write-int - (lambda (x p) - (unless (fixnum? x) (error 'write-int "not a fixnum ~s" x)) - (write-char (integer->char (fxlogand x #xFF)) p) - (write-char (integer->char (fxlogand (fxsra x 8) #xFF)) p) - (write-char (integer->char (fxlogand (fxsra x 16) #xFF)) p) - (write-char (integer->char (fxlogand (fxsra x 24) #xFF)) p))) - - (define fasl-write-immediate - (lambda (x p) - (cond - [(null? x) (write-char #\N p)] - [(fixnum? x) - (write-char #\I p) - (write-fixnum x p)] - [(char? x) - (write-char #\C p) - (write-char x p)] - [(boolean? x) - (write-char (if x #\T #\F) p)] - [(eof-object? x) (write-char #\E p)] - [(eq? x (void)) (write-char #\U p)] - [else (error 'fasl-write "~s is not a fasl-writable immediate" x)]))) - - (define do-write - (lambda (x p h m) - (cond - [(pair? x) - (write-char #\P p) - (fasl-write (cdr x) p h - (fasl-write (car x) p h m))] - [(vector? x) - (write-char #\V p) - (write-int (vector-length x) p) - (let f ([x x] [i 0] [n (vector-length x)] [m m]) - (cond - [(fx= i n) m] - [else - (f x (fxadd1 i) n - (fasl-write (vector-ref x i) p h m))]))] - [(string? x) - (write-char #\S p) - (write-int (string-length x) p) - (let f ([x x] [i 0] [n (string-length x)]) - (cond - [(fx= i n) m] - [else - (write-char (string-ref x i) p) - (f x (fxadd1 i) n)]))] - [(gensym? x) - (write-char #\G p) - (fasl-write (gensym->unique-string x) p h - (fasl-write (symbol->string x) p h m))] - [(symbol? x) - (write-char #\M p) - (fasl-write (symbol->string x) p h m)] - [(code? x) - (write-char #\X p) - (let ([code-vec (code-code-vec x)] - [reloc-vec (code-reloc-vec x)] - [closure-size (code-closure-size x)]) - (write-int (string-length code-vec) p) - (write-int (fx* (vector-length reloc-vec) 4) p) - (write-int closure-size p) - (let f ([i 0] [n (string-length code-vec)]) - (unless (fx= i n) - (write-char (string-ref code-vec i) p) - (f (fxadd1 i) n))) - (let f ([i 0] [n (vector-length reloc-vec)] [m m]) - (if (fx= i n) - m - (let ([b (vector-ref reloc-vec i)]) - (case (car b) - [(object) - (let ([code-idx (cadr b)] [object (caddr b)]) - (write-char #\O p) - (write-int code-idx p) - (let ([m (fasl-write object p h m)]) - (f (fxadd1 i) n m)))] - [(foreign) - (let ([code-idx (cadr b)] [object (caddr b)]) - (write-char #\F p) - (write-int code-idx p) - (let ([m (fasl-write object p h m)]) - (f (fx+ i 2) n m)))] - [(object+off/rel object+off) - (let ([code-idx (cadr b)] - [object (caddr b)] - [object-off (cadddr b)]) - (if (eq? (car b) 'object+off/rel) - (write-char #\J p) - (write-char #\D p)) - (write-int code-idx p) - (write-int object-off p) - (let ([m (fasl-write object p h m)]) - (f (fx+ i 2) n m)))] - [else (error 'fasl-write "invalid reloc byte ~s" b)])))))] - [(record? x) - (let ([rtd (record-type-descriptor x)]) - (cond - [(eq? rtd #%$base-rtd) - ;;; rtd record - (write-char #\R p) - (let ([names (record-type-field-names x)] - [m - (fasl-write (record-type-symbol x) p h - (fasl-write (record-type-name x) p h m))]) - (write-int (length names) p) - (let f ([names names] [m m]) - (cond - [(null? names) m] - [else - (f (cdr names) - (fasl-write (car names) p h m))])))] - [else - ;;; non-rtd record - (write-char #\{ p) - (write-int (length (record-type-field-names rtd)) p) - (let f ([names (record-type-field-names rtd)] - [m (fasl-write rtd p h m)]) - (cond - [(null? names) m] - [else - (f (cdr names) - (fasl-write - ((record-field-accessor rtd (car names)) x) - p h m))]))]))] - [else (error 'fasl-write "~s is not fasl-writable" x)]))) - (define fasl-write - (lambda (x p h m) - (cond - [(immediate? x) (fasl-write-immediate x p) m] - [(get-hash-table h x #f) => - (lambda (mark) - (unless (fixnum? mark) - (error 'fasl-write "BUG: invalid mark ~s" mark)) - (cond - [(fx= mark 0) ; singly referenced - (do-write x p h m)] - [(fx> mark 0) ; marked but not written - (put-hash-table! h x (fx- 0 m)) - (write-char #\> p) - (write-int m p) - (do-write x p h (fxadd1 m))] - [else - (write-char #\< p) - (write-int (fx- 0 mark) p) - m]))] - [else (error 'fasl-write "BUG: not in hash table ~s" x)]))) - (define make-graph - (lambda (x h) - (unless (immediate? x) - (cond - [(get-hash-table h x #f) => - (lambda (i) - (put-hash-table! h x (fxadd1 i)))] - [else - (put-hash-table! h x 0) - (cond - [(pair? x) - (make-graph (car x) h) - (make-graph (cdr x) h)] - [(vector? x) - (let f ([x x] [i 0] [n (vector-length x)]) - (unless (fx= i n) - (make-graph (vector-ref x i) h) - (f x (fxadd1 i) n)))] - [(symbol? x) - (make-graph (symbol->string x) h) - (when (gensym? x) (make-graph (gensym->unique-string x) h))] - [(string? x) (void)] - [(code? x) - (let ([x (code-reloc-vec x)]) - (let f ([i 0] [n (vector-length x)]) - (unless (fx= i n) - (let ([b (vector-ref x i)]) - (case (car b) - [(object) - (make-graph (caddr b) h) - (f (fxadd1 i) n)] - [(object+off/rel object+off foreign) - (make-graph (caddr b) h) - (f (fx+ i 2) n)] - [else (error 'fasl-write "unrecognized reloc ~s" b)] - )))))] - [(record? x) - (when (eq? x #%$base-rtd) - (error 'fasl-write "$base-rtd is not writable")) - (let ([rtd (record-type-descriptor x)]) - (cond - [(eq? rtd #%$base-rtd) - ;;; this is an rtd - (make-graph (record-type-name x) h) - (make-graph (record-type-symbol x) h) - (for-each (lambda (x) (make-graph x h)) - (record-type-field-names x))] - [else - ;;; this is a record - (make-graph rtd h) - (for-each - (lambda (name) - (make-graph ((record-field-accessor rtd name) x) h)) - (record-type-field-names rtd))]))] - [else (error 'fasl-write "~s is not fasl-writable" x)])])))) - (define do-fasl-write - (lambda (x port) - (let ([h (make-hash-table)]) - (make-graph x h) - (write-char #\# port) - (write-char #\@ port) - (write-char #\I port) - (write-char #\K port) - (write-char #\0 port) - (write-char #\1 port) - (fasl-write x port h 1)))) - (primitive-set! 'fasl-write - (case-lambda - [(x) (do-fasl-write x (current-output-port))] - [(x port) - (unless (output-port? port) - (error 'fasl-write "~s is not an output port" port)) - (do-fasl-write x port)]))) - diff --git a/src/libfasl-6.6.ss b/src/libfasl-6.6.ss deleted file mode 100644 index 2cab6ef..0000000 --- a/src/libfasl-6.6.ss +++ /dev/null @@ -1,217 +0,0 @@ - -;;; FASL -;;; -;;; A fasl object is a header followed by one or more objects followed by an -;;; end-of-fasl marker -;;; -;;; The header is the string "#@IK01" -;;; The end of fasl marker is "@" -;;; -;;; An object is either: -;;; "N" : denoting the empty list -;;; "T" : denoting #t -;;; "F" : denoting #f -;;; "E" : denoting the end of file object -;;; "U" : denoting the unspecified value -;;; "I" + 4-bytes : denoting a fixnum (in host byte order) -;;; "C" + 1-byte : denoting a character -;;; "P" + object1 + object2 : a pair -;;; "V" + 4-bytes(n) + object ... : a vector of length n followed by n -;;; objects -;;; "S" + 4-bytes(n) + char ... : a string -;;; "M" + symbol-name : a symbol -;;; "G" + pretty-name + unique-name : a gensym -;;; "R" + rtd-name + rtd-symbol + field-count + field-names -;;; "{" + field-count + rtd + fields -;;; ">" + 4-bytes(i) : mark the next object with index i -;;; "<" + 4-bytes(i) : dereference the object marked with index i -;;; - - -(let () - (define write-fixnum - (lambda (x p) - (unless (fixnum? x) (error 'write-fixnum "not a fixnum ~s" x)) - (write-char (integer->char (fxsll (fxlogand x #x3F) 2)) p) - (write-char (integer->char (fxlogand (fxsra x 6) #xFF)) p) - (write-char (integer->char (fxlogand (fxsra x 14) #xFF)) p) - (write-char (integer->char (fxlogand (fxsra x 22) #xFF)) p))) - (define write-int - (lambda (x p) - (unless (fixnum? x) (error 'write-int "not a fixnum ~s" x)) - (write-char (integer->char (fxlogand x #xFF)) p) - (write-char (integer->char (fxlogand (fxsra x 8) #xFF)) p) - (write-char (integer->char (fxlogand (fxsra x 16) #xFF)) p) - (write-char (integer->char (fxlogand (fxsra x 24) #xFF)) p))) - - (define fasl-write-immediate - (lambda (x p) - (cond - [(null? x) (write-char #\N p)] - [(fixnum? x) - (write-char #\I p) - (write-fixnum x p)] - [(char? x) - (write-char #\C p) - (write-char x p)] - [(boolean? x) - (write-char (if x #\T #\F) p)] - [(eof-object? x) (write-char #\E p)] - [(eq? x (void)) (write-char #\U p)] - [else (error 'fasl-write "~s is not a fasl-writable immediate" x)]))) - - (define do-write - (lambda (x p h m) - (cond - [(pair? x) - (write-char #\P p) - (fasl-write (cdr x) p h - (fasl-write (car x) p h m))] - [(vector? x) - (write-char #\V p) - (write-int (vector-length x) p) - (let f ([x x] [i 0] [n (vector-length x)] [m m]) - (cond - [(fx= i n) m] - [else - (f x (fxadd1 i) n - (fasl-write (vector-ref x i) p h m))]))] - [(string? x) - (write-char #\S p) - (write-int (string-length x) p) - (let f ([x x] [i 0] [n (string-length x)]) - (cond - [(fx= i n) m] - [else - (write-char (string-ref x i) p) - (f x (fxadd1 i) n)]))] - [(gensym? x) - (write-char #\G p) - (fasl-write (gensym->unique-string x) p h - (fasl-write (symbol->string x) p h m))] - [(symbol? x) - (write-char #\M p) - (fasl-write (symbol->string x) p h m)] - [(code? x) - (write-char #\x p) - (write-int (code-size x) p) - (write-int (code-closure-size x) p) - (let f ([i 0] [n (code-size x)]) - (unless (fx= i n) - (write-char (integer->char (code-ref x i)) p) - (f (fxadd1 i) n))) - (fasl-write (code-reloc-vector x) p h m)] - [(record? x) - (let ([rtd (record-type-descriptor x)]) - (cond - [(eq? rtd #%$base-rtd) - ;;; rtd record - (write-char #\R p) - (let ([names (record-type-field-names x)] - [m - (fasl-write (record-type-symbol x) p h - (fasl-write (record-type-name x) p h m))]) - (write-int (length names) p) - (let f ([names names] [m m]) - (cond - [(null? names) m] - [else - (f (cdr names) - (fasl-write (car names) p h m))])))] - [else - ;;; non-rtd record - (write-char #\{ p) - (write-int (length (record-type-field-names rtd)) p) - (let f ([names (record-type-field-names rtd)] - [m (fasl-write rtd p h m)]) - (cond - [(null? names) m] - [else - (f (cdr names) - (fasl-write - ((record-field-accessor rtd (car names)) x) - p h m))]))]))] - [else (error 'fasl-write "~s is not fasl-writable" x)]))) - (define fasl-write - (lambda (x p h m) - (cond - [(immediate? x) (fasl-write-immediate x p) m] - [(get-hash-table h x #f) => - (lambda (mark) - (unless (fixnum? mark) - (error 'fasl-write "BUG: invalid mark ~s" mark)) - (cond - [(fx= mark 0) ; singly referenced - (do-write x p h m)] - [(fx> mark 0) ; marked but not written - (put-hash-table! h x (fx- 0 m)) - (write-char #\> p) - (write-int m p) - (do-write x p h (fxadd1 m))] - [else - (write-char #\< p) - (write-int (fx- 0 mark) p) - m]))] - [else (error 'fasl-write "BUG: not in hash table ~s" x)]))) - (define make-graph - (lambda (x h) - (unless (immediate? x) - (cond - [(get-hash-table h x #f) => - (lambda (i) - (put-hash-table! h x (fxadd1 i)))] - [else - (put-hash-table! h x 0) - (cond - [(pair? x) - (make-graph (car x) h) - (make-graph (cdr x) h)] - [(vector? x) - (let f ([x x] [i 0] [n (vector-length x)]) - (unless (fx= i n) - (make-graph (vector-ref x i) h) - (f x (fxadd1 i) n)))] - [(symbol? x) - (make-graph (symbol->string x) h) - (when (gensym? x) (make-graph (gensym->unique-string x) h))] - [(string? x) (void)] - [(code? x) - (make-graph (code-reloc-vector x) h)] - [(record? x) - (when (eq? x #%$base-rtd) - (error 'fasl-write "$base-rtd is not writable")) - (let ([rtd (record-type-descriptor x)]) - (cond - [(eq? rtd #%$base-rtd) - ;;; this is an rtd - (make-graph (record-type-name x) h) - (make-graph (record-type-symbol x) h) - (for-each (lambda (x) (make-graph x h)) - (record-type-field-names x))] - [else - ;;; this is a record - (make-graph rtd h) - (for-each - (lambda (name) - (make-graph ((record-field-accessor rtd name) x) h)) - (record-type-field-names rtd))]))] - [else (error 'fasl-write "~s is not fasl-writable" x)])])))) - (define do-fasl-write - (lambda (x port) - (let ([h (make-hash-table)]) - (make-graph x h) - (write-char #\# port) - (write-char #\@ port) - (write-char #\I port) - (write-char #\K port) - (write-char #\0 port) - (write-char #\1 port) - (fasl-write x port h 1)))) - (primitive-set! 'fasl-write - (case-lambda - [(x) (do-fasl-write x (current-output-port))] - [(x port) - (unless (output-port? port) - (error 'fasl-write "~s is not an output port" port)) - (do-fasl-write x port)]))) - diff --git a/src/libhandlers-6.0.ss b/src/libhandlers-6.0.ss deleted file mode 100644 index f4a50a0..0000000 --- a/src/libhandlers-6.0.ss +++ /dev/null @@ -1,28 +0,0 @@ - -(primitive-set! 'error - (lambda args - (foreign-call "ik_error" args))) - -(primitive-set! '$apply-nonprocedure-error-handler - (lambda (x) - (error 'apply "~s is not a procedure" x))) - -(primitive-set! '$incorrect-args-error-handler - (lambda (p n) - (error 'apply "incorrect number of argument (~s) to ~s" n p))) - -(primitive-set! '$multiple-values-error - (lambda args - (error 'apply - "incorrect number of values ~s returned to single value context" - args))) - -(primitive-set! '$debug - (lambda (x) - (foreign-call "ik_error" (cons "DEBUG" x)))) - -(primitive-set! '$underflow-misaligned-error - (lambda () - (foreign-call "ik_error" "misaligned"))) - - diff --git a/src/libhandlers.fasl b/src/libhandlers.fasl index 768f16c..61b65e1 100644 Binary files a/src/libhandlers.fasl and b/src/libhandlers.fasl differ diff --git a/src/libhash-6.2.ss b/src/libhash-6.2.ss index 282203f..3692620 100644 --- a/src/libhash-6.2.ss +++ b/src/libhash-6.2.ss @@ -8,7 +8,7 @@ (define get-tc (record-field-accessor hash-rtd 2)) ;;; implementation - ;;; directly from Dybvig's + ;;; directly from Dybvig's paper (define tc-pop (lambda (tc) (let ([x ($car tc)]) @@ -22,7 +22,7 @@ (define inthash (lambda (key) - ;static int inthash(int key) { + ;static int inthash(int key) { /* from Bob Jenkin's */ ; key += ~(key << 15); ; key ^= (key >> 10); ; key += (key << 3); diff --git a/src/libhash-9.2.ss b/src/libhash-9.2.ss new file mode 100644 index 0000000..09e103d --- /dev/null +++ b/src/libhash-9.2.ss @@ -0,0 +1,244 @@ + +(let ([hash-rtd (make-record-type '"hash-table" '(hash-vec count tc dlink))]) + ;;; accessors + (define get-vec (record-field-accessor hash-rtd 0)) + (define set-vec! (record-field-mutator hash-rtd 0)) + (define get-count (record-field-accessor hash-rtd 1)) + (define set-count! (record-field-mutator hash-rtd 1)) + (define get-tc (record-field-accessor hash-rtd 2)) + (define get-dlink (record-field-accessor hash-rtd 3)) + ;;; implementation + + ;;; directly from Dybvig's paper + (define tc-pop + (lambda (tc) + (let ([x ($car tc)]) + (if (eq? x ($cdr tc)) + #f + (let ([v ($car x)]) + ($set-car! tc ($cdr x)) + ($set-car! x #f) + ($set-cdr! x #f) + v))))) + + (define inthash + (lambda (key) + ;static int inthash(int key) { /* from Bob Jenkin's */ + ; key += ~(key << 15); + ; key ^= (key >> 10); + ; key += (key << 3); + ; key ^= (key >> 6); + ; key += ~(key << 11); + ; key ^= (key >> 16); + ; return key; + ;} + (let* ([key ($fx+ key ($fxlognot ($fxsll key 15)))] + [key ($fxlogxor key ($fxsra key 10))] + [key ($fx+ key ($fxsll key 3))] + [key ($fxlogxor key ($fxsra key 6))] + [key ($fx+ key ($fxlognot ($fxsll key 11)))] + [key ($fxlogxor key ($fxsra key 16))]) + key))) + + ;;; assq-like lookup + (define direct-lookup + (lambda (x b) + (if (fixnum? b) + #f + (if (eq? x ($tcbucket-key b)) + b + (direct-lookup x ($tcbucket-next b)))))) + + (define rehash-lookup + (lambda (h tc x) + (cond + [(tc-pop tc) => + (lambda (b) + (if (eq? ($tcbucket-next b) #f) + (rehash-lookup h tc x) + (begin + (re-add! h b) + (if (eq? x ($tcbucket-key b)) + b + (rehash-lookup h tc x)))))] + [else #f]))) + + (define get-bucket-index + (lambda (b) + (let ([next ($tcbucket-next b)]) + (if (fixnum? next) + next + (get-bucket-index next))))) + + (define replace! + (lambda (lb x y) + (let ([n ($tcbucket-next lb)]) + (cond + [(eq? n x) + ($set-tcbucket-next! lb y) + (void)] + [else + (replace! n x y)])))) + + (define re-add! + (lambda (h b) + (let ([vec (get-vec h)] + [next ($tcbucket-next b)]) + ;;; first remove it from its old place + (let ([idx + (if (fixnum? next) + next + (get-bucket-index next))]) + (let ([fst ($vector-ref vec idx)]) + (cond + [(eq? fst b) + ($vector-set! vec idx next)] + [else + (replace! fst b next)]))) + ;;; reset the tcbucket-tconc FIRST + ($set-tcbucket-tconc! b (get-tc h)) + ;;; then add it to the new place + (let ([k ($tcbucket-key b)]) + (let ([ih (inthash (pointer-value k))]) + (let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))]) + (let ([n ($vector-ref vec idx)]) + ($set-tcbucket-next! b n) + ($vector-set! vec idx b) + (void)))))))) + + + ;(define hash-remove! + ; (lambda (h x) + ; (let ([vec (get-vec h)] + ; [next ($tcbucket-next b)]) + ; ;;; first remove it from its old place + ; (let ([idx + ; (if (fixnum? next) + ; next + ; (get-bucket-index next))]) + ; (let ([fst ($vector-ref vec idx)]) + ; (cond + ; [(eq? fst b) + ; ($vector-set! vec idx next)] + ; [else + ; (replace! fst b next)])))) + ; (let ([b1 ($tcbucket-dlink-next b)] + ; [b2 ($tcbucket-dlink-prev b)]) + ; ($set-tcbucket-dlink-next! b2 b1) + ; ($set-tcbucket-dlink-prev! b1 b2) + ; (void)))) + + (define get-hash + (lambda (h x v) + (let ([pv (pointer-value x)] + [vec (get-vec h)]) + (let ([ih (inthash pv)]) + (let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))]) + (let ([b ($vector-ref vec idx)]) + (cond + [(or (direct-lookup x b) (rehash-lookup h (get-tc h) x)) + => + (lambda (b) + ($tcbucket-val b))] + [else v]))))))) + + + (define put-hash! + (lambda (h x v) + (let ([pv (pointer-value x)] + [vec (get-vec h)]) + (let ([ih (inthash pv)]) + (let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))]) + (let ([b ($vector-ref vec idx)]) + (cond + [(or (direct-lookup x b) (rehash-lookup h (get-tc h) x)) + => + (lambda (b) + ($set-tcbucket-val! b v) + (void))] + [else + (let ([bucket + ($make-tcbucket (get-tc h) x v ($vector-ref vec idx))]) + (if ($fx= (pointer-value x) pv) + ($vector-set! vec idx bucket) + (let* ([ih (inthash (pointer-value x))] + [idx + ($fxlogand ih ($fx- ($vector-length vec) 1))]) + ($set-tcbucket-next! bucket ($vector-ref vec idx)) + ($vector-set! vec idx bucket))) + (let ([b1 (get-dlink h)]) + (let ([b2 ($tcbucket-dlink-next b1)]) + ($set-tcbucket-dlink-next! bucket b2) + ($set-tcbucket-dlink-prev! bucket b1) + ($set-tcbucket-dlink-next! b1 bucket) + ($set-tcbucket-dlink-prev! b2 bucket)))) + (let ([ct (get-count h)]) + (set-count! h ($fxadd1 ct)) + (when ($fx> ct ($vector-length vec)) + (enlarge-table h)))]))))))) + + (define insert-b + (lambda (b vec mask) + (let* ([x ($tcbucket-key b)] + [pv (pointer-value x)] + [ih (inthash pv)] + [idx ($fxlogand ih mask)] + [next ($tcbucket-next b)]) + ($set-tcbucket-next! b ($vector-ref vec idx)) + ($vector-set! vec idx b) + (unless (fixnum? next) + (insert-b next vec mask))))) + + (define move-all + (lambda (vec1 i n vec2 mask) + (unless ($fx= i n) + (let ([b ($vector-ref vec1 i)]) + (unless (fixnum? b) + (insert-b b vec2 mask)) + (move-all vec1 ($fxadd1 i) n vec2 mask))))) + + (define enlarge-table + (lambda (h) + (let* ([vec1 (get-vec h)] + [n1 ($vector-length vec1)] + [n2 ($fxsll n1 1)] + [vec2 (make-base-vec n2)]) + (move-all vec1 0 n1 vec2 ($fx- n2 1)) + (set-vec! h vec2)))) + + + + (define init-vec + (lambda (v i n) + (if ($fx= i n) + v + (begin + ($vector-set! v i i) + (init-vec v ($fxadd1 i) n))))) + + (define make-base-vec + (lambda (n) + (init-vec (make-vector n) 0 n))) + + ;;; public interface + (primitive-set! 'hash-table? (record-predicate hash-rtd)) + (primitive-set! 'make-hash-table + (let ([make (record-constructor hash-rtd)]) + (lambda () + (let ([x (cons #f #f)]) + (let ([tc (cons x x)]) + (make (make-base-vec 32) 0 tc + (let ([b ($make-tcbucket tc #f #f #f)]) + ($set-tcbucket-dlink-next! b b) + ($set-tcbucket-dlink-prev! b b) + b))))))) + (primitive-set! 'get-hash-table + (lambda (h x v) + (if (hash-table? h) + (get-hash h x v) + (error 'get-hash-table "~s is not a hash table" h)))) + (primitive-set! 'put-hash-table! + (lambda (h x v) + (if (hash-table? h) + (put-hash! h x v) + (error 'put-hash-table! "~s is not a hash table" h))))) diff --git a/src/libintelasm-6.0.ss b/src/libintelasm-6.0.ss deleted file mode 100644 index 38900da..0000000 --- a/src/libintelasm-6.0.ss +++ /dev/null @@ -1,921 +0,0 @@ - -;;; -;;; assuming the existence of a code manager, this file defines an assember -;;; that takes lists of assembly code and produces a list of code objects -;;; - - ;;; add - ;;; and - ;;; cmp - ;;; call - ;;; cltd - ;;; idiv - ;;; imull - ;;; ja - ;;; jae - ;;; jb - ;;; jbe - ;;; je - ;;; jg - ;;; jge - ;;; jl - ;;; jle - ;;; jne - ;;; jmp - ;;; movb - ;;; movl - ;;; negl - ;;; notl - ;;; orl - ;;; popl - ;;; pushl - ;;; ret - ;;; sall - ;;; sarl - ;;; shrl - ;;; sete - ;;; setg - - -(let () - -(define fold - (lambda (f init ls) - (cond - [(null? ls) init] - [else - (f (car ls) (fold f init (cdr ls)))]))) - -(define convert-instructions - (lambda (ls) - (fold convert-instruction '() ls))) - -(define register-mapping - '([%eax 32 0] - [%ecx 32 1] - [%edx 32 2] - [%ebx 32 3] - [%esp 32 4] - [%ebp 32 5] - [%esi 32 6] - [%edi 32 7] - [%al 8 0] - [%cl 8 1] - [%dl 8 2] - [%bl 8 3] - [%ah 8 4] - [%ch 8 5] - [%dh 8 6] - [%bh 8 7] - [/0 0 0] - [/1 0 1] - [/2 0 2] - [/3 0 3] - [/4 0 4] - [/5 0 5] - [/6 0 6] - [/7 0 7] - )) - -(define register-index - (lambda (x) - (cond - [(assq x register-mapping) => caddr] - [else (error 'register-index "not a register ~s" x)]))) - -(define reg32? - (lambda (x) - (cond - [(assq x register-mapping) => - (lambda (x) (fx= (cadr x) 32))] - [else #f]))) - -(define reg8? - (lambda (x) - (cond - [(assq x register-mapping) => - (lambda (x) (fx= (cadr x) 8))] - [else #f]))) - -(define reg? - (lambda (x) - (assq x register-mapping))) - -(define check-len - (lambda (x) - (define instr-len - '([ret] - [movl s d] - [movb s d] - [addl s d] - [subl s d] - [sall s d] - [sarl s d] - [shrl s d] - [andl s d] - [xorl s d] - [orl s d] - [cmpl s d] - [imull s d] - [notl d] - [negl d] - [idivl d] - [pushl d] - [popl d] - [jmp d] - [call d] - [ja d] - [jae d] - [jb d] - [jbe d] - [je d] - [jg d] - [jge d] - [jl d] - [jle d] - [jna d] - [jnae d] - [jnb d] - [jnbe d] - [jne d] - [jng d] - [jnge d] - [jnl d] - [jnle d] - [seta d] - [setae d] - [setb d] - [setbe d] - [sete d] - [setg d] - [setge d] - [setl d] - [setle d] - [setna d] - [setnae d] - [setnb d] - [setnbe d] - [setne d] - [setng d] - [setnge d] - [setnl d] - [setnle d] - [cltd] - [nop] - [byte x] - [byte-vector x] - [int x] - [label x] - [label-address x] - [current-frame-offset] - )) - (cond - [(assq (car x) instr-len) => - (lambda (p) - (unless (fx= (length x) (length p)) - (error 'assembler "invalid instruction format ~s" x)))] - [else (error 'assembler "unknown instruction ~s" x)]))) - -(define with-args - (lambda (ls f) - (apply f (cdr ls)))) - -(define byte - (lambda (x) - (cons 'byte (fxlogand x 255)))) - - -(define word - (lambda (x) - (cons 'word x))) - -(define reloc-word - (lambda (x) - (cons 'reloc-word x))) - -(define reloc-word+ - (lambda (x d) - (list* 'reloc-word+ x d))) - -(define list*-aux - (lambda (ls ls*) - (cond - [(null? ls*) ls] - [else (cons ls (list*-aux (car ls*) (cdr ls*)))]))) - -(define list* - (lambda (ls . ls*) - (list*-aux ls ls*))) - -(define byte? - (lambda (x) - (and (fixnum? x) - (fx<= x 127) - (fx<= -128 x)))) - -(define mem? - (lambda (x) - (and (list? x) - (fx= (length x) 3) - (eq? (car x) 'disp) - (or (imm? (cadr x)) - (reg? (cadr x))) - (or (imm? (caddr x)) - (reg? (caddr x)))))) - -(define small-disp? - (lambda (x) - (and (mem? x) - (byte? (cadr x))))) - - -(define CODE - (lambda (n ac) - (cons (byte n) ac))) - -(define CODE+r - (lambda (n r ac) - (cons (byte (fxlogor n (register-index r))) ac))) - -(define ModRM - (lambda (mod reg r/m ac) - (cons (byte (fxlogor - (register-index r/m) - (fxlogor - (fxsll (register-index reg) 3) - (fxsll mod 6)))) - (if (and (not (fx= mod 3)) (eq? r/m '%esp)) - (cons (byte #x24) ac) - ac)))) - -(define IMM32 - (lambda (n ac) - (cond - [(int? n) - (let ([n (cadr n)]) - (list* (byte n) - (byte (fxsra n 8)) - (byte (fxsra n 16)) - (byte (fxsra n 24)) - ac))] - [(obj? n) - (let ([v (cadr n)]) - (if (immediate? v) - (cons (word v) ac) - (cons (reloc-word v) ac)))] - [(obj+? n) - (let ([v (cadr n)] [d (caddr n)]) - (cons (reloc-word+ v d) ac))] - [(label-address? n) - (cons (cons 'label-addr (label-name n)) ac)] - [(foreign? n) - (cons (cons 'foreign-label (label-name n)) ac)] - [else (error 'IMM32 "invalid ~s" n)]))) - - -(define IMM8 - (lambda (n ac) - (cond - [(int? n) - (let ([n (cadr n)]) - (list* (byte n) ac))] - [else (error 'IMM8 "invalid ~s" n)]))) - - -(define imm? - (lambda (x) - (or (int? x) - (obj? x) - (obj+? x) - (label-address? x) - (foreign? x)))) - -(define foreign? - (lambda (x) - (and (pair? x) (eq? (car x) 'foreign-label)))) - - -(define imm8? - (lambda (x) - (and (int? x) (byte? (cadr x))))) - -(define label? - (lambda (x) - (cond - [(and (pair? x) (eq? (car x) 'label)) - (let ([d (cdr x)]) - (unless (and (null? (cdr d)) - (symbol? (car d))) - (error 'assemble "invalid label ~s" x))) - #t] - [else #f]))) - -(define label-address? - (lambda (x) - (cond - [(and (pair? x) (eq? (car x) 'label-address)) - (let ([d (cdr x)]) - (unless (and (null? (cdr d)) - (or (symbol? (car d)) - (string? (car d)))) - (error 'assemble "invalid label-address ~s" x))) - #t] - [else #f]))) - -(define label-name - (lambda (x) (cadr x))) - -(define int? - (lambda (x) - (and (pair? x) (eq? (car x) 'int)))) - -(define obj? - (lambda (x) - (and (pair? x) (eq? (car x) 'obj)))) - -(define obj+? - (lambda (x) - (and (pair? x) (eq? (car x) 'obj+)))) - -(define CODErri - (lambda (c d s i ac) - (cond - [(imm8? i) - (CODE c (ModRM 1 d s (IMM8 i ac)))] - [(reg? i) - (CODE c (ModRM i d s ac))] - [else - (CODE c (ModRM 2 d s (IMM32 i ac)))]))) - -(define CODErr - (lambda (c d s ac) - (CODE c (ModRM 3 d s ac)))) - -(define CODEri - (lambda (c d i ac) - (CODE+r c d (IMM32 i ac)))) - - -(define RegReg - (lambda (r1 r2 r3 ac) - (cond - [(eq? r3 '%esp) (error 'assembler "BUG: invalid src %esp")] - [(eq? r1 '%ebp) (error 'assembler "BUG: invalid src %ebp")] - [else -;;; (parameterize ([print-radix 16]) -;;; (printf "REGREG ~s ~s ~s\n" r1 r2 r3) -;;; (printf "REGREG ~s ~s\n" -;;; (byte (fxlogor 4 (fxsll (register-index r1) 3))) -;;; (byte (fxlogor (register-index r2) -;;; (fxsll (register-index r3) 3))))) - (list* - (byte (fxlogor 4 (fxsll (register-index r1) 3))) - (byte (fxlogor (register-index r2) - (fxsll (register-index r3) 3))) - ac)]))) - - -;;(define CODErd -;; (lambda (c r1 disp ac) -;; (with-args disp -;; (lambda (i/r r2) -;; (if (reg? i/r) -;; (CODE c (RegReg r1 i/r r2 ac)) -;; (CODErri c r1 r2 i/r ac)))))) - - -(define IMM32*2 - (lambda (i1 i2 ac) - (cond - [(and (int? i1) (obj? i2)) - (let ([d (cadr i1)] [v (cadr i2)]) - (cons (reloc-word+ v d) ac))] - [else (error 'assemble "IMM32*2 ~s ~s" i1 i2)]))) - - -(define CODErd - (lambda (c r1 disp ac) - (with-args disp - (lambda (a1 a2) - (cond - [(and (reg? a1) (reg? a2)) - (CODE c (RegReg r1 a1 a2 ac))] - [(and (imm? a1) (reg? a2)) - (CODErri c r1 a2 a1 ac)] - [(and (imm? a1) (imm? a2)) - (CODE c - (ModRM 0 r1 '/5 - (IMM32*2 a1 a2 ac)))] - [else (error 'CODErd "unhandled ~s" disp)]))))) - -(define CODEdi - (lambda (c disp n ac) - (with-args disp - (lambda (i r) - (CODErri c '/0 r i (IMM32 n ac)))))) - -(define CODEdi8 - (lambda (c disp n ac) - (with-args disp - (lambda (i r) - (CODErri c '/0 r i (IMM8 n ac)))))) - - - - -(define convert-instruction - (lambda (a ac) - (define who 'assemble) - (check-len a) - (case (car a) - [(ret) (CODE #xC3 ac)] - [(cltd) (CODE #x99 ac)] - [(movl) - (with-args a - (lambda (src dst) - (cond - [(and (imm? src) (reg? dst)) (CODEri #xB8 dst src ac)] - [(and (imm? src) (mem? dst)) (CODEdi #xC7 dst src ac)] - [(and (reg? src) (reg? dst)) (CODErr #x89 src dst ac)] - [(and (reg? src) (mem? dst)) (CODErd #x89 src dst ac)] - [(and (mem? src) (reg? dst)) (CODErd #x8B dst src ac)] - [else (error who "invalid ~s" a)])))] - [(movb) - (with-args a - (lambda (src dst) - (cond - ;[(and (imm8? src) (reg8? dst)) (CODEri #xB0 dst src ac)] - [(and (imm8? src) (mem? dst)) (CODEdi8 #xC6 dst src ac)] - ;[(and (reg8? src) (reg8? dst)) (CODErr #x88 src dst ac)] - [(and (reg8? src) (mem? dst)) (CODErd #x88 src dst ac)] - [(and (mem? src) (reg8? dst)) (CODErd #x8A dst src ac)] - [else (error who "invalid ~s" a)])))] - [(addl) - (with-args a - (lambda (src dst) - (cond - ;;; add imm -> reg - [(and (imm8? src) (reg? dst)) - (CODE #x83 (ModRM 3 '/0 dst (IMM8 src ac)))] - [(and (imm? src) (eq? dst '%eax)) - (CODE #x05 (IMM32 src ac))] - [(and (imm? src) (reg? dst)) - (CODE #x81 (ModRM 3 '/0 dst (IMM32 src ac)))] - ;;; add reg -> reg - [(and (reg? src) (reg? dst)) - (CODE #x01 (ModRM 3 src dst ac))] - ;;; add mem -> reg - [(and (mem? src) (reg? dst)) - (CODErd #x03 dst src ac)] - ;;; add imm -> mem (not needed) - ;;; add reg -> mem (not needed) - [else (error who "invalid ~s" a)])))] - [(subl) - (with-args a - (lambda (src dst) - (cond - ;;; imm -> reg - [(and (imm8? src) (reg? dst)) - (CODE #x83 (ModRM 3 '/5 dst (IMM8 src ac)))] - [(and (imm? src) (eq? dst '%eax)) - (CODE #x2D (IMM32 src ac))] - [(and (imm? src) (reg? dst)) - (CODE #x81 (ModRM 3 '/5 dst (IMM32 src ac)))] - ;;; reg -> reg - [(and (reg? src) (reg? dst)) - (CODE #x29 (ModRM 3 src dst ac))] - ;;; mem -> reg - [(and (mem? src) (reg? dst)) - (CODErd #x2B dst src ac)] - ;;; imm -> mem (not needed) - ;;; reg -> mem (not needed) - [else (error who "invalid ~s" a)])))] - [(sall) - (with-args a - (lambda (src dst) - (cond - [(and (equal? '(int 1) src) (reg? dst)) - (CODE #xD1 (ModRM 3 '/4 dst ac))] - [(and (imm8? src) (reg? dst)) - (CODE #xC1 (ModRM 3 '/4 dst (IMM8 src ac)))] - [(and (eq? src '%cl) (reg? dst)) - (CODE #xD3 (ModRM 3 '/4 dst ac))] - [else (error who "invalid ~s" a)])))] - [(shrl) - (with-args a - (lambda (src dst) - (cond - [(and (equal? '(int 1) src) (reg? dst)) - (CODE #xD1 (ModRM 3 '/5 dst ac))] - [(and (imm8? src) (reg? dst)) - (CODE #xC1 (ModRM 3 '/5 dst (IMM8 src ac)))] - [(and (eq? src '%cl) (reg? dst)) - (CODE #xD3 (ModRM 3 '/5 dst ac))] - [else (error who "invalid ~s" a)])))] - [(sarl) - (with-args a - (lambda (src dst) - (cond - [(and (equal? '(int 1) src) (reg? dst)) - (CODE #xD1 (ModRM 3 '/7 dst ac))] - [(and (imm8? src) (reg? dst)) - (CODE #xC1 (ModRM 3 '/7 dst (IMM8 src ac)))] - [(and (eq? src '%cl) (reg? dst)) - (CODE #xD3 (ModRM 3 '/7 dst ac))] - [else (error who "invalid ~s" a)])))] - [(andl) ; similar to add - (with-args a - (lambda (src dst) - (cond - ;;; and imm -> reg - [(and (imm8? src) (reg? dst)) - (CODE #x83 (ModRM 3 '/4 dst (IMM8 src ac)))] - [(and (imm? src) (eq? dst '%eax)) - (CODE #x25 (IMM32 src ac))] - [(and (imm? src) (reg? dst)) - (CODE #x81 (ModRM 3 '/4 dst (IMM32 src ac)))] - ;;; and reg -> reg - [(and (reg? src) (reg? dst)) - (CODE #x21 (ModRM 3 src dst ac))] - ;;; and mem -> reg - [(and (mem? src) (reg? dst)) - (CODErd #x23 dst src ac)] - [else (error who "invalid ~s" a)])))] - [(orl) ; similar to add - (with-args a - (lambda (src dst) - (cond - ;;; or imm -> reg - [(and (imm8? src) (reg? dst)) - (CODE #x83 (ModRM 3 '/1 dst (IMM8 src ac)))] - [(and (imm? src) (eq? dst '%eax)) - (CODE #x0D (IMM32 src ac))] - [(and (imm? src) (reg? dst)) - (CODE #x81 (ModRM 3 '/1 dst (IMM32 src ac)))] - ;;; or reg -> reg - [(and (reg? src) (reg? dst)) - (CODE #x09 (ModRM 3 src dst ac))] - ;;; or mem -> reg - [(and (mem? src) (reg? dst)) - (CODErd #x0B dst src ac)] - [else (error who "invalid ~s" a)])))] - [(xorl) ; similar to add - (with-args a - (lambda (src dst) - (cond - ;;; or imm -> reg - ;[(and (imm8? src) (reg? dst)) - ; (CODE #x83 (ModRM 3 '/1 dst (IMM8 src ac)))] - ;[(and (imm? src) (eq? dst '%eax)) - ; (CODE #x0D (IMM32 src ac))] - ;[(and (imm? src) (reg? dst)) - ; (CODE #x81 (ModRM 3 '/1 dst (IMM32 src ac)))] - ;;; or reg -> reg - [(and (reg? src) (reg? dst)) - (CODE #x31 (ModRM 3 src dst ac))] - ;;; or mem -> reg - [(and (mem? src) (reg? dst)) - (CODErd #x33 dst src ac)] - [else (error who "invalid ~s" a)])))] - [(cmpl) - (with-args a - (lambda (src dst) - (cond - [(and (imm8? src) (reg? dst)) - (CODE #x83 (ModRM 3 '/7 dst (IMM8 src ac)))] - [(and (imm? src) (eq? dst '%eax)) - (CODE #x3D (IMM32 src ac))] - [(and (reg? src) (reg? dst)) - (CODE #x39 (ModRM 3 src dst ac))] - [(and (mem? src) (reg? dst)) - (CODErd #x3B dst src ac)] - [(and (imm8? src) (mem? dst)) - (CODErd #x83 '/7 dst (IMM8 src ac))] - [(and (imm? src) (mem? dst)) - (CODErd #x81 '/7 dst (IMM32 src ac))] - [else (error who "invalid ~s" a)])))] - [(imull) - (with-args a - (lambda (src dst) - (cond - [(and (imm8? src) (reg? dst)) - (CODE #x6B (ModRM 3 dst dst (IMM8 src ac)))] - [(and (imm? src) (reg? dst)) - (CODE #x69 (ModRM 3 dst dst (IMM32 src ac)))] - [(and (reg? src) (reg? dst)) - (CODE #x0F (CODE #xAF (ModRM 3 dst src ac)))] - [(and (mem? src) (reg? dst)) - (CODE #x0F (CODErd #xAF dst src ac))] - [else (error who "invalid ~s" a)])))] - [(idivl) - (with-args a - (lambda (dst) - (cond - [(reg? dst) - (CODErr #xF7 '/7 dst ac)] - [(mem? dst) - (CODErd #xF7 '/7 dst ac)] - [else (error who "invalid ~s" a)])))] - [(pushl) - (with-args a - (lambda (dst) - (cond - [(imm8? dst) - (CODE #x6A (IMM8 dst ac))] - [(imm? dst) - (CODE #x68 (IMM32 dst ac))] - [(reg? dst) - (CODE+r #x50 dst ac)] - [(mem? dst) - (CODErd #xFF '/6 dst ac)] - [else (error who "invalid ~s" a)])))] - [(popl) - (with-args a - (lambda (dst) - (cond - [(reg? dst) - (CODE+r #x58 dst ac)] - [(mem? dst) - (CODErd #x8F '/0 dst ac)] - [else (error who "invalid ~s" a)])))] - [(notl) - (with-args a - (lambda (dst) - (cond - [(reg? dst) - (CODE #xF7 (ModRM 3 '/2 dst ac))] - [(mem? dst) - (CODErd #xF7 '/7 dst ac)] - [else (error who "invalid ~s" a)])))] - [(negl) - (with-args a - (lambda (dst) - (cond - [(reg? dst) - (CODE #xF7 (ModRM 3 '/3 dst ac))] - [else (error who "invalid ~s" a)])))] - [(jmp) - (with-args a - (lambda (dst) - (cond - [(label? dst) - (CODE #xE9 (cons (cons 'relative (label-name dst)) ac))] - [(imm? dst) - (CODE #xE9 (IMM32 dst ac))] - [(mem? dst) - (CODErd #xFF '/4 dst ac)] - [else (error who "invalid jmp in ~s" a)])))] - [(call) - (with-args a - (lambda (dst) - (cond - [(imm? dst) - (CODE #xE8 (IMM32 dst ac))] - [(label? dst) - (CODE #xE8 (cons (cons 'relative (label-name dst)) ac))] - [(mem? dst) - (CODErd #xFF '/2 dst ac)] - [(reg? dst) - (CODE #xFF (ModRM 3 '/2 dst ac))] - [else (error who "invalid jmp in ~s" a)])))] - [(seta setae setb setbe sete setg setge setl setle - setna setnae setnb setnbe setne setng setnge setnl setnle) - (let* ([table - '([seta #x97] [setna #x96] - [setae #x93] [setnae #x92] - [setb #x92] [setnb #x93] - [setbe #x96] [setnbe #x97] - [setg #x9F] [setng #x9E] - [setge #x9D] [setnge #x9C] - [setl #x9C] [setnl #x9D] - [setle #x9E] [setnle #x9F] - [sete #x94] [setne #x95])] - [lookup - (lambda (x) - (cond - [(assq x table) => cadr] - [else (error who "invalid cset ~s" x)]))]) - (with-args a - (lambda (dst) - (cond - [(reg8? dst) - (CODE #x0F - (CODE (lookup (car a)) - (ModRM 3 '/0 dst ac)))] - [else (error who "invalid ~s" a)]))))] - [(ja jae jb jbe je jg jge jl jle - jna jnae jnb jnbe jne jng jnge jnl jnle) - (let* ([table - '([je #x84] [jne #x85] - [ja #x87] [jna #x86] - [jae #x83] [jnae #x82] - [jb #x82] [jnb #x83] - [jbe #x86] [jnbe #x87] - [jg #x8F] [jng #x8E] - [jge #x8D] [jnge #x8C] - [jl #x8C] [jnl #x8D] - [jle #x8E] [jnle #x8F])] - [lookup - (lambda (x) - (cond - [(assq x table) => cadr] - [else (error who "invalid cmp ~s" x)]))]) - (with-args a - (lambda (dst) - (cond - [(imm? dst) - (CODE #x0F (CODE (lookup (car a)) (IMM32 dst ac)))] - [(label? dst) - (CODE #x0F - (CODE (lookup (car a)) - (cons (cons 'relative (label-name dst)) ac)))] - [else (error who "invalid ~s" a)]))))] - [(byte) - (with-args a - (lambda (x) - (unless (byte? x) (error who "invalid instruction ~s" a)) - (cons (byte x) ac)))] - [(byte-vector) - (with-args a - (lambda (x) (append (map byte (vector->list x)) ac)))] - [(int) (IMM32 a ac)] - [(label) - (with-args a - (lambda (L) - (unless (symbol? L) (error who "invalid instruction ~s" a)) - (cons (cons 'label L) ac)))] - [(label-address) - (with-args a - (lambda (L) - (unless (symbol? L) (error who "invalid instruction ~s" a)) - (cons (cons 'label-addr L) ac)))] - [(current-frame-offset) - (cons '(current-frame-offset) ac)] - [(nop) ac] - [else - (error who "unknown instruction ~s" a)]))) - -(define diff - (lambda (ls x) - (cond - [(eq? ls x) '()] - [else (cons (car ls) (diff (cdr ls) x))]))) - -(define hex-table - '#(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 - #\8 #\9 #\A #\B #\C #\D #\E #\F)) - -(define write/x - (lambda (x) - (case (car x) - [(byte) - (display "0x") - (display (vector-ref hex-table (fxsra (cdr x) 4))) - (display (vector-ref hex-table (fxlogand (cdr x) 15))) - (display " ")] - [else (write x)]))) - - -(define compute-code-size - (lambda (ls) - (fold (lambda (x ac) - (case (car x) - [(byte) (fx+ ac 1)] - [(word reloc-word reloc-word+ label-addr foreign-label - relative current-frame-offset) - (fx+ ac 4)] - [(label) ac] - [else (error 'compute-code-size "unknown instr ~s" x)])) - 0 - ls))) - - -(define compute-reloc-size - (lambda (ls) - (fold (lambda (x ac) - (case (car x) - [(reloc-word ) (fx+ ac 4)] - [(reloc-word+) (fx+ ac 8)] - [(relative label-addr foreign-label) (fx+ ac 8)] - [(word byte label current-frame-offset) ac] - [else (error 'compute-reloc-size "unknown instr ~s" x)])) - 0 - ls))) - -(define set-label-loc! - (lambda (x loc) - (when (getprop x '*label-loc*) - (error 'compile "label ~s is already defined" x)) - (putprop x '*label-loc* loc))) - -(define label-loc - (lambda (x) - (or (getprop x '*label-loc*) - (error 'compile "undefined label ~s" x)))) - - -(define unset-label-loc! - (lambda (x) - (remprop x '*label-loc*))) - - -(define whack-instructions - (lambda (x ls) - (define f - (lambda (ls idx reloc) - (cond - [(null? ls) reloc] - [else - (let ([a (car ls)]) - (case (car a) - [(byte) - (set-code-byte! x idx (cdr a)) - (f (cdr ls) (fx+ idx 1) reloc)] - [(reloc-word reloc-word+) - (f (cdr ls) (fx+ idx 4) (cons (cons idx a) reloc))] - [(relative label-addr foreign-label) - (f (cdr ls) (fx+ idx 4) (cons (cons idx a) reloc))] - [(word) - (let ([v (cdr a)]) - (set-code-word! x idx v) - (f (cdr ls) (fx+ idx 4) reloc))] - [(current-frame-offset) - (set-code-word! x idx idx) - (f (cdr ls) (fx+ idx 4) reloc)] - [(label) - (set-label-loc! (cdr a) (cons x idx)) - (f (cdr ls) idx reloc)] - [else - (error 'whack-instructions "unknown instr ~s" a)]))]))) - (f ls 0 '()))) - -(define wordsize 4) - -(define whack-reloc - (lambda (code) - (define reloc-idx 0) - (lambda (r) - (let ([idx (car r)] [type (cadr r)] [v (cddr r)]) - (case type - [(reloc-word) - (set-code-object! code v idx reloc-idx) - (set! reloc-idx (fxadd1 reloc-idx))] - [(foreign-label) - (set-code-foreign-object! code v idx reloc-idx) - (set! reloc-idx (fx+ reloc-idx 2))] - [(reloc-word+) - (let ([obj (car v)] [disp (cdr v)]) - (set-code-object+offset! code obj idx disp reloc-idx) - (set! reloc-idx (fx+ reloc-idx 2)))] - [(label-addr) - (let ([loc (label-loc v)]) - (let ([obj (car loc)] [off (cdr loc)]) - (set-code-object+offset! - code obj idx (fx+ off 11) reloc-idx))) - (set! reloc-idx (fx+ reloc-idx 2))] - [(relative) - (let ([loc (label-loc v)]) - (let ([obj (car loc)] [off (cdr loc)]) - (set-code-object+offset/rel! - code obj idx (fx+ off 11) reloc-idx))) - (set! reloc-idx (fx+ reloc-idx 2))] - [else (error 'whack-reloc "invalid reloc type ~s" type)])) - ))) - - -;;; (define list->code -;;; (lambda (ls) -;;; (let ([ls (convert-instructions ls)]) -;;; (let ([n (compute-code-size ls)] -;;; [m (compute-reloc-size ls)]) -;;; (let ([x (make-code n m 1)]) -;;; (let ([reloc* (whack-instructions x ls)]) -;;; (for-each (whack-reloc x) reloc*)) -;;; (make-code-executable! x) -;;; x))))) - -(define list*->code* - (lambda (ls*) - (let ([closure-size* (map car ls*)] - [ls* (map cdr ls*)]) - (let ([ls* (map convert-instructions ls*)]) - (let ([n* (map compute-code-size ls*)] - [m* (map compute-reloc-size ls*)]) - (let ([code* (map (lambda (n m c) (make-code n m c)) - n* - m* - closure-size*)]) - (let ([reloc** (map whack-instructions code* ls*)]) - (for-each - (lambda (code reloc*) - (for-each (whack-reloc code) reloc*)) - code* reloc**) - (for-each make-code-executable! code*) - code*))))))) - -(define list->code - (lambda (ls) - (car (list*->code* (list ls))))) - -(primitive-set! 'list*->code* list*->code*) -) diff --git a/src/libintelasm-6.4.ss b/src/libintelasm-6.4.ss deleted file mode 100644 index e1094b5..0000000 --- a/src/libintelasm-6.4.ss +++ /dev/null @@ -1,920 +0,0 @@ - -;;; -;;; assuming the existence of a code manager, this file defines an assember -;;; that takes lists of assembly code and produces a list of code objects -;;; - - ;;; add - ;;; and - ;;; cmp - ;;; call - ;;; cltd - ;;; idiv - ;;; imull - ;;; ja - ;;; jae - ;;; jb - ;;; jbe - ;;; je - ;;; jg - ;;; jge - ;;; jl - ;;; jle - ;;; jne - ;;; jmp - ;;; movb - ;;; movl - ;;; negl - ;;; notl - ;;; orl - ;;; popl - ;;; pushl - ;;; ret - ;;; sall - ;;; sarl - ;;; shrl - ;;; sete - ;;; setg - - -(let () - -(define fold - (lambda (f init ls) - (cond - [(null? ls) init] - [else - (f (car ls) (fold f init (cdr ls)))]))) - -(define convert-instructions - (lambda (ls) - (fold convert-instruction '() ls))) - -(define register-mapping - '([%eax 32 0] - [%ecx 32 1] - [%edx 32 2] - [%ebx 32 3] - [%esp 32 4] - [%ebp 32 5] - [%esi 32 6] - [%edi 32 7] - [%al 8 0] - [%cl 8 1] - [%dl 8 2] - [%bl 8 3] - [%ah 8 4] - [%ch 8 5] - [%dh 8 6] - [%bh 8 7] - [/0 0 0] - [/1 0 1] - [/2 0 2] - [/3 0 3] - [/4 0 4] - [/5 0 5] - [/6 0 6] - [/7 0 7] - )) - -(define register-index - (lambda (x) - (cond - [(assq x register-mapping) => caddr] - [else (error 'register-index "not a register ~s" x)]))) - -(define reg32? - (lambda (x) - (cond - [(assq x register-mapping) => - (lambda (x) (fx= (cadr x) 32))] - [else #f]))) - -(define reg8? - (lambda (x) - (cond - [(assq x register-mapping) => - (lambda (x) (fx= (cadr x) 8))] - [else #f]))) - -(define reg? - (lambda (x) - (assq x register-mapping))) - -(define check-len - (lambda (x) - (define instr-len - '([ret] - [movl s d] - [movb s d] - [addl s d] - [subl s d] - [sall s d] - [sarl s d] - [shrl s d] - [andl s d] - [xorl s d] - [orl s d] - [cmpl s d] - [imull s d] - [notl d] - [negl d] - [idivl d] - [pushl d] - [popl d] - [jmp d] - [call d] - [ja d] - [jae d] - [jb d] - [jbe d] - [je d] - [jg d] - [jge d] - [jl d] - [jle d] - [jna d] - [jnae d] - [jnb d] - [jnbe d] - [jne d] - [jng d] - [jnge d] - [jnl d] - [jnle d] - [seta d] - [setae d] - [setb d] - [setbe d] - [sete d] - [setg d] - [setge d] - [setl d] - [setle d] - [setna d] - [setnae d] - [setnb d] - [setnbe d] - [setne d] - [setng d] - [setnge d] - [setnl d] - [setnle d] - [cltd] - [nop] - [byte x] - [byte-vector x] - [int x] - [label x] - [label-address x] - [current-frame-offset] - )) - (cond - [(assq (car x) instr-len) => - (lambda (p) - (unless (fx= (length x) (length p)) - (error 'assembler "invalid instruction format ~s" x)))] - [else (error 'assembler "unknown instruction ~s" x)]))) - -(define with-args - (lambda (ls f) - (apply f (cdr ls)))) - -(define byte - (lambda (x) - (cons 'byte (fxlogand x 255)))) - - -(define word - (lambda (x) - (cons 'word x))) - -(define reloc-word - (lambda (x) - (cons 'reloc-word x))) - -(define reloc-word+ - (lambda (x d) - (list* 'reloc-word+ x d))) - -(define list*-aux - (lambda (ls ls*) - (cond - [(null? ls*) ls] - [else (cons ls (list*-aux (car ls*) (cdr ls*)))]))) - -(define list* - (lambda (ls . ls*) - (list*-aux ls ls*))) - -(define byte? - (lambda (x) - (and (fixnum? x) - (fx<= x 127) - (fx<= -128 x)))) - -(define mem? - (lambda (x) - (and (list? x) - (fx= (length x) 3) - (eq? (car x) 'disp) - (or (imm? (cadr x)) - (reg? (cadr x))) - (or (imm? (caddr x)) - (reg? (caddr x)))))) - -(define small-disp? - (lambda (x) - (and (mem? x) - (byte? (cadr x))))) - - -(define CODE - (lambda (n ac) - (cons (byte n) ac))) - -(define CODE+r - (lambda (n r ac) - (cons (byte (fxlogor n (register-index r))) ac))) - -(define ModRM - (lambda (mod reg r/m ac) - (cons (byte (fxlogor - (register-index r/m) - (fxlogor - (fxsll (register-index reg) 3) - (fxsll mod 6)))) - (if (and (not (fx= mod 3)) (eq? r/m '%esp)) - (cons (byte #x24) ac) - ac)))) - -(define IMM32 - (lambda (n ac) - (cond - [(int? n) - (let ([n (cadr n)]) - (list* (byte n) - (byte (fxsra n 8)) - (byte (fxsra n 16)) - (byte (fxsra n 24)) - ac))] - [(obj? n) - (let ([v (cadr n)]) - (if (immediate? v) - (cons (word v) ac) - (cons (reloc-word v) ac)))] - [(obj+? n) - (let ([v (cadr n)] [d (caddr n)]) - (cons (reloc-word+ v d) ac))] - [(label-address? n) - (cons (cons 'label-addr (label-name n)) ac)] - [(foreign? n) - (cons (cons 'foreign-label (label-name n)) ac)] - [else (error 'IMM32 "invalid ~s" n)]))) - - -(define IMM8 - (lambda (n ac) - (cond - [(int? n) - (let ([n (cadr n)]) - (list* (byte n) ac))] - [else (error 'IMM8 "invalid ~s" n)]))) - - -(define imm? - (lambda (x) - (or (int? x) - (obj? x) - (obj+? x) - (label-address? x) - (foreign? x)))) - -(define foreign? - (lambda (x) - (and (pair? x) (eq? (car x) 'foreign-label)))) - - -(define imm8? - (lambda (x) - (and (int? x) (byte? (cadr x))))) - -(define label? - (lambda (x) - (cond - [(and (pair? x) (eq? (car x) 'label)) - (let ([d (cdr x)]) - (unless (and (null? (cdr d)) - (symbol? (car d))) - (error 'assemble "invalid label ~s" x))) - #t] - [else #f]))) - -(define label-address? - (lambda (x) - (cond - [(and (pair? x) (eq? (car x) 'label-address)) - (let ([d (cdr x)]) - (unless (and (null? (cdr d)) - (or (symbol? (car d)) - (string? (car d)))) - (error 'assemble "invalid label-address ~s" x))) - #t] - [else #f]))) - -(define label-name - (lambda (x) (cadr x))) - -(define int? - (lambda (x) - (and (pair? x) (eq? (car x) 'int)))) - -(define obj? - (lambda (x) - (and (pair? x) (eq? (car x) 'obj)))) - -(define obj+? - (lambda (x) - (and (pair? x) (eq? (car x) 'obj+)))) - -(define CODErri - (lambda (c d s i ac) - (cond - [(imm8? i) - (CODE c (ModRM 1 d s (IMM8 i ac)))] - [(reg? i) - (CODE c (ModRM i d s ac))] - [else - (CODE c (ModRM 2 d s (IMM32 i ac)))]))) - -(define CODErr - (lambda (c d s ac) - (CODE c (ModRM 3 d s ac)))) - -(define CODEri - (lambda (c d i ac) - (CODE+r c d (IMM32 i ac)))) - - -(define RegReg - (lambda (r1 r2 r3 ac) - (cond - [(eq? r3 '%esp) (error 'assembler "BUG: invalid src %esp")] - [(eq? r1 '%ebp) (error 'assembler "BUG: invalid src %ebp")] - [else -;;; (parameterize ([print-radix 16]) -;;; (printf "REGREG ~s ~s ~s\n" r1 r2 r3) -;;; (printf "REGREG ~s ~s\n" -;;; (byte (fxlogor 4 (fxsll (register-index r1) 3))) -;;; (byte (fxlogor (register-index r2) -;;; (fxsll (register-index r3) 3))))) - (list* - (byte (fxlogor 4 (fxsll (register-index r1) 3))) - (byte (fxlogor (register-index r2) - (fxsll (register-index r3) 3))) - ac)]))) - - -;;(define CODErd -;; (lambda (c r1 disp ac) -;; (with-args disp -;; (lambda (i/r r2) -;; (if (reg? i/r) -;; (CODE c (RegReg r1 i/r r2 ac)) -;; (CODErri c r1 r2 i/r ac)))))) - - -(define IMM32*2 - (lambda (i1 i2 ac) - (cond - [(and (int? i1) (obj? i2)) - (let ([d (cadr i1)] [v (cadr i2)]) - (cons (reloc-word+ v d) ac))] - [else (error 'assemble "IMM32*2 ~s ~s" i1 i2)]))) - - -(define CODErd - (lambda (c r1 disp ac) - (with-args disp - (lambda (a1 a2) - (cond - [(and (reg? a1) (reg? a2)) - (CODE c (RegReg r1 a1 a2 ac))] - [(and (imm? a1) (reg? a2)) - (CODErri c r1 a2 a1 ac)] - [(and (imm? a1) (imm? a2)) - (CODE c - (ModRM 0 r1 '/5 - (IMM32*2 a1 a2 ac)))] - [else (error 'CODErd "unhandled ~s" disp)]))))) - -(define CODEdi - (lambda (c disp n ac) - (with-args disp - (lambda (i r) - (CODErri c '/0 r i (IMM32 n ac)))))) - -(define CODEdi8 - (lambda (c disp n ac) - (with-args disp - (lambda (i r) - (CODErri c '/0 r i (IMM8 n ac)))))) - -(define *cogen* (gensym "*cogen*")) - -(define-syntax add-instruction - (syntax-rules () - [(_ (name instr ac args ...) b b* ...) - (putprop 'name *cogen* - (cons (length '(args ...)) - (lambda (instr ac args ...) b b* ...)))])) - -(define-syntax add-instructions - (syntax-rules () - [(_ instr ac [(name* arg** ...) b* b** ...] ...) - (begin - (add-instruction (name* instr ac arg** ...) b* b** ...) ...)])) - -(define (convert-instruction a ac) - (cond - [(getprop (car a) *cogen*) => - (lambda (p) - (let ([n (car p)] [proc (cdr p)] [args (cdr a)]) - (cond - [(fx= n (length args)) - (apply proc a ac args)] - [else - (error 'convert-instruction "incorrect args in ~s" a)])))] - [else (old-convert-instruction a ac)] - ;[else (error 'convert-instruction "unknown instruction in ~s" a)] - )) - -(module () -(define who 'assembler) -(add-instructions instr ac - [(ret) (CODE #xC3 ac)] - [(cltd) (CODE #x99 ac)] - [(movl src dst) - (cond - [(and (imm? src) (reg? dst)) (CODEri #xB8 dst src ac)] - [(and (imm? src) (mem? dst)) (CODEdi #xC7 dst src ac)] - [(and (reg? src) (reg? dst)) (CODErr #x89 src dst ac)] - [(and (reg? src) (mem? dst)) (CODErd #x89 src dst ac)] - [(and (mem? src) (reg? dst)) (CODErd #x8B dst src ac)] - [else (error who "invalid ~s" instr)])] - [(movb src dst) - (cond - ;[(and (imm8? src) (reg8? dst)) (CODEri #xB0 dst src ac)] - [(and (imm8? src) (mem? dst)) (CODEdi8 #xC6 dst src ac)] - ;[(and (reg8? src) (reg8? dst)) (CODErr #x88 src dst ac)] - [(and (reg8? src) (mem? dst)) (CODErd #x88 src dst ac)] - [(and (mem? src) (reg8? dst)) (CODErd #x8A dst src ac)] - [else (error who "invalid ~s" instr)])] - [(addl src dst) - (cond - ;;; add imm -> reg - [(and (imm8? src) (reg? dst)) - (CODE #x83 (ModRM 3 '/0 dst (IMM8 src ac)))] - [(and (imm? src) (eq? dst '%eax)) - (CODE #x05 (IMM32 src ac))] - [(and (imm? src) (reg? dst)) - (CODE #x81 (ModRM 3 '/0 dst (IMM32 src ac)))] - ;;; add reg -> reg - [(and (reg? src) (reg? dst)) - (CODE #x01 (ModRM 3 src dst ac))] - ;;; add mem -> reg - [(and (mem? src) (reg? dst)) - (CODErd #x03 dst src ac)] - ;;; add imm -> mem (not needed) - ;;; add reg -> mem (not needed) - [else (error who "invalid ~s" instr)])] - [(subl src dst) - (cond - ;;; imm -> reg - [(and (imm8? src) (reg? dst)) - (CODE #x83 (ModRM 3 '/5 dst (IMM8 src ac)))] - [(and (imm? src) (eq? dst '%eax)) - (CODE #x2D (IMM32 src ac))] - [(and (imm? src) (reg? dst)) - (CODE #x81 (ModRM 3 '/5 dst (IMM32 src ac)))] - ;;; reg -> reg - [(and (reg? src) (reg? dst)) - (CODE #x29 (ModRM 3 src dst ac))] - ;;; mem -> reg - [(and (mem? src) (reg? dst)) - (CODErd #x2B dst src ac)] - ;;; imm -> mem (not needed) - ;;; reg -> mem (not needed) - [else (error who "invalid ~s" instr)])] - [(sall src dst) - (cond - [(and (equal? '(int 1) src) (reg? dst)) - (CODE #xD1 (ModRM 3 '/4 dst ac))] - [(and (imm8? src) (reg? dst)) - (CODE #xC1 (ModRM 3 '/4 dst (IMM8 src ac)))] - [(and (eq? src '%cl) (reg? dst)) - (CODE #xD3 (ModRM 3 '/4 dst ac))] - [else (error who "invalid ~s" instr)])] - [(shrl src dst) - (cond - [(and (equal? '(int 1) src) (reg? dst)) - (CODE #xD1 (ModRM 3 '/5 dst ac))] - [(and (imm8? src) (reg? dst)) - (CODE #xC1 (ModRM 3 '/5 dst (IMM8 src ac)))] - [(and (eq? src '%cl) (reg? dst)) - (CODE #xD3 (ModRM 3 '/5 dst ac))] - [else (error who "invalid ~s" instr)])] - [(sarl src dst) - (cond - [(and (equal? '(int 1) src) (reg? dst)) - (CODE #xD1 (ModRM 3 '/7 dst ac))] - [(and (imm8? src) (reg? dst)) - (CODE #xC1 (ModRM 3 '/7 dst (IMM8 src ac)))] - [(and (eq? src '%cl) (reg? dst)) - (CODE #xD3 (ModRM 3 '/7 dst ac))] - [else (error who "invalid ~s" instr)])] - [(andl src dst) - (cond - ;;; and imm -> reg - [(and (imm8? src) (reg? dst)) - (CODE #x83 (ModRM 3 '/4 dst (IMM8 src ac)))] - [(and (imm? src) (eq? dst '%eax)) - (CODE #x25 (IMM32 src ac))] - [(and (imm? src) (reg? dst)) - (CODE #x81 (ModRM 3 '/4 dst (IMM32 src ac)))] - ;;; and reg -> reg - [(and (reg? src) (reg? dst)) - (CODE #x21 (ModRM 3 src dst ac))] - ;;; and mem -> reg - [(and (mem? src) (reg? dst)) - (CODErd #x23 dst src ac)] - [else (error who "invalid ~s" instr)])] - [(orl src dst) - (cond - ;;; or imm -> reg - [(and (imm8? src) (reg? dst)) - (CODE #x83 (ModRM 3 '/1 dst (IMM8 src ac)))] - [(and (imm? src) (eq? dst '%eax)) - (CODE #x0D (IMM32 src ac))] - [(and (imm? src) (reg? dst)) - (CODE #x81 (ModRM 3 '/1 dst (IMM32 src ac)))] - ;;; or reg -> reg - [(and (reg? src) (reg? dst)) - (CODE #x09 (ModRM 3 src dst ac))] - ;;; or mem -> reg - [(and (mem? src) (reg? dst)) - (CODErd #x0B dst src ac)] - [else (error who "invalid ~s" instr)])] - [(xorl src dst) - (cond - ;;; or imm -> reg - ;[(and (imm8? src) (reg? dst)) - ; (CODE #x83 (ModRM 3 '/1 dst (IMM8 src ac)))] - ;[(and (imm? src) (eq? dst '%eax)) - ; (CODE #x0D (IMM32 src ac))] - ;[(and (imm? src) (reg? dst)) - ; (CODE #x81 (ModRM 3 '/1 dst (IMM32 src ac)))] - ;;; or reg -> reg - [(and (reg? src) (reg? dst)) - (CODE #x31 (ModRM 3 src dst ac))] - ;;; or mem -> reg - [(and (mem? src) (reg? dst)) - (CODErd #x33 dst src ac)] - [else (error who "invalid ~s" instr)])] - [(cmpl src dst) - (cond - [(and (imm8? src) (reg? dst)) - (CODE #x83 (ModRM 3 '/7 dst (IMM8 src ac)))] - [(and (imm? src) (eq? dst '%eax)) - (CODE #x3D (IMM32 src ac))] - [(and (reg? src) (reg? dst)) - (CODE #x39 (ModRM 3 src dst ac))] - [(and (mem? src) (reg? dst)) - (CODErd #x3B dst src ac)] - [(and (imm8? src) (mem? dst)) - (CODErd #x83 '/7 dst (IMM8 src ac))] - [(and (imm? src) (mem? dst)) - (CODErd #x81 '/7 dst (IMM32 src ac))] - [else (error who "invalid ~s" instr)])] - [(imull src dst) - (cond - [(and (imm8? src) (reg? dst)) - (CODE #x6B (ModRM 3 dst dst (IMM8 src ac)))] - [(and (imm? src) (reg? dst)) - (CODE #x69 (ModRM 3 dst dst (IMM32 src ac)))] - [(and (reg? src) (reg? dst)) - (CODE #x0F (CODE #xAF (ModRM 3 dst src ac)))] - [(and (mem? src) (reg? dst)) - (CODE #x0F (CODErd #xAF dst src ac))] - [else (error who "invalid ~s" instr)])] - [(idivl dst) - (cond - [(reg? dst) - (CODErr #xF7 '/7 dst ac)] - [(mem? dst) - (CODErd #xF7 '/7 dst ac)] - [else (error who "invalid ~s" instr)])] - [(pushl dst) - (cond - [(imm8? dst) - (CODE #x6A (IMM8 dst ac))] - [(imm? dst) - (CODE #x68 (IMM32 dst ac))] - [(reg? dst) - (CODE+r #x50 dst ac)] - [(mem? dst) - (CODErd #xFF '/6 dst ac)] - [else (error who "invalid ~s" instr)])] - [(popl dst) - (cond - [(reg? dst) - (CODE+r #x58 dst ac)] - [(mem? dst) - (CODErd #x8F '/0 dst ac)] - [else (error who "invalid ~s" instr)])] - [(notl dst) - (cond - [(reg? dst) - (CODE #xF7 (ModRM 3 '/2 dst ac))] - [(mem? dst) - (CODErd #xF7 '/7 dst ac)] - [else (error who "invalid ~s" instr)])] - [(negl dst) - (cond - [(reg? dst) - (CODE #xF7 (ModRM 3 '/3 dst ac))] - [else (error who "invalid ~s" instr)])] - -)) - -(define old-convert-instruction - (lambda (a ac) - (define who 'assemble) - (check-len a) - (case (car a) - - [(jmp) - (with-args a - (lambda (dst) - (cond - [(label? dst) - (CODE #xE9 (cons (cons 'relative (label-name dst)) ac))] - [(imm? dst) - (CODE #xE9 (IMM32 dst ac))] - [(mem? dst) - (CODErd #xFF '/4 dst ac)] - [else (error who "invalid jmp in ~s" a)])))] - [(call) - (with-args a - (lambda (dst) - (cond - [(imm? dst) - (CODE #xE8 (IMM32 dst ac))] - [(label? dst) - (CODE #xE8 (cons (cons 'relative (label-name dst)) ac))] - [(mem? dst) - (CODErd #xFF '/2 dst ac)] - [(reg? dst) - (CODE #xFF (ModRM 3 '/2 dst ac))] - [else (error who "invalid jmp in ~s" a)])))] - [(seta setae setb setbe sete setg setge setl setle - setna setnae setnb setnbe setne setng setnge setnl setnle) - (let* ([table - '([seta #x97] [setna #x96] - [setae #x93] [setnae #x92] - [setb #x92] [setnb #x93] - [setbe #x96] [setnbe #x97] - [setg #x9F] [setng #x9E] - [setge #x9D] [setnge #x9C] - [setl #x9C] [setnl #x9D] - [setle #x9E] [setnle #x9F] - [sete #x94] [setne #x95])] - [lookup - (lambda (x) - (cond - [(assq x table) => cadr] - [else (error who "invalid cset ~s" x)]))]) - (with-args a - (lambda (dst) - (cond - [(reg8? dst) - (CODE #x0F - (CODE (lookup (car a)) - (ModRM 3 '/0 dst ac)))] - [else (error who "invalid ~s" a)]))))] - [(ja jae jb jbe je jg jge jl jle - jna jnae jnb jnbe jne jng jnge jnl jnle) - (let* ([table - '([je #x84] [jne #x85] - [ja #x87] [jna #x86] - [jae #x83] [jnae #x82] - [jb #x82] [jnb #x83] - [jbe #x86] [jnbe #x87] - [jg #x8F] [jng #x8E] - [jge #x8D] [jnge #x8C] - [jl #x8C] [jnl #x8D] - [jle #x8E] [jnle #x8F])] - [lookup - (lambda (x) - (cond - [(assq x table) => cadr] - [else (error who "invalid cmp ~s" x)]))]) - (with-args a - (lambda (dst) - (cond - [(imm? dst) - (CODE #x0F (CODE (lookup (car a)) (IMM32 dst ac)))] - [(label? dst) - (CODE #x0F - (CODE (lookup (car a)) - (cons (cons 'relative (label-name dst)) ac)))] - [else (error who "invalid ~s" a)]))))] - [(byte) - (with-args a - (lambda (x) - (unless (byte? x) (error who "invalid instruction ~s" a)) - (cons (byte x) ac)))] - [(byte-vector) - (with-args a - (lambda (x) (append (map byte (vector->list x)) ac)))] - [(int) (IMM32 a ac)] - [(label) - (with-args a - (lambda (L) - (unless (symbol? L) (error who "invalid instruction ~s" a)) - (cons (cons 'label L) ac)))] - [(label-address) - (with-args a - (lambda (L) - (unless (symbol? L) (error who "invalid instruction ~s" a)) - (cons (cons 'label-addr L) ac)))] - [(current-frame-offset) - (cons '(current-frame-offset) ac)] - [(nop) ac] - [else - (error who "unknown instruction ~s" a)]))) - -(define diff - (lambda (ls x) - (cond - [(eq? ls x) '()] - [else (cons (car ls) (diff (cdr ls) x))]))) - -(define hex-table - '#(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 - #\8 #\9 #\A #\B #\C #\D #\E #\F)) - -(define write/x - (lambda (x) - (case (car x) - [(byte) - (display "0x") - (display (vector-ref hex-table (fxsra (cdr x) 4))) - (display (vector-ref hex-table (fxlogand (cdr x) 15))) - (display " ")] - [else (write x)]))) - - -(define compute-code-size - (lambda (ls) - (fold (lambda (x ac) - (case (car x) - [(byte) (fx+ ac 1)] - [(word reloc-word reloc-word+ label-addr foreign-label - relative current-frame-offset) - (fx+ ac 4)] - [(label) ac] - [else (error 'compute-code-size "unknown instr ~s" x)])) - 0 - ls))) - - -(define compute-reloc-size - (lambda (ls) - (fold (lambda (x ac) - (case (car x) - [(reloc-word ) (fx+ ac 4)] - [(reloc-word+) (fx+ ac 8)] - [(relative label-addr foreign-label) (fx+ ac 8)] - [(word byte label current-frame-offset) ac] - [else (error 'compute-reloc-size "unknown instr ~s" x)])) - 0 - ls))) - -(define set-label-loc! - (lambda (x loc) - (when (getprop x '*label-loc*) - (error 'compile "label ~s is already defined" x)) - (putprop x '*label-loc* loc))) - -(define label-loc - (lambda (x) - (or (getprop x '*label-loc*) - (error 'compile "undefined label ~s" x)))) - - -(define unset-label-loc! - (lambda (x) - (remprop x '*label-loc*))) - - -(define whack-instructions - (lambda (x ls) - (define f - (lambda (ls idx reloc) - (cond - [(null? ls) reloc] - [else - (let ([a (car ls)]) - (case (car a) - [(byte) - (set-code-byte! x idx (cdr a)) - (f (cdr ls) (fx+ idx 1) reloc)] - [(reloc-word reloc-word+) - (f (cdr ls) (fx+ idx 4) (cons (cons idx a) reloc))] - [(relative label-addr foreign-label) - (f (cdr ls) (fx+ idx 4) (cons (cons idx a) reloc))] - [(word) - (let ([v (cdr a)]) - (set-code-word! x idx v) - (f (cdr ls) (fx+ idx 4) reloc))] - [(current-frame-offset) - (set-code-word! x idx idx) - (f (cdr ls) (fx+ idx 4) reloc)] - [(label) - (set-label-loc! (cdr a) (cons x idx)) - (f (cdr ls) idx reloc)] - [else - (error 'whack-instructions "unknown instr ~s" a)]))]))) - (f ls 0 '()))) - -(define wordsize 4) - -(define whack-reloc - (lambda (code) - (define reloc-idx 0) - (lambda (r) - (let ([idx (car r)] [type (cadr r)] [v (cddr r)]) - (case type - [(reloc-word) - (set-code-object! code v idx reloc-idx) - (set! reloc-idx (fxadd1 reloc-idx))] - [(foreign-label) - (set-code-foreign-object! code v idx reloc-idx) - (set! reloc-idx (fx+ reloc-idx 2))] - [(reloc-word+) - (let ([obj (car v)] [disp (cdr v)]) - (set-code-object+offset! code obj idx disp reloc-idx) - (set! reloc-idx (fx+ reloc-idx 2)))] - [(label-addr) - (let ([loc (label-loc v)]) - (let ([obj (car loc)] [off (cdr loc)]) - (set-code-object+offset! - code obj idx (fx+ off 11) reloc-idx))) - (set! reloc-idx (fx+ reloc-idx 2))] - [(relative) - (let ([loc (label-loc v)]) - (let ([obj (car loc)] [off (cdr loc)]) - (set-code-object+offset/rel! - code obj idx (fx+ off 11) reloc-idx))) - (set! reloc-idx (fx+ reloc-idx 2))] - [else (error 'whack-reloc "invalid reloc type ~s" type)])) - ))) - - -;;; (define list->code -;;; (lambda (ls) -;;; (let ([ls (convert-instructions ls)]) -;;; (let ([n (compute-code-size ls)] -;;; [m (compute-reloc-size ls)]) -;;; (let ([x (make-code n m 1)]) -;;; (let ([reloc* (whack-instructions x ls)]) -;;; (for-each (whack-reloc x) reloc*)) -;;; (make-code-executable! x) -;;; x))))) - -(define list*->code* - (lambda (ls*) - (let ([closure-size* (map car ls*)] - [ls* (map cdr ls*)]) - (let ([ls* (map convert-instructions ls*)]) - (let ([n* (map compute-code-size ls*)] - [m* (map compute-reloc-size ls*)]) - (let ([code* (map (lambda (n m c) (make-code n m c)) - n* - m* - closure-size*)]) - (let ([reloc** (map whack-instructions code* ls*)]) - (for-each - (lambda (code reloc*) - (for-each (whack-reloc code) reloc*)) - code* reloc**) - (for-each make-code-executable! code*) - code*))))))) - -(define list->code - (lambda (ls) - (car (list*->code* (list ls))))) - -(primitive-set! 'list*->code* list*->code*) -) diff --git a/src/libintelasm-6.6.ss b/src/libintelasm-6.6.ss deleted file mode 100644 index 7254753..0000000 --- a/src/libintelasm-6.6.ss +++ /dev/null @@ -1,932 +0,0 @@ - -;;; -;;; assuming the existence of a code manager, this file defines an assember -;;; that takes lists of assembly code and produces a list of code objects -;;; - - ;;; add - ;;; and - ;;; cmp - ;;; call - ;;; cltd - ;;; idiv - ;;; imull - ;;; ja - ;;; jae - ;;; jb - ;;; jbe - ;;; je - ;;; jg - ;;; jge - ;;; jl - ;;; jle - ;;; jne - ;;; jmp - ;;; movb - ;;; movl - ;;; negl - ;;; notl - ;;; orl - ;;; popl - ;;; pushl - ;;; ret - ;;; sall - ;;; sarl - ;;; shrl - ;;; sete - ;;; setg - - -(let () - -(define fold - (lambda (f init ls) - (cond - [(null? ls) init] - [else - (f (car ls) (fold f init (cdr ls)))]))) - -(define convert-instructions - (lambda (ls) - (fold convert-instruction '() ls))) - -(define register-mapping - '([%eax 32 0] - [%ecx 32 1] - [%edx 32 2] - [%ebx 32 3] - [%esp 32 4] - [%ebp 32 5] - [%esi 32 6] - [%edi 32 7] - [%al 8 0] - [%cl 8 1] - [%dl 8 2] - [%bl 8 3] - [%ah 8 4] - [%ch 8 5] - [%dh 8 6] - [%bh 8 7] - [/0 0 0] - [/1 0 1] - [/2 0 2] - [/3 0 3] - [/4 0 4] - [/5 0 5] - [/6 0 6] - [/7 0 7] - )) - -(define register-index - (lambda (x) - (cond - [(assq x register-mapping) => caddr] - [else (error 'register-index "not a register ~s" x)]))) - -(define reg32? - (lambda (x) - (cond - [(assq x register-mapping) => - (lambda (x) (fx= (cadr x) 32))] - [else #f]))) - -(define reg8? - (lambda (x) - (cond - [(assq x register-mapping) => - (lambda (x) (fx= (cadr x) 8))] - [else #f]))) - -(define reg? - (lambda (x) - (assq x register-mapping))) - -(define check-len - (lambda (x) - (define instr-len - '([ret] - [movl s d] - [movb s d] - [addl s d] - [subl s d] - [sall s d] - [sarl s d] - [shrl s d] - [andl s d] - [xorl s d] - [orl s d] - [cmpl s d] - [imull s d] - [notl d] - [negl d] - [idivl d] - [pushl d] - [popl d] - [jmp d] - [call d] - [ja d] - [jae d] - [jb d] - [jbe d] - [je d] - [jg d] - [jge d] - [jl d] - [jle d] - [jna d] - [jnae d] - [jnb d] - [jnbe d] - [jne d] - [jng d] - [jnge d] - [jnl d] - [jnle d] - [seta d] - [setae d] - [setb d] - [setbe d] - [sete d] - [setg d] - [setge d] - [setl d] - [setle d] - [setna d] - [setnae d] - [setnb d] - [setnbe d] - [setne d] - [setng d] - [setnge d] - [setnl d] - [setnle d] - [cltd] - [nop] - [byte x] - [byte-vector x] - [int x] - [label x] - [label-address x] - [current-frame-offset] - )) - (cond - [(assq (car x) instr-len) => - (lambda (p) - (unless (fx= (length x) (length p)) - (error 'assembler "invalid instruction format ~s" x)))] - [else (error 'assembler "unknown instruction ~s" x)]))) - -(define with-args - (lambda (ls f) - (apply f (cdr ls)))) - -(define byte - (lambda (x) - (cons 'byte (fxlogand x 255)))) - - -(define word - (lambda (x) - (cons 'word x))) - -(define reloc-word - (lambda (x) - (cons 'reloc-word x))) - -(define reloc-word+ - (lambda (x d) - (list* 'reloc-word+ x d))) - -(define list*-aux - (lambda (ls ls*) - (cond - [(null? ls*) ls] - [else (cons ls (list*-aux (car ls*) (cdr ls*)))]))) - -(define list* - (lambda (ls . ls*) - (list*-aux ls ls*))) - -(define byte? - (lambda (x) - (and (fixnum? x) - (fx<= x 127) - (fx<= -128 x)))) - -(define mem? - (lambda (x) - (and (list? x) - (fx= (length x) 3) - (eq? (car x) 'disp) - (or (imm? (cadr x)) - (reg? (cadr x))) - (or (imm? (caddr x)) - (reg? (caddr x)))))) - -(define small-disp? - (lambda (x) - (and (mem? x) - (byte? (cadr x))))) - - -(define CODE - (lambda (n ac) - (cons (byte n) ac))) - -(define CODE+r - (lambda (n r ac) - (cons (byte (fxlogor n (register-index r))) ac))) - -(define ModRM - (lambda (mod reg r/m ac) - (cons (byte (fxlogor - (register-index r/m) - (fxlogor - (fxsll (register-index reg) 3) - (fxsll mod 6)))) - (if (and (not (fx= mod 3)) (eq? r/m '%esp)) - (cons (byte #x24) ac) - ac)))) - -(define IMM32 - (lambda (n ac) - (cond - [(int? n) - (let ([n (cadr n)]) - (list* (byte n) - (byte (fxsra n 8)) - (byte (fxsra n 16)) - (byte (fxsra n 24)) - ac))] - [(obj? n) - (let ([v (cadr n)]) - (if (immediate? v) - (cons (word v) ac) - (cons (reloc-word v) ac)))] - [(obj+? n) - (let ([v (cadr n)] [d (caddr n)]) - (cons (reloc-word+ v d) ac))] - [(label-address? n) - (cons (cons 'label-addr (label-name n)) ac)] - [(foreign? n) - (cons (cons 'foreign-label (label-name n)) ac)] - [else (error 'IMM32 "invalid ~s" n)]))) - - -(define IMM8 - (lambda (n ac) - (cond - [(int? n) - (let ([n (cadr n)]) - (list* (byte n) ac))] - [else (error 'IMM8 "invalid ~s" n)]))) - - -(define imm? - (lambda (x) - (or (int? x) - (obj? x) - (obj+? x) - (label-address? x) - (foreign? x)))) - -(define foreign? - (lambda (x) - (and (pair? x) (eq? (car x) 'foreign-label)))) - - -(define imm8? - (lambda (x) - (and (int? x) (byte? (cadr x))))) - -(define label? - (lambda (x) - (cond - [(and (pair? x) (eq? (car x) 'label)) - (let ([d (cdr x)]) - (unless (and (null? (cdr d)) - (symbol? (car d))) - (error 'assemble "invalid label ~s" x))) - #t] - [else #f]))) - -(define label-address? - (lambda (x) - (cond - [(and (pair? x) (eq? (car x) 'label-address)) - (let ([d (cdr x)]) - (unless (and (null? (cdr d)) - (or (symbol? (car d)) - (string? (car d)))) - (error 'assemble "invalid label-address ~s" x))) - #t] - [else #f]))) - -(define label-name - (lambda (x) (cadr x))) - -(define int? - (lambda (x) - (and (pair? x) (eq? (car x) 'int)))) - -(define obj? - (lambda (x) - (and (pair? x) (eq? (car x) 'obj)))) - -(define obj+? - (lambda (x) - (and (pair? x) (eq? (car x) 'obj+)))) - -(define CODErri - (lambda (c d s i ac) - (cond - [(imm8? i) - (CODE c (ModRM 1 d s (IMM8 i ac)))] - [(reg? i) - (CODE c (ModRM i d s ac))] - [else - (CODE c (ModRM 2 d s (IMM32 i ac)))]))) - -(define CODErr - (lambda (c d s ac) - (CODE c (ModRM 3 d s ac)))) - -(define CODEri - (lambda (c d i ac) - (CODE+r c d (IMM32 i ac)))) - - -(define RegReg - (lambda (r1 r2 r3 ac) - (cond - [(eq? r3 '%esp) (error 'assembler "BUG: invalid src %esp")] - [(eq? r1 '%ebp) (error 'assembler "BUG: invalid src %ebp")] - [else -;;; (parameterize ([print-radix 16]) -;;; (printf "REGREG ~s ~s ~s\n" r1 r2 r3) -;;; (printf "REGREG ~s ~s\n" -;;; (byte (fxlogor 4 (fxsll (register-index r1) 3))) -;;; (byte (fxlogor (register-index r2) -;;; (fxsll (register-index r3) 3))))) - (list* - (byte (fxlogor 4 (fxsll (register-index r1) 3))) - (byte (fxlogor (register-index r2) - (fxsll (register-index r3) 3))) - ac)]))) - - -;;(define CODErd -;; (lambda (c r1 disp ac) -;; (with-args disp -;; (lambda (i/r r2) -;; (if (reg? i/r) -;; (CODE c (RegReg r1 i/r r2 ac)) -;; (CODErri c r1 r2 i/r ac)))))) - - -(define IMM32*2 - (lambda (i1 i2 ac) - (cond - [(and (int? i1) (obj? i2)) - (let ([d (cadr i1)] [v (cadr i2)]) - (cons (reloc-word+ v d) ac))] - [else (error 'assemble "IMM32*2 ~s ~s" i1 i2)]))) - - -(define CODErd - (lambda (c r1 disp ac) - (with-args disp - (lambda (a1 a2) - (cond - [(and (reg? a1) (reg? a2)) - (CODE c (RegReg r1 a1 a2 ac))] - [(and (imm? a1) (reg? a2)) - (CODErri c r1 a2 a1 ac)] - [(and (imm? a1) (imm? a2)) - (CODE c - (ModRM 0 r1 '/5 - (IMM32*2 a1 a2 ac)))] - [else (error 'CODErd "unhandled ~s" disp)]))))) - -(define CODEdi - (lambda (c disp n ac) - (with-args disp - (lambda (i r) - (CODErri c '/0 r i (IMM32 n ac)))))) - -(define CODEdi8 - (lambda (c disp n ac) - (with-args disp - (lambda (i r) - (CODErri c '/0 r i (IMM8 n ac)))))) - -(define *cogen* (gensym "*cogen*")) - -(define-syntax add-instruction - (syntax-rules () - [(_ (name instr ac args ...) b b* ...) - (putprop 'name *cogen* - (cons (length '(args ...)) - (lambda (instr ac args ...) b b* ...)))])) - -(define-syntax add-instructions - (syntax-rules () - [(_ instr ac [(name* arg** ...) b* b** ...] ...) - (begin - (add-instruction (name* instr ac arg** ...) b* b** ...) ...)])) - -(define (convert-instruction a ac) - (cond - [(getprop (car a) *cogen*) => - (lambda (p) - (let ([n (car p)] [proc (cdr p)] [args (cdr a)]) - (cond - [(fx= n (length args)) - (apply proc a ac args)] - [else - (error 'convert-instruction "incorrect args in ~s" a)])))] - [else (old-convert-instruction a ac)] - ;[else (error 'convert-instruction "unknown instruction in ~s" a)] - )) - -(module () -(define who 'assembler) -(add-instructions instr ac - [(ret) (CODE #xC3 ac)] - [(cltd) (CODE #x99 ac)] - [(movl src dst) - (cond - [(and (imm? src) (reg? dst)) (CODEri #xB8 dst src ac)] - [(and (imm? src) (mem? dst)) (CODEdi #xC7 dst src ac)] - [(and (reg? src) (reg? dst)) (CODErr #x89 src dst ac)] - [(and (reg? src) (mem? dst)) (CODErd #x89 src dst ac)] - [(and (mem? src) (reg? dst)) (CODErd #x8B dst src ac)] - [else (error who "invalid ~s" instr)])] - [(movb src dst) - (cond - ;[(and (imm8? src) (reg8? dst)) (CODEri #xB0 dst src ac)] - [(and (imm8? src) (mem? dst)) (CODEdi8 #xC6 dst src ac)] - ;[(and (reg8? src) (reg8? dst)) (CODErr #x88 src dst ac)] - [(and (reg8? src) (mem? dst)) (CODErd #x88 src dst ac)] - [(and (mem? src) (reg8? dst)) (CODErd #x8A dst src ac)] - [else (error who "invalid ~s" instr)])] - [(addl src dst) - (cond - ;;; add imm -> reg - [(and (imm8? src) (reg? dst)) - (CODE #x83 (ModRM 3 '/0 dst (IMM8 src ac)))] - [(and (imm? src) (eq? dst '%eax)) - (CODE #x05 (IMM32 src ac))] - [(and (imm? src) (reg? dst)) - (CODE #x81 (ModRM 3 '/0 dst (IMM32 src ac)))] - ;;; add reg -> reg - [(and (reg? src) (reg? dst)) - (CODE #x01 (ModRM 3 src dst ac))] - ;;; add mem -> reg - [(and (mem? src) (reg? dst)) - (CODErd #x03 dst src ac)] - ;;; add imm -> mem (not needed) - ;;; add reg -> mem (not needed) - [else (error who "invalid ~s" instr)])] - [(subl src dst) - (cond - ;;; imm -> reg - [(and (imm8? src) (reg? dst)) - (CODE #x83 (ModRM 3 '/5 dst (IMM8 src ac)))] - [(and (imm? src) (eq? dst '%eax)) - (CODE #x2D (IMM32 src ac))] - [(and (imm? src) (reg? dst)) - (CODE #x81 (ModRM 3 '/5 dst (IMM32 src ac)))] - ;;; reg -> reg - [(and (reg? src) (reg? dst)) - (CODE #x29 (ModRM 3 src dst ac))] - ;;; mem -> reg - [(and (mem? src) (reg? dst)) - (CODErd #x2B dst src ac)] - ;;; imm -> mem (not needed) - ;;; reg -> mem (not needed) - [else (error who "invalid ~s" instr)])] - [(sall src dst) - (cond - [(and (equal? '(int 1) src) (reg? dst)) - (CODE #xD1 (ModRM 3 '/4 dst ac))] - [(and (imm8? src) (reg? dst)) - (CODE #xC1 (ModRM 3 '/4 dst (IMM8 src ac)))] - [(and (eq? src '%cl) (reg? dst)) - (CODE #xD3 (ModRM 3 '/4 dst ac))] - [else (error who "invalid ~s" instr)])] - [(shrl src dst) - (cond - [(and (equal? '(int 1) src) (reg? dst)) - (CODE #xD1 (ModRM 3 '/5 dst ac))] - [(and (imm8? src) (reg? dst)) - (CODE #xC1 (ModRM 3 '/5 dst (IMM8 src ac)))] - [(and (eq? src '%cl) (reg? dst)) - (CODE #xD3 (ModRM 3 '/5 dst ac))] - [else (error who "invalid ~s" instr)])] - [(sarl src dst) - (cond - [(and (equal? '(int 1) src) (reg? dst)) - (CODE #xD1 (ModRM 3 '/7 dst ac))] - [(and (imm8? src) (reg? dst)) - (CODE #xC1 (ModRM 3 '/7 dst (IMM8 src ac)))] - [(and (eq? src '%cl) (reg? dst)) - (CODE #xD3 (ModRM 3 '/7 dst ac))] - [else (error who "invalid ~s" instr)])] - [(andl src dst) - (cond - ;;; and imm -> reg - [(and (imm8? src) (reg? dst)) - (CODE #x83 (ModRM 3 '/4 dst (IMM8 src ac)))] - [(and (imm? src) (eq? dst '%eax)) - (CODE #x25 (IMM32 src ac))] - [(and (imm? src) (reg? dst)) - (CODE #x81 (ModRM 3 '/4 dst (IMM32 src ac)))] - ;;; and reg -> reg - [(and (reg? src) (reg? dst)) - (CODE #x21 (ModRM 3 src dst ac))] - ;;; and mem -> reg - [(and (mem? src) (reg? dst)) - (CODErd #x23 dst src ac)] - [else (error who "invalid ~s" instr)])] - [(orl src dst) - (cond - ;;; or imm -> reg - [(and (imm8? src) (reg? dst)) - (CODE #x83 (ModRM 3 '/1 dst (IMM8 src ac)))] - [(and (imm? src) (eq? dst '%eax)) - (CODE #x0D (IMM32 src ac))] - [(and (imm? src) (reg? dst)) - (CODE #x81 (ModRM 3 '/1 dst (IMM32 src ac)))] - ;;; or reg -> reg - [(and (reg? src) (reg? dst)) - (CODE #x09 (ModRM 3 src dst ac))] - ;;; or mem -> reg - [(and (mem? src) (reg? dst)) - (CODErd #x0B dst src ac)] - [else (error who "invalid ~s" instr)])] - [(xorl src dst) - (cond - ;;; or imm -> reg - ;[(and (imm8? src) (reg? dst)) - ; (CODE #x83 (ModRM 3 '/1 dst (IMM8 src ac)))] - ;[(and (imm? src) (eq? dst '%eax)) - ; (CODE #x0D (IMM32 src ac))] - ;[(and (imm? src) (reg? dst)) - ; (CODE #x81 (ModRM 3 '/1 dst (IMM32 src ac)))] - ;;; or reg -> reg - [(and (reg? src) (reg? dst)) - (CODE #x31 (ModRM 3 src dst ac))] - ;;; or mem -> reg - [(and (mem? src) (reg? dst)) - (CODErd #x33 dst src ac)] - [else (error who "invalid ~s" instr)])] - [(cmpl src dst) - (cond - [(and (imm8? src) (reg? dst)) - (CODE #x83 (ModRM 3 '/7 dst (IMM8 src ac)))] - [(and (imm? src) (eq? dst '%eax)) - (CODE #x3D (IMM32 src ac))] - [(and (reg? src) (reg? dst)) - (CODE #x39 (ModRM 3 src dst ac))] - [(and (mem? src) (reg? dst)) - (CODErd #x3B dst src ac)] - [(and (imm8? src) (mem? dst)) - (CODErd #x83 '/7 dst (IMM8 src ac))] - [(and (imm? src) (mem? dst)) - (CODErd #x81 '/7 dst (IMM32 src ac))] - [else (error who "invalid ~s" instr)])] - [(imull src dst) - (cond - [(and (imm8? src) (reg? dst)) - (CODE #x6B (ModRM 3 dst dst (IMM8 src ac)))] - [(and (imm? src) (reg? dst)) - (CODE #x69 (ModRM 3 dst dst (IMM32 src ac)))] - [(and (reg? src) (reg? dst)) - (CODE #x0F (CODE #xAF (ModRM 3 dst src ac)))] - [(and (mem? src) (reg? dst)) - (CODE #x0F (CODErd #xAF dst src ac))] - [else (error who "invalid ~s" instr)])] - [(idivl dst) - (cond - [(reg? dst) - (CODErr #xF7 '/7 dst ac)] - [(mem? dst) - (CODErd #xF7 '/7 dst ac)] - [else (error who "invalid ~s" instr)])] - [(pushl dst) - (cond - [(imm8? dst) - (CODE #x6A (IMM8 dst ac))] - [(imm? dst) - (CODE #x68 (IMM32 dst ac))] - [(reg? dst) - (CODE+r #x50 dst ac)] - [(mem? dst) - (CODErd #xFF '/6 dst ac)] - [else (error who "invalid ~s" instr)])] - [(popl dst) - (cond - [(reg? dst) - (CODE+r #x58 dst ac)] - [(mem? dst) - (CODErd #x8F '/0 dst ac)] - [else (error who "invalid ~s" instr)])] - [(notl dst) - (cond - [(reg? dst) - (CODE #xF7 (ModRM 3 '/2 dst ac))] - [(mem? dst) - (CODErd #xF7 '/7 dst ac)] - [else (error who "invalid ~s" instr)])] - [(negl dst) - (cond - [(reg? dst) - (CODE #xF7 (ModRM 3 '/3 dst ac))] - [else (error who "invalid ~s" instr)])] -)) - -(define old-convert-instruction - (lambda (a ac) - (define who 'assemble) - (check-len a) - (case (car a) - [(jmp) - (with-args a - (lambda (dst) - (cond - [(label? dst) - (CODE #xE9 (cons (cons 'relative (label-name dst)) ac))] - [(imm? dst) - (CODE #xE9 (IMM32 dst ac))] - [(mem? dst) - (CODErd #xFF '/4 dst ac)] - [else (error who "invalid jmp in ~s" a)])))] - [(call) - (with-args a - (lambda (dst) - (cond - [(imm? dst) - (CODE #xE8 (IMM32 dst ac))] - [(label? dst) - (CODE #xE8 (cons (cons 'relative (label-name dst)) ac))] - [(mem? dst) - (CODErd #xFF '/2 dst ac)] - [(reg? dst) - (CODE #xFF (ModRM 3 '/2 dst ac))] - [else (error who "invalid jmp in ~s" a)])))] - [(seta setae setb setbe sete setg setge setl setle - setna setnae setnb setnbe setne setng setnge setnl setnle) - (let* ([table - '([seta #x97] [setna #x96] - [setae #x93] [setnae #x92] - [setb #x92] [setnb #x93] - [setbe #x96] [setnbe #x97] - [setg #x9F] [setng #x9E] - [setge #x9D] [setnge #x9C] - [setl #x9C] [setnl #x9D] - [setle #x9E] [setnle #x9F] - [sete #x94] [setne #x95])] - [lookup - (lambda (x) - (cond - [(assq x table) => cadr] - [else (error who "invalid cset ~s" x)]))]) - (with-args a - (lambda (dst) - (cond - [(reg8? dst) - (CODE #x0F - (CODE (lookup (car a)) - (ModRM 3 '/0 dst ac)))] - [else (error who "invalid ~s" a)]))))] - [(ja jae jb jbe je jg jge jl jle - jna jnae jnb jnbe jne jng jnge jnl jnle) - (let* ([table - '([je #x84] [jne #x85] - [ja #x87] [jna #x86] - [jae #x83] [jnae #x82] - [jb #x82] [jnb #x83] - [jbe #x86] [jnbe #x87] - [jg #x8F] [jng #x8E] - [jge #x8D] [jnge #x8C] - [jl #x8C] [jnl #x8D] - [jle #x8E] [jnle #x8F])] - [lookup - (lambda (x) - (cond - [(assq x table) => cadr] - [else (error who "invalid cmp ~s" x)]))]) - (with-args a - (lambda (dst) - (cond - [(imm? dst) - (CODE #x0F (CODE (lookup (car a)) (IMM32 dst ac)))] - [(label? dst) - (CODE #x0F - (CODE (lookup (car a)) - (cons (cons 'relative (label-name dst)) ac)))] - [else (error who "invalid ~s" a)]))))] - [(byte) - (with-args a - (lambda (x) - (unless (byte? x) (error who "invalid instruction ~s" a)) - (cons (byte x) ac)))] - [(byte-vector) - (with-args a - (lambda (x) (append (map byte (vector->list x)) ac)))] - [(int) (IMM32 a ac)] - [(label) - (with-args a - (lambda (L) - (unless (symbol? L) (error who "invalid instruction ~s" a)) - (cons (cons 'label L) ac)))] - [(label-address) - (with-args a - (lambda (L) - (unless (symbol? L) (error who "invalid instruction ~s" a)) - (cons (cons 'label-addr L) ac)))] - [(current-frame-offset) - (cons '(current-frame-offset) ac)] - [(nop) ac] - [else - (error who "unknown instruction ~s" a)]))) - -(define diff - (lambda (ls x) - (cond - [(eq? ls x) '()] - [else (cons (car ls) (diff (cdr ls) x))]))) - -(define hex-table - '#(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 - #\8 #\9 #\A #\B #\C #\D #\E #\F)) - -(define write/x - (lambda (x) - (case (car x) - [(byte) - (display "0x") - (display (vector-ref hex-table (fxsra (cdr x) 4))) - (display (vector-ref hex-table (fxlogand (cdr x) 15))) - (display " ")] - [else (write x)]))) - - -(define compute-code-size - (lambda (ls) - (fold (lambda (x ac) - (case (car x) - [(byte) (fx+ ac 1)] - [(word reloc-word reloc-word+ label-addr foreign-label - relative current-frame-offset) - (fx+ ac 4)] - [(label) ac] - [else (error 'compute-code-size "unknown instr ~s" x)])) - 0 - ls))) - - -(define set-label-loc! - (lambda (x loc) - (when (getprop x '*label-loc*) - (error 'compile "label ~s is already defined" x)) - (putprop x '*label-loc* loc))) - -(define label-loc - (lambda (x) - (or (getprop x '*label-loc*) - (error 'compile "undefined label ~s" x)))) - - -(define unset-label-loc! - (lambda (x) - (remprop x '*label-loc*))) - - -(define set-code-word! - (lambda (code idx x) - (cond - [(fixnum? x) - (code-set! code (fx+ idx 0) (fxsll (fxlogand x #x3F) 2)) - (code-set! code (fx+ idx 1) (fxlogand (fxsra x 6) #xFF)) - (code-set! code (fx+ idx 2) (fxlogand (fxsra x 14) #xFF)) - (code-set! code (fx+ idx 3) (fxlogand (fxsra x 22) #xFF))] - [else (error 'set-code-word! "unhandled ~s" x)]))) - -(define whack-instructions - (lambda (x ls) - (define f - (lambda (ls idx reloc) - (cond - [(null? ls) reloc] - [else - (let ([a (car ls)]) - (case (car a) - [(byte) - (code-set! x idx (cdr a)) - (f (cdr ls) (fx+ idx 1) reloc)] - [(reloc-word reloc-word+) - (f (cdr ls) (fx+ idx 4) (cons (cons idx a) reloc))] - [(relative label-addr foreign-label) - (f (cdr ls) (fx+ idx 4) (cons (cons idx a) reloc))] - [(word) - (let ([v (cdr a)]) - (set-code-word! x idx v) - (f (cdr ls) (fx+ idx 4) reloc))] - [(current-frame-offset) - (set-code-word! x idx idx) - (f (cdr ls) (fx+ idx 4) reloc)] - [(label) - (set-label-loc! (cdr a) (cons x idx)) - (f (cdr ls) idx reloc)] - [else - (error 'whack-instructions "unknown instr ~s" a)]))]))) - (f ls 0 '()))) - -(define wordsize 4) - - -(define compute-reloc-size - (lambda (ls) - (fold (lambda (x ac) - (case (car x) - [(reloc-word foreign-label) (fx+ ac 2)] - [(relative reloc-word+ label-addr) (fx+ ac 3)] - [(word byte label current-frame-offset) ac] - [else (error 'compute-reloc-size "unknown instr ~s" x)])) - 0 - ls))) - -(define whack-reloc - (lambda (vec) - (define reloc-idx 0) - (lambda (r) - (let ([idx (car r)] [type (cadr r)] [v (cddr r)]) - (case type - [(reloc-word) - (vector-set! vec reloc-idx (fxsll idx 2)) - (vector-set! vec (fx+ reloc-idx 1) v) - (set! reloc-idx (fx+ reloc-idx 2))] - [(foreign-label) - (vector-set! vec reloc-idx (fxlogor 1 (fxsll idx 2))) - (vector-set! vec (fx+ reloc-idx 1) v) - (set! reloc-idx (fx+ reloc-idx 2))] - [(reloc-word+) - (let ([obj (car v)] [disp (cdr v)]) - (vector-set! vec reloc-idx (fxlogor 2 (fxsll idx 2))) - (vector-set! vec (fx+ reloc-idx 1) disp) - (vector-set! vec (fx+ reloc-idx 2) obj) - (set! reloc-idx (fx+ reloc-idx 3)))] - [(label-addr) - (let ([loc (label-loc v)]) - (let ([obj (car loc)] [disp (cdr loc)]) - (vector-set! vec reloc-idx (fxlogor 2 (fxsll idx 2))) - (vector-set! vec (fx+ reloc-idx 1) (fx+ disp 11)) - (vector-set! vec (fx+ reloc-idx 2) obj))) - (set! reloc-idx (fx+ reloc-idx 3))] - [(relative) - (let ([loc (label-loc v)]) - (let ([obj (car loc)] [disp (cdr loc)]) - (vector-set! vec reloc-idx (fxlogor 3 (fxsll idx 2))) - (vector-set! vec (fx+ reloc-idx 1) (fx+ disp 11)) - (vector-set! vec (fx+ reloc-idx 2) obj))) - (set! reloc-idx (fx+ reloc-idx 3))] - [else (error 'whack-reloc "invalid reloc type ~s" type)])) - ))) - - -;;; (define list->code -;;; (lambda (ls) -;;; (let ([ls (convert-instructions ls)]) -;;; (let ([n (compute-code-size ls)] -;;; [m (compute-reloc-size ls)]) -;;; (let ([x (make-code n m 1)]) -;;; (let ([reloc* (whack-instructions x ls)]) -;;; (for-each (whack-reloc x) reloc*)) -;;; (make-code-executable! x) -;;; x))))) - -(define list*->code* - (lambda (ls*) - (let ([closure-size* (map car ls*)] - [ls* (map cdr ls*)]) - (let ([ls* (map convert-instructions ls*)]) - (let ([n* (map compute-code-size ls*)] - [m* (map compute-reloc-size ls*)]) - (let ([code* (map make-code n* closure-size*)] - [relv* (map make-vector m*)]) - (let ([reloc** (map whack-instructions code* ls*)]) - (for-each - (lambda (relv reloc*) - (for-each (whack-reloc relv) reloc*)) - relv* reloc**) - (for-each set-code-reloc-vector! code* relv*) - code*))))))) - -(define list->code - (lambda (ls) - (car (list*->code* (list ls))))) - -(primitive-set! 'list*->code* list*->code*) -) diff --git a/src/libintelasm-6.9.ss b/src/libintelasm-6.9.ss index 74ccc3c..497384a 100644 --- a/src/libintelasm-6.9.ss +++ b/src/libintelasm-6.9.ss @@ -558,6 +558,8 @@ (CODE #x83 (ModRM 3 '/7 dst (IMM8 src ac)))] [(and (imm? src) (eq? dst '%eax)) (CODE #x3D (IMM32 src ac))] + [(and (imm? src) (reg? dst)) + (CODE #x81 (ModRM 3 '/7 dst (IMM32 src ac)))] [(and (reg? src) (reg? dst)) (CODE #x39 (ModRM 3 src dst ac))] [(and (mem? src) (reg? dst)) diff --git a/src/libinterpret-6.0.ss b/src/libinterpret-6.0.ss deleted file mode 100644 index 41ddfa2..0000000 --- a/src/libinterpret-6.0.ss +++ /dev/null @@ -1,277 +0,0 @@ - -;;; Expand : Scheme -> Core Scheme -;;; -;;; ::= (quote datum) -;;; | -;;; | (if ) -;;; | (set! ) -;;; | (begin ...) -;;; | (lambda ...) -;;; | ( ...) -;;; | (primref ) -;;; | ( ...) -;;; ::= () -;;; | -;;; | ( . ) -;;; ::= void | memv | top-level-value | set-top-level-value! -;;; - - -(let () - (define syntax-error - (lambda (x) - (error 'interpret "invalid syntax ~s" x))) - ;;; - (define C*->last - (lambda (a d env) - (cond - [(null? d) (C a env)] - [else - (let ([a (C a env)] - [d (C*->last (car d) (cdr d) env)]) - (lambda (renv) - (a renv) - (d renv)))]))) - ;;; - (define C*->list - (lambda (a d env) - (cond - [(null? d) - (let ([a (C a env)]) - (lambda (renv) - (list (a renv))))] - [else - (let ([a (C a env)] - [d (C*->list (car d) (cdr d) env)]) - (lambda (renv) - (cons (a renv) (d renv))))]))) - ;;; - (define extend-env - (lambda (fml* env) - (cons fml* env))) - ;;; - (define fml-length - (lambda (fml* x) - (cond - [(pair? fml*) (fxadd1 (fml-length (cdr fml*) x))] - [(null? fml*) 0] - [(symbol? fml*) 1] - [else (syntax-error x)]))) - ;;; - (define whack-proper - (lambda (v ls i j) - (cond - [(null? ls) - (if (fx= i j) - v - (error 'apply1 "incorrect number of arguments to procedure"))] - [(fx= i j) - (error 'apply2 "incorrect number of arguments to procedure")] - [else - (vector-set! v i (car ls)) - (whack-proper v (cdr ls) (fxadd1 i) j)]))) - ;;; - (define whack-improper - (lambda (v ls i j) - (cond - [(fx= i j) (vector-set! v i ls) v] - [(null? ls) - (error 'apply3 "incorrect number of arguments to procedure")] - [else - (vector-set! v i (car ls)) - (whack-improper v (cdr ls) (fxadd1 i) j)]))) - ;;; - (define lookup - (lambda (x env) - (define Lj - (lambda (x fml* j) - (cond - [(pair? fml*) - (if (eq? (car fml*) x) - j - (Lj x (cdr fml*) (fxadd1 j)))] - [(eq? x fml*) j] - [else #f]))) - (define Li - (lambda (x env i) - (cond - [(null? env) #f] - [(Lj x (car env) 0) => - (lambda (j) - (cons i j))] - [else (Li x (cdr env) (fxadd1 i))]))) - (Li x env 0))) - ;;; - (define C - (lambda (x env) - (cond - [(gensym? x) - (cond - [(lookup x env) => - (lambda (b) - (let ([i (car b)] [j (cdr b)]) - (lambda (renv) - (vector-ref (list-ref renv i) j))))] - [else (syntax-error x)])] - [(pair? x) - (let ([a (car x)] [d (cdr x)]) - (unless (list? d) (syntax-error x)) - (cond - [(eq? a 'quote) - (unless (fx= (length d) 1) (syntax-error x)) - (let ([v (car d)]) - (lambda (renv) v))] - [(eq? a 'if) - (unless (fx= (length d) 3) (syntax-error x)) - (let ([test (C (car d) env)] - [conseq (C (cadr d) env)] - [altern (C (caddr d) env)]) - (lambda (renv) - (if (test renv) - (conseq renv) - (altern renv))))] - [(eq? a 'set!) - (unless (fx= (length d) 2) (syntax-error x)) - (let ([var (car d)] [val (C (cadr d) env)]) - (cond - [(lookup var env) => - (lambda (b) - (let ([i (car b)] [j (cdr b)]) - (lambda (renv) - (vector-set! (list-ref renv i) j (val renv)))))] - [else (syntax-error x)]))] - [(eq? a 'begin) - (unless (fx>= (length d) 1) (syntax-error x)) - (C*->last (car d) (cdr d) env)] - [(eq? a 'lambda) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([fml* (car d)] [body* (cdr d)]) - (let ([env (extend-env fml* env)] - [n (fml-length fml* x)]) - (let ([body* (C*->last (car body*) (cdr body*) env)]) - (if (list? fml*) - (lambda (renv) - (lambda args - (body* - (cons (whack-proper (make-vector n) args 0 n) - renv)))) - (lambda (renv) - (lambda args - (body* - (cons - (whack-improper - (make-vector n) args 0 (fxsub1 n)) - renv))))))))] - [(eq? a 'void) - (unless (fx= (length d) 0) (syntax-error x)) - (lambda (renv) (void))] - [(eq? a 'memv) - (unless (fx= (length d) 2) (syntax-error x)) - (let ([val (C (car d) env)] [list (C (cadr d) env)]) - (lambda (renv) - (memq (val renv) (list renv))))] - [(eq? a 'top-level-value) - (unless (fx= (length d) 1) (syntax-error x)) - (let ([qsym (car d)]) - (unless (and (pair? qsym) - (fx= (length qsym) 2) - (eq? (car qsym) 'quote) - (symbol? (cadr qsym))) - (syntax-error x)) - (let ([sym (cadr qsym)]) - (if (top-level-bound? sym) - (lambda (renv) - (top-level-value sym)) - (lambda (renv) - (if (top-level-bound? sym) - (top-level-value sym) - (error #f "~s is unbound" sym))))))] - [(memq a '(set-top-level-value!)) - (unless (fx= (length d) 2) (syntax-error x)) - (let ([qsym (car d)] [val (C (cadr d) env)]) - (unless (and (pair? qsym) - (fx= (length qsym) 2) - (eq? (car qsym) 'quote) - (symbol? (cadr qsym))) - (syntax-error x)) - (let ([sym (cadr qsym)]) - (lambda (renv) - (set-top-level-value! sym (val renv)))))] - ;;; [(eq? a '$pcb-set!) - ;;; (unless (fx= (length d) 2) (syntax-error x)) - ;;; (let ([sym (car d)] [val (C (cadr d) env)]) - ;;; (unless (symbol? sym) (syntax-error x)) - ;;; (lambda (renv) - ;;; (set-top-level-value! sym (val renv))))] - [(eq? a '|#primitive|) - (unless (fx= (length d) 1) (syntax-error x)) - (let ([sym (car d)]) - (let ([prim (primitive-ref sym)]) - (if (procedure? prim) - (lambda (renv) prim) - (syntax-error x))))] - [(memq a '(foreign-call $apply)) - (error 'interpret "~a form is not supported" a)] - ;;; [else - ;;; (let ([rator (C a env)] [n (length d)]) - ;;; (cond - ;;; [(fx= n 0) - ;;; (lambda (renv) - ;;; (let ([p (rator renv)]) - ;;; (p)))] - ;;; [(fx= n 1) - ;;; (let ([arg1 (C (car d) env)]) - ;;; (lambda (renv) - ;;; (let ([p (rator renv)]) - ;;; (p (arg1 renv)))))] - ;;; [(fx= n 2) - ;;; (let ([arg1 (C (car d) env)] - ;;; [arg2 (C (cadr d) env)]) - ;;; (lambda (renv) - ;;; (let ([p (rator renv)]) - ;;; (p (arg1 renv) (arg2 renv)))))] - ;;; [else - ;;; (let ([arg* (C*->list (car d) (cdr d) env)]) - ;;; (lambda (renv) - ;;; (apply (rator renv) (arg* renv))))]))] - [else - (let ([rator (C a env)] [n (length d)]) - (cond - [(fx= n 0) - (lambda (renv) - (apply (rator renv) '()))] - ;[(fx= n 1) - ; (let ([arg1 (C (car d) env)]) - ; (lambda (renv) - ; ((rator renv) (arg1 renv))))] - ;[(fx= n 2) - ; (let ([arg1 (C (car d) env)] - ; [arg2 (C (cadr d) env)]) - ; (lambda (renv) - ; ((rator renv) (arg1 renv) (arg2 renv))))] - [else - (let ([arg* (C*->list (car d) (cdr d) env)]) - (lambda (renv) - (apply (rator renv) (arg* renv))))]))] - - ))] - [else (syntax-error x)]))) - ;;; - (primitive-set! 'interpret - (lambda (x) - (let ([x (expand x)]) - (let ([p (C x '())]) - (p '()))))) - ;;; - (primitive-set! 'current-eval - (make-parameter - interpret - (lambda (f) - (unless (procedure? f) - (error 'current-eval "~s is not a procedure" f)) - f))) - ;;; - (primitive-set! 'eval - (lambda (x) - ((current-eval) x)))) - diff --git a/src/libinterpret-6.1.ss b/src/libinterpret-6.1.ss deleted file mode 100644 index f4172f2..0000000 --- a/src/libinterpret-6.1.ss +++ /dev/null @@ -1,324 +0,0 @@ - -;;; Changes: -;;; 6.1: adding case-lambda, dropping lambda -;;; 6.0: basic version working -;;; - -;;; Expand : Scheme -> Core Scheme -;;; -;;; ::= (quote datum) -;;; | -;;; | (if ) -;;; | (set! ) -;;; | (begin ...) -;;; | (case-lambda ( ) ( ) ...) -;;; | ( ...) -;;; | (primref ) -;;; | ( ...) -;;; ::= () -;;; | -;;; | ( . ) -;;; ::= void | memv | top-level-value | set-top-level-value! -;;; - - -(let () - (define syntax-error - (lambda (x) - (error 'interpret "invalid syntax ~s" x))) - ;;; - (define C*->last - (lambda (a d env) - (cond - [(null? d) (C a env)] - [else - (let ([a (C a env)] - [d (C*->last (car d) (cdr d) env)]) - (lambda (renv) - (a renv) - (d renv)))]))) - ;;; - (define C*->list - (lambda (a d env) - (cond - [(null? d) - (let ([a (C a env)]) - (lambda (renv) - (list (a renv))))] - [else - (let ([a (C a env)] - [d (C*->list (car d) (cdr d) env)]) - (lambda (renv) - (cons (a renv) (d renv))))]))) - ;;; - (define extend-env - (lambda (fml* env) - (cons fml* env))) - ;;; - (define fml-length - (lambda (fml* x) - (cond - [(pair? fml*) (fxadd1 (fml-length (cdr fml*) x))] - [(null? fml*) 0] - [(symbol? fml*) 1] - [else (syntax-error x)]))) - ;;; - (define whack-proper - (lambda (v ls i j) - (cond - [(null? ls) - (if (fx= i j) - v - (error 'apply1 "incorrect number of arguments to procedure"))] - [(fx= i j) - (error 'apply2 "incorrect number of arguments to procedure")] - [else - (vector-set! v i (car ls)) - (whack-proper v (cdr ls) (fxadd1 i) j)]))) - ;;; - (define whack-improper - (lambda (v ls i j) - (cond - [(fx= i j) (vector-set! v i ls) v] - [(null? ls) - (error 'apply3 "incorrect number of arguments to procedure")] - [else - (vector-set! v i (car ls)) - (whack-improper v (cdr ls) (fxadd1 i) j)]))) - ;;; - (define lookup - (lambda (x env) - (define Lj - (lambda (x fml* j) - (cond - [(pair? fml*) - (if (eq? (car fml*) x) - j - (Lj x (cdr fml*) (fxadd1 j)))] - [(eq? x fml*) j] - [else #f]))) - (define Li - (lambda (x env i) - (cond - [(null? env) #f] - [(Lj x (car env) 0) => - (lambda (j) - (cons i j))] - [else (Li x (cdr env) (fxadd1 i))]))) - (Li x env 0))) - ;;; - (define C - (lambda (x env) - (cond - [(gensym? x) - (cond - [(lookup x env) => - (lambda (b) - (let ([i (car b)] [j (cdr b)]) - (lambda (renv) - (vector-ref (list-ref renv i) j))))] - [else (syntax-error x)])] - [(pair? x) - (let ([a (car x)] [d (cdr x)]) - (unless (list? d) (syntax-error x)) - (cond - [(eq? a 'quote) - (unless (fx= (length d) 1) (syntax-error x)) - (let ([v (car d)]) - (lambda (renv) v))] - [(eq? a 'if) - (unless (fx= (length d) 3) (syntax-error x)) - (let ([test (C (car d) env)] - [conseq (C (cadr d) env)] - [altern (C (caddr d) env)]) - (lambda (renv) - (if (test renv) - (conseq renv) - (altern renv))))] - [(eq? a 'set!) - (unless (fx= (length d) 2) (syntax-error x)) - (let ([var (car d)] [val (C (cadr d) env)]) - (cond - [(lookup var env) => - (lambda (b) - (let ([i (car b)] [j (cdr b)]) - (lambda (renv) - (vector-set! (list-ref renv i) j (val renv)))))] - [else (syntax-error x)]))] - [(eq? a 'begin) - (unless (fx>= (length d) 1) (syntax-error x)) - (C*->last (car d) (cdr d) env)] - [(eq? a 'case-lambda) - (unless (fx>= (length d) 1) (syntax-error x)) - (let () - (define generate - (lambda (d) - (cond - [(null? d) - (lambda (n args renv) - (error 'apply - "incorrect number of arguments ~s to procedure" - n))] - [else - (let ([k (generate (cdr d))] - [a (car d)]) - (let ([fml (car a)] [body* (cdr a)]) - (let ([env (extend-env fml env)] - [n (fml-length fml x)]) - (let ([body* - (C*->last (car body*) (cdr body*) env)]) - (if (list? fml) - (lambda (m args renv) - (if (fx= n m) - (body* (cons (list->vector args) renv)) - (k m args renv))) - (let ([q (fxsub1 n)]) - (lambda (m args renv) - (if (fx>= m q) - (let ([v (make-vector n)]) - (let f ([i 0] [args args]) - (cond - [(fx= i q) - (vector-set! v q args)] - [else - (vector-set! v i (car args)) - (f (fxadd1 i) (cdr args))])) - (body* (cons v renv))) - (k m args renv)))))))))]))) - (let ([dispatch (generate d)]) - (lambda (renv) - (lambda args - (dispatch (length args) args renv)))))] - [(eq? a 'lambda) - (syntax-error x) - (unless (fx>= (length d) 2) (syntax-error x)) - (let ([fml* (car d)] [body* (cdr d)]) - (let ([env (extend-env fml* env)] - [n (fml-length fml* x)]) - (let ([body* (C*->last (car body*) (cdr body*) env)]) - (if (list? fml*) - (lambda (renv) - (lambda args - (body* - (cons (whack-proper (make-vector n) args 0 n) - renv)))) - (lambda (renv) - (lambda args - (body* - (cons - (whack-improper - (make-vector n) args 0 (fxsub1 n)) - renv))))))))] - [(eq? a 'void) - (unless (fx= (length d) 0) (syntax-error x)) - (lambda (renv) (void))] - [(eq? a 'memv) - (unless (fx= (length d) 2) (syntax-error x)) - (let ([val (C (car d) env)] [list (C (cadr d) env)]) - (lambda (renv) - (memq (val renv) (list renv))))] - [(eq? a 'top-level-value) - (unless (fx= (length d) 1) (syntax-error x)) - (let ([qsym (car d)]) - (unless (and (pair? qsym) - (fx= (length qsym) 2) - (eq? (car qsym) 'quote) - (symbol? (cadr qsym))) - (syntax-error x)) - (let ([sym (cadr qsym)]) - (if (top-level-bound? sym) - (lambda (renv) - (top-level-value sym)) - (lambda (renv) - (if (top-level-bound? sym) - (top-level-value sym) - (error #f "~s is unbound" sym))))))] - [(memq a '(set-top-level-value!)) - (unless (fx= (length d) 2) (syntax-error x)) - (let ([qsym (car d)] [val (C (cadr d) env)]) - (unless (and (pair? qsym) - (fx= (length qsym) 2) - (eq? (car qsym) 'quote) - (symbol? (cadr qsym))) - (syntax-error x)) - (let ([sym (cadr qsym)]) - (lambda (renv) - (set-top-level-value! sym (val renv)))))] - ;;; [(eq? a '$pcb-set!) - ;;; (unless (fx= (length d) 2) (syntax-error x)) - ;;; (let ([sym (car d)] [val (C (cadr d) env)]) - ;;; (unless (symbol? sym) (syntax-error x)) - ;;; (lambda (renv) - ;;; (set-top-level-value! sym (val renv))))] - [(eq? a '|#primitive|) - (unless (fx= (length d) 1) (syntax-error x)) - (let ([sym (car d)]) - (let ([prim (primitive-ref sym)]) - (if (procedure? prim) - (lambda (renv) prim) - (syntax-error x))))] - [(memq a '(foreign-call $apply)) - (error 'interpret "~a form is not supported" a)] - ;;; [else - ;;; (let ([rator (C a env)] [n (length d)]) - ;;; (cond - ;;; [(fx= n 0) - ;;; (lambda (renv) - ;;; (let ([p (rator renv)]) - ;;; (p)))] - ;;; [(fx= n 1) - ;;; (let ([arg1 (C (car d) env)]) - ;;; (lambda (renv) - ;;; (let ([p (rator renv)]) - ;;; (p (arg1 renv)))))] - ;;; [(fx= n 2) - ;;; (let ([arg1 (C (car d) env)] - ;;; [arg2 (C (cadr d) env)]) - ;;; (lambda (renv) - ;;; (let ([p (rator renv)]) - ;;; (p (arg1 renv) (arg2 renv)))))] - ;;; [else - ;;; (let ([arg* (C*->list (car d) (cdr d) env)]) - ;;; (lambda (renv) - ;;; (apply (rator renv) (arg* renv))))]))] - [else - (let ([rator (C a env)] [n (length d)]) - (cond - [(fx= n 0) - (lambda (renv) - (apply (rator renv) '()))] - ;[(fx= n 1) - ; (let ([arg1 (C (car d) env)]) - ; (lambda (renv) - ; ((rator renv) (arg1 renv))))] - ;[(fx= n 2) - ; (let ([arg1 (C (car d) env)] - ; [arg2 (C (cadr d) env)]) - ; (lambda (renv) - ; ((rator renv) (arg1 renv) (arg2 renv))))] - [else - (let ([arg* (C*->list (car d) (cdr d) env)]) - (lambda (renv) - (apply (rator renv) (arg* renv))))]))] - - ))] - [else (syntax-error x)]))) - ;;; - (primitive-set! 'interpret - (lambda (x) - (let ([x (expand x)]) - (let ([p (C x '())]) - (p '()))))) - ;;; - (primitive-set! 'current-eval - (make-parameter - interpret - (lambda (f) - (unless (procedure? f) - (error 'current-eval "~s is not a procedure" f)) - f))) - ;;; - (primitive-set! 'eval - (lambda (x) - ((current-eval) x)))) - diff --git a/src/libinterpret.fasl b/src/libinterpret.fasl index d167d41..ea77e62 100644 Binary files a/src/libinterpret.fasl and b/src/libinterpret.fasl differ diff --git a/src/libio-6.0.ss b/src/libio-6.0.ss deleted file mode 100644 index bbbe610..0000000 --- a/src/libio-6.0.ss +++ /dev/null @@ -1,510 +0,0 @@ - -;;; OUTPUT PORTS - -(let () - ;;; only file-based ports are supported at this point - ;;; - ;;; an output port is a vector with the following fields: - ;;; 0. id - ;;; 1. file-name - ;;; 2. file-descriptor - ;;; 3. open? - ;;; 4. buffer - ;;; 5. buffer-size - ;;; 6. index - ;;; 7. flush-proc - ;;; 8. close-proc - (define output-port-id (gensym "output-port")) - (define output-port? - (lambda (x) - (and (vector? x) - (fx= (vector-length x) 9) - (eq? (vector-ref x 0) output-port-id)))) - (define output-port-name - (lambda (p) (vector-ref p 1))) - (define output-port-fd - (lambda (p) (vector-ref p 2))) - (define set-output-port-fd! - (lambda (p x) (vector-set! p 2 x))) - (define output-port-open? - (lambda (p) (vector-ref p 3))) - (define set-output-port-open?! - (lambda (p b) (vector-set! p 3 b))) - (define output-port-buffer - (lambda (p) (vector-ref p 4))) - (define set-output-port-buffer! - (lambda (p b) (vector-set! p 4 b))) - (define output-port-size - (lambda (p) (vector-ref p 5))) - (define output-port-index - (lambda (p) (vector-ref p 6))) - (define output-port-flush-proc - (lambda (p) (vector-ref p 7))) - (define output-port-close-proc - (lambda (p) (vector-ref p 8))) - (define set-output-port-index! - (lambda (p i) (vector-set! p 6 i))) - (define fd->port - (lambda (fd filename) - (vector output-port-id ; id - filename - fd - #t - (make-string 4096) - 4096 - 0 - fd-flush-proc - fd-close-proc))) - (define open-output-string - (lambda () - (vector output-port-id - '*string-port* - '() - #t - (make-string 4096) - 4096 - 0 - str-flush-proc - (lambda (port) (void))))) - (define get-output-string - (lambda (p) - (define fill - (lambda (dst src di si sj) - (cond - [(fx= si sj) dst] - [else - (string-set! dst di (string-ref src si)) - (fill dst src (fxadd1 di) (fxadd1 si) sj)]))) - (unless (output-port? p) - (error 'get-output-string "~s is not an output port" p)) - (let ([ls (output-port-fd p)]) - (unless (list? ls) - (error 'get-output-string "~s is not an output port" p)) - (let f ([ls (reverse ls)] [n 0]) - (cond - [(null? ls) - (let ([idx (output-port-index p)] - [buf (output-port-buffer p)]) - (let ([str (make-string (fx+ n idx))]) - (fill str buf n 0 idx)))] - [else - (let ([buf (car ls)]) - (let ([idx (string-length buf)]) - (let ([str (f (cdr ls) (fx+ n idx))]) - (fill str buf n 0 idx))))]))))) - - (define open-output-file - (lambda (filename . rest) - (unless (string? filename) - (error 'open-output-file "invalid filename ~s" filename)) - (let ([mode - (let ([fst - (cond - [(null? rest) 'error] - [(null? (cdr rest)) (car rest)] - [else - (error 'open-output-file "too many arguments")])] - [mode-map - '([error . 0] [append . 1] [replace . 2] [truncate . 3])]) - (cond - [(assq fst mode-map) => cdr] - [else (error 'open-output-file "invalid mode ~s" fst)]))]) - (let ([fh (foreign-call "ik_open_file" filename mode)]) - (fd->port fh filename))))) - (define write-char - (lambda (c . port) - (let ([port - (cond - [(null? port) (current-output-port)] - [(null? (cdr port)) - (let ([p (car port)]) - (if (output-port? p) - p - (error 'write-char "not a port: ~s" p)))] - [else - (error 'write-char "too many arguments")])]) - (unless (char? c) - (error 'write-char "not a char: ~s" c)) - (unless (output-port-open? port) - (error 'write-char "port ~s closed" port)) - (let ([idx (output-port-index port)] [size (output-port-size port)]) - (if (fx< idx size) - (begin - (string-set! (output-port-buffer port) idx c) - (set-output-port-index! port (fxadd1 idx)) - (when (char= c #\newline) - (flush-output-port port))) - (begin - (flush-output-port port) - (write-char c port))))))) - (define fd-flush-proc - (lambda (port) - (let ([idx (output-port-index port)]) - (when (fx> idx 0) - (foreign-call "ik_write" - (output-port-fd port) - idx - (output-port-buffer port)))) - (set-output-port-index! port 0))) - (define str-flush-proc - (lambda (port) - (let ([idx (output-port-index port)]) - (when (fx> idx 0) - (let ([str (output-port-buffer port)]) - (when (fx= idx (string-length str)) - (set-output-port-fd! port - (cons str (output-port-fd port))) - (set-output-port-buffer! port - (make-string (string-length str))) - (set-output-port-index! port 0))))))) - (define fd-close-proc - (lambda (port) - (let ([idx (output-port-index port)]) - (when (fx> idx 0) - (foreign-call "ik_write" - (output-port-fd port) - idx - (output-port-buffer port)))) - (foreign-call "ik_close" (output-port-fd port)))) - - (define flush-output-port - (lambda port - (let ([port - (cond - [(null? port) (current-output-port)] - [(null? (cdr port)) - (let ([p (car port)]) - (if (output-port? p) - p - (error 'flush-output-port "not a port: ~s" p)))] - [else - (error 'flush-output-port "too many arguments")])]) - (unless (output-port-open? port) - (error 'flush-output-port "port ~s closed" port)) - ((output-port-flush-proc port) port)))) - (define close-output-port - (lambda (port) - (unless (output-port? port) - (error 'close-output-port "not a port ~s" port)) - (when (output-port-open? port) - ((output-port-close-proc port) port) - (set-output-port-open?! port #f)))) - - ;;; init section - (primitive-set! 'close-output-port close-output-port) - (primitive-set! 'output-port? output-port?) - (primitive-set! 'open-output-file open-output-file) - (primitive-set! 'write-char write-char) - (primitive-set! 'flush-output-port flush-output-port) - (primitive-set! 'standard-output-port - (let ([p (fd->port 1 '*stdout*)]) - (lambda () p))) - (primitive-set! 'standard-error-port - (let ([p (fd->port 2 '*stderr*)]) - (lambda () p))) - (primitive-set! 'current-output-port - (make-parameter (standard-output-port) - (lambda (p) - (unless (output-port? p) - (error 'current-output-port "not a port ~s" p)) - p))) - (primitive-set! 'console-output-port - (make-parameter (standard-output-port) - (lambda (p) - (unless (output-port? p) - (error 'console-output-port "not a port ~s" p)) - p))) - (primitive-set! 'newline - (lambda args - (if (null? args) - (write-char #\newline (current-output-port)) - (if (null? (cdr args)) - (let ([p (car args)]) - (if (output-port? p) - (write-char #\newline p) - (error 'newline "not an output port ~s" p))) - (error 'newline "too many arguments"))))) - (primitive-set! 'open-output-string open-output-string) - (primitive-set! 'get-output-string get-output-string) - (primitive-set! 'output-port-name - (lambda (x) - (if (output-port? x) - (output-port-name x) - (error 'output-port-name "~s is not an output port" x))))) - -;;; INPUT PORTS - -(let () - ;;; input ports are similar to output ports, with the exception of - ;;; the ungetchar buffer - ;;; Fields: - ;;; 0. id - ;;; 1. file-name - ;;; 2. file-descriptor - ;;; 3. open? - ;;; 4. buffer - ;;; 5. buffer-size - ;;; 6. index - ;;; 7. unget - (define input-port-id (gensym "input-port")) - (define input-port? - (lambda (x) - (and (vector? x) - (fx= (vector-length x) 8) - (eq? (vector-ref x 0) input-port-id)))) - (define input-port-name - (lambda (x) - (vector-ref x 1))) - (define input-port-fd - (lambda (x) - (vector-ref x 2))) - (define input-port-open? - (lambda (x) - (vector-ref x 3))) - (define input-port-buffer - (lambda (x) - (vector-ref x 4))) - (define input-port-size - (lambda (x) - (vector-ref x 5))) - (define set-input-port-size! - (lambda (x i) - (vector-set! x 5 i))) - (define input-port-index - (lambda (x) - (vector-ref x 6))) - (define set-input-port-index! - (lambda (x i) - (vector-set! x 6 i))) - (define set-input-port-returned-char! - (lambda (x i) - (vector-set! x 7 i))) - (define input-port-returned-char - (lambda (x) - (vector-ref x 7))) - (define fd->port - (lambda (fd filename) - (vector input-port-id - filename - fd - #t - (make-string 4096) - 0 - 0 - #f))) - (define open-input-file - (lambda (filename) - (unless (string? filename) - (error 'open-input-file "not a string: ~s" filename)) - (let ([fd (foreign-call "ik_open_file" filename 4)]) - (fd->port fd filename)))) - (define close-input-port - (lambda port - (let ([port - (if (null? port) - (current-input-port) - (if (null? ($cdr port)) - (let ([p ($car port)]) - (if (input-port? p) - p - (error 'close-input-port "not an input port: ~s" p))) - (error 'close-input-port "too many arguments")))]) - (foreign-call "ik_close" (input-port-fd port)) - (void)))) - (define read-char - (lambda port - (let ([port - (if (null? port) - (current-input-port) - (if (null? ($cdr port)) - (let ([p ($car port)]) - (if (input-port? p) - p - (error 'read-char "not an input port: ~s" p))) - (error 'read-char "too many arguments")))]) - (unless (input-port-open? port) - (error 'read-char "port closed")) - (cond - [(input-port-returned-char port) => - (lambda (c) - (set-input-port-returned-char! port #f) - c)] - [else - (let ([idx (input-port-index port)] - [size (input-port-size port)] - [buf (input-port-buffer port)]) - (if ($fx< idx size) - (let ([c ($string-ref buf idx)]) - (set-input-port-index! port ($fxadd1 idx)) - c) - (let ([bytes - (foreign-call "ik_read" - (input-port-fd port) - buf - ($string-length buf))]) - (set-input-port-size! port bytes) - (if ($fxzero? bytes) - (begin - (set-input-port-index! port 0) - (eof-object)) - (begin - (let ([c ($string-ref buf 0)]) - (set-input-port-index! port 1) - c))))))])))) - (define peek-char - (lambda port - (let ([port - (if (null? port) - (current-input-port) - (if (null? (cdr port)) - (let ([p (car port)]) - (if (input-port? p) - p - (error 'peek-char "not an input port: ~s" p))) - (error 'peek-char "too many arguments")))]) - (unless (input-port-open? port) - (error 'peek-char "port closed")) - (cond - [(input-port-returned-char port) => - (lambda (c) c)] - [else - (let ([idx (input-port-index port)] - [size (input-port-size port)] - [buf (input-port-buffer port)]) - (if (fx< idx size) - (string-ref buf idx) - (let ([bytes - (foreign-call "ik_read" - (input-port-fd port) - buf - ($string-length buf))]) - (set-input-port-size! port bytes) - (set-input-port-index! port 0) - (if (fxzero? bytes) - (eof-object) - (string-ref buf 0)))))])))) - (define reset-input-port! - (lambda (p) - (unless (input-port? p) - (error 'reset-input-port! "~s is not an input port" p)) - (set-input-port-index! p 0) - (set-input-port-size! p 0) - (set-input-port-returned-char! p #f))) - (define unread-char - (lambda (c . port) - (let ([port - (if (null? port) - (current-input-port) - (if (null? (cdr port)) - (let ([p (car port)]) - (if (input-port? p) - p - (error 'unread-char "not an input port: ~s" p))) - (error 'unread-char "too many arguments")))]) - (unless (char? c) - (error 'unread-char "not a character ~s" c)) - (unless (input-port-open? port) - (error 'unread-char "port closed")) - (when (input-port-returned-char port) - (error 'unread-char "cannot unread twice")) - (set-input-port-returned-char! port c)))) - (primitive-set! 'open-input-file open-input-file) - (primitive-set! 'close-input-port close-input-port) - (primitive-set! 'input-port? input-port?) - (primitive-set! 'read-char read-char) - (primitive-set! 'unread-char unread-char) - (primitive-set! 'peek-char peek-char) - (primitive-set! 'standard-input-port - (let ([p (fd->port 0 '*stdin*)]) - (lambda () p))) - (primitive-set! 'current-input-port - (make-parameter (standard-input-port) - (lambda (x) - (unless (input-port? x) - (error 'current-input-port "not an input port ~s" x)) - x))) - (primitive-set! 'console-input-port - (make-parameter (standard-input-port) - (lambda (x) - (unless (input-port? x) - (error 'console-input-port "not an input port ~s" x)) - x))) - (primitive-set! 'input-port-name - (lambda (x) - (if (input-port? x) - (input-port-name x) - (error 'input-port-name "~s is not an input port" x)))) - (primitive-set! 'reset-input-port! reset-input-port!)) - -(primitive-set! 'with-output-to-file - (lambda (name proc . args) - (unless (string? name) - (error 'with-output-to-file "~s is not a string" name)) - (unless (procedure? proc) - (error 'with-output-to-file "~s is not a procedure" proc)) - (let ([p (apply open-output-file name args)] - [shot #f]) - (parameterize ([current-output-port p]) - (dynamic-wind - (lambda () - (when shot - (error 'with-output-to-file - "cannot reenter"))) - proc - (lambda () - (close-output-port p) - (set! shot #t))))))) - -(primitive-set! 'call-with-output-file - (lambda (name proc . args) - (unless (string? name) - (error 'call-with-output-file "~s is not a string" name)) - (unless (procedure? proc) - (error 'call-with-output-file "~s is not a procedure" proc)) - (let ([p (apply open-output-file name args)] - [shot #f]) - (dynamic-wind - (lambda () - (when shot - (error 'call-with-output-file "cannot reenter"))) - (lambda () (proc p)) - (lambda () - (close-output-port p) - (set! shot #t)))))) - -(primitive-set! 'with-input-from-file - (lambda (name proc . args) - (unless (string? name) - (error 'with-input-from-file "~s is not a string" name)) - (unless (procedure? proc) - (error 'with-input-from-file "~s is not a procedure" proc)) - (let ([p (apply open-input-file name args)] - [shot #f]) - (parameterize ([current-input-port p]) - (dynamic-wind - (lambda () - (when shot - (error 'with-input-from-file - "cannot reenter"))) - proc - (lambda () - (close-input-port p) - (set! shot #t))))))) - -(primitive-set! 'call-with-input-file - (lambda (name proc . args) - (unless (string? name) - (error 'call-with-input-file "~s is not a string" name)) - (unless (procedure? proc) - (error 'call-with-input-file "~s is not a procedure" proc)) - (let ([p (apply open-input-file name args)] - [shot #f]) - (dynamic-wind - (lambda () - (when shot - (error 'call-with-input-file "cannot reenter"))) - (lambda () (proc p)) - (lambda () - (close-input-port p) - (set! shot #t)))))) - diff --git a/src/libio-6.1.ss b/src/libio-6.1.ss deleted file mode 100644 index b66ce45..0000000 --- a/src/libio-6.1.ss +++ /dev/null @@ -1,497 +0,0 @@ - -;;; OUTPUT PORTS - -(let () - ;;; only file-based ports are supported at this point - ;;; - ;;; an output port is a vector with the following fields: - ;;; 0. id - ;;; 1. file-name - ;;; 2. file-descriptor - ;;; 3. open? - ;;; 4. buffer - ;;; 5. buffer-size - ;;; 6. index - ;;; 7. flush-proc - ;;; 8. close-proc - (define output-port-id (gensym "output-port")) - (define output-port? - (lambda (x) - (and (vector? x) - (fx= (vector-length x) 9) - (eq? (vector-ref x 0) output-port-id)))) - (define output-port-name - (lambda (p) (vector-ref p 1))) - (define output-port-fd - (lambda (p) (vector-ref p 2))) - (define set-output-port-fd! - (lambda (p x) (vector-set! p 2 x))) - (define output-port-open? - (lambda (p) (vector-ref p 3))) - (define set-output-port-open?! - (lambda (p b) (vector-set! p 3 b))) - (define output-port-buffer - (lambda (p) (vector-ref p 4))) - (define set-output-port-buffer! - (lambda (p b) (vector-set! p 4 b))) - (define output-port-size - (lambda (p) (vector-ref p 5))) - (define output-port-index - (lambda (p) (vector-ref p 6))) - (define output-port-flush-proc - (lambda (p) (vector-ref p 7))) - (define output-port-close-proc - (lambda (p) (vector-ref p 8))) - (define set-output-port-index! - (lambda (p i) (vector-set! p 6 i))) - (define fd->port - (lambda (fd filename) - (vector output-port-id ; id - filename - fd - #t - (make-string 4096) - 4096 - 0 - fd-flush-proc - fd-close-proc))) - (define open-output-string - (lambda () - (vector output-port-id - '*string-port* - '() - #t - (make-string 4096) - 4096 - 0 - str-flush-proc - (lambda (port) (void))))) - (define get-output-string - (lambda (p) - (define fill - (lambda (dst src di si sj) - (cond - [(fx= si sj) dst] - [else - (string-set! dst di (string-ref src si)) - (fill dst src (fxadd1 di) (fxadd1 si) sj)]))) - (unless (output-port? p) - (error 'get-output-string "~s is not an output port" p)) - (let ([ls (output-port-fd p)]) - (unless (list? ls) - (error 'get-output-string "~s is not an output port" p)) - (let f ([ls (reverse ls)] [n 0]) - (cond - [(null? ls) - (let ([idx (output-port-index p)] - [buf (output-port-buffer p)]) - (let ([str (make-string (fx+ n idx))]) - (fill str buf n 0 idx)))] - [else - (let ([buf (car ls)]) - (let ([idx (string-length buf)]) - (let ([str (f (cdr ls) (fx+ n idx))]) - (fill str buf n 0 idx))))]))))) - (define open-output-file - (lambda (name mode) - (unless (string? name) - (error 'open-output-file "~s is not a valid file name" name)) - (let ([mode - (cond - [(assq mode '([error 0] [append 1] [replace 2] [truncate 3])) - => cadr] - [else - (error 'open-output-file "~s is not a valid mode" mode)])]) - (let ([fh (foreign-call "ik_open_file" name mode)]) - (fd->port fh name))))) - (define write-char - (lambda (c port) - (unless (char? c) - (error 'write-char "not a char: ~s" c)) - (unless (output-port-open? port) - (error 'write-char "port ~s closed" port)) - (let ([idx (output-port-index port)] [size (output-port-size port)]) - (if (fx< idx size) - (begin - (string-set! (output-port-buffer port) idx c) - (set-output-port-index! port (fxadd1 idx)) - (when ($char= c #\newline) - (flush-output-port port))) - (begin - (flush-output-port port) - (write-char c port)))))) - (define fd-flush-proc - (lambda (port) - (let ([idx (output-port-index port)]) - (when (fx> idx 0) - (foreign-call "ik_write" - (output-port-fd port) - idx - (output-port-buffer port)))) - (set-output-port-index! port 0))) - (define str-flush-proc - (lambda (port) - (let ([idx (output-port-index port)]) - (when (fx> idx 0) - (let ([str (output-port-buffer port)]) - (when (fx= idx (string-length str)) - (set-output-port-fd! port - (cons str (output-port-fd port))) - (set-output-port-buffer! port - (make-string (string-length str))) - (set-output-port-index! port 0))))))) - (define fd-close-proc - (lambda (port) - (let ([idx (output-port-index port)]) - (when (fx> idx 0) - (foreign-call "ik_write" - (output-port-fd port) - idx - (output-port-buffer port)))) - (foreign-call "ik_close" (output-port-fd port)))) - - (define flush-output-port - (lambda (port) - (unless (output-port-open? port) - (error 'flush-output-port "port ~s closed" port)) - ((output-port-flush-proc port) port))) - (define close-output-port - (lambda (port) - (when (output-port-open? port) - ((output-port-close-proc port) port) - (set-output-port-open?! port #f)))) - - ;;; init section - (primitive-set! 'close-output-port - (case-lambda - [() (close-output-port (current-output-port))] - [(p) - (unless (output-port? p) - (error 'close-output-port "~s is not an output port" p)) - (close-output-port p)])) - (primitive-set! 'output-port? output-port?) - (primitive-set! 'open-output-file - (case-lambda - [(filename) (open-output-file filename 'error)] - [(filename mode) (open-output-file filename mode)])) - (primitive-set! 'write-char - (case-lambda - [(c) (write-char c (current-output-port))] - [(c p) - (unless (output-port? p) - (error 'write-char "~s is not an output port" p)) - (write-char c p)])) - (primitive-set! 'flush-output-port - (case-lambda - [() (flush-output-port (current-output-port))] - [(p) - (unless (output-port? p) - (error 'flush-output-port "~s is not an output port" p)) - (flush-output-port p)])) - (primitive-set! 'standard-output-port - (let ([p (fd->port 1 '*stdout*)]) - (lambda () p))) - (primitive-set! 'standard-error-port - (let ([p (fd->port 2 '*stderr*)]) - (lambda () p))) - (primitive-set! 'current-output-port - (make-parameter (standard-output-port) - (lambda (p) - (unless (output-port? p) - (error 'current-output-port "not a port ~s" p)) - p))) - (primitive-set! 'console-output-port - (make-parameter (standard-output-port) - (lambda (p) - (unless (output-port? p) - (error 'console-output-port "not a port ~s" p)) - p))) - (primitive-set! 'newline - (case-lambda - [() (write-char #\newline (current-output-port))] - [(p) - (unless (output-port? p) - (error 'newline "~s is not an output port" p)) - (write-char #\newline p)])) - - (primitive-set! 'open-output-string open-output-string) - (primitive-set! 'get-output-string get-output-string) - (primitive-set! 'output-port-name - (lambda (x) - (if (output-port? x) - (output-port-name x) - (error 'output-port-name "~s is not an output port" x))))) - -;;; INPUT PORTS - -(let () - ;;; input ports are similar to output ports, with the exception of - ;;; the ungetchar buffer - ;;; Fields: - ;;; 0. id - ;;; 1. file-name - ;;; 2. file-descriptor - ;;; 3. open? - ;;; 4. buffer - ;;; 5. buffer-size - ;;; 6. index - ;;; 7. unget - (define input-port-id (gensym "input-port")) - (define input-port? - (lambda (x) - (and (vector? x) - (fx= (vector-length x) 8) - (eq? (vector-ref x 0) input-port-id)))) - (define input-port-name - (lambda (x) - (vector-ref x 1))) - (define input-port-fd - (lambda (x) - (vector-ref x 2))) - (define input-port-open? - (lambda (x) - (vector-ref x 3))) - (define input-port-buffer - (lambda (x) - (vector-ref x 4))) - (define input-port-size - (lambda (x) - (vector-ref x 5))) - (define set-input-port-size! - (lambda (x i) - (vector-set! x 5 i))) - (define input-port-index - (lambda (x) - (vector-ref x 6))) - (define set-input-port-index! - (lambda (x i) - (vector-set! x 6 i))) - (define set-input-port-returned-char! - (lambda (x i) - (vector-set! x 7 i))) - (define input-port-returned-char - (lambda (x) - (vector-ref x 7))) - (define fd->port - (lambda (fd filename) - (vector input-port-id - filename - fd - #t - (make-string 4096) - 0 - 0 - #f))) - (define open-input-file - (lambda (filename) - (unless (string? filename) - (error 'open-input-file "not a string: ~s" filename)) - (let ([fd (foreign-call "ik_open_file" filename 4)]) - (fd->port fd filename)))) - (define close-input-port - (lambda port - (let ([port - (if (null? port) - (current-input-port) - (if (null? ($cdr port)) - (let ([p ($car port)]) - (if (input-port? p) - p - (error 'close-input-port "not an input port: ~s" p))) - (error 'close-input-port "too many arguments")))]) - (foreign-call "ik_close" (input-port-fd port)) - (void)))) - (define read-char - (lambda (port) - (unless (input-port-open? port) - (error 'read-char "port closed")) - (cond - [(input-port-returned-char port) => - (lambda (c) - (set-input-port-returned-char! port #f) - c)] - [else - (let ([idx (input-port-index port)] - [size (input-port-size port)] - [buf (input-port-buffer port)]) - (if ($fx< idx size) - (let ([c ($string-ref buf idx)]) - (set-input-port-index! port ($fxadd1 idx)) - c) - (let ([bytes - (foreign-call "ik_read" - (input-port-fd port) - buf - ($string-length buf))]) - (set-input-port-size! port bytes) - (if ($fxzero? bytes) - (begin - (set-input-port-index! port 0) - (eof-object)) - (begin - (let ([c ($string-ref buf 0)]) - (set-input-port-index! port 1) - c))))))]))) - (define peek-char - (lambda (port) - (unless (input-port-open? port) - (error 'peek-char "port closed")) - (cond - [(input-port-returned-char port) => - (lambda (c) c)] - [else - (let ([idx (input-port-index port)] - [size (input-port-size port)] - [buf (input-port-buffer port)]) - (if (fx< idx size) - (string-ref buf idx) - (let ([bytes - (foreign-call "ik_read" - (input-port-fd port) - buf - ($string-length buf))]) - (set-input-port-size! port bytes) - (set-input-port-index! port 0) - (if (fxzero? bytes) - (eof-object) - (string-ref buf 0)))))]))) - (define reset-input-port! - (lambda (p) - (unless (input-port? p) - (error 'reset-input-port! "~s is not an input port" p)) - (set-input-port-index! p 0) - (set-input-port-size! p 0) - (set-input-port-returned-char! p #f))) - (define unread-char - (lambda (c port) - (unless (char? c) - (error 'unread-char "not a character ~s" c)) - (unless (input-port-open? port) - (error 'unread-char "port closed")) - (when (input-port-returned-char port) - (error 'unread-char "cannot unread twice")) - (set-input-port-returned-char! port c))) - (primitive-set! 'open-input-file open-input-file) - (primitive-set! 'close-input-port - (case-lambda - [() (close-input-port (current-input-port))] - [(p) - (unless (input-port? p) - (error 'close-input-port "~s is not an input port" p)) - (close-input-port p)])) - (primitive-set! 'input-port? input-port?) - (primitive-set! 'read-char - (case-lambda - [() (read-char (current-input-port))] - [(p) - (unless (input-port? p) - (error 'read-char "~s is not an input port" p)) - (read-char p)])) - (primitive-set! 'peek-char - (case-lambda - [() (peek-char (current-input-port))] - [(p) - (unless (input-port? p) - (error 'peek-char "~s is not an input port" p)) - (peek-char p)])) - (primitive-set! 'unread-char - (case-lambda - [(c) (unread-char c (current-input-port))] - [(c p) - (unless (input-port? p) - (error 'unread-char "~s is not an input port" p)) - (unread-char c p)])) - (primitive-set! 'standard-input-port - (let ([p (fd->port 0 '*stdin*)]) - (lambda () p))) - (primitive-set! 'current-input-port - (make-parameter (standard-input-port) - (lambda (x) - (unless (input-port? x) - (error 'current-input-port "not an input port ~s" x)) - x))) - (primitive-set! 'console-input-port - (make-parameter (standard-input-port) - (lambda (x) - (unless (input-port? x) - (error 'console-input-port "not an input port ~s" x)) - x))) - (primitive-set! 'input-port-name - (lambda (x) - (if (input-port? x) - (input-port-name x) - (error 'input-port-name "~s is not an input port" x)))) - (primitive-set! 'reset-input-port! reset-input-port!)) - -(primitive-set! 'with-output-to-file - (lambda (name proc . args) - (unless (string? name) - (error 'with-output-to-file "~s is not a string" name)) - (unless (procedure? proc) - (error 'with-output-to-file "~s is not a procedure" proc)) - (let ([p (apply open-output-file name args)] - [shot #f]) - (parameterize ([current-output-port p]) - (dynamic-wind - (lambda () - (when shot - (error 'with-output-to-file - "cannot reenter"))) - proc - (lambda () - (close-output-port p) - (set! shot #t))))))) - -(primitive-set! 'call-with-output-file - (lambda (name proc . args) - (unless (string? name) - (error 'call-with-output-file "~s is not a string" name)) - (unless (procedure? proc) - (error 'call-with-output-file "~s is not a procedure" proc)) - (let ([p (apply open-output-file name args)] - [shot #f]) - (dynamic-wind - (lambda () - (when shot - (error 'call-with-output-file "cannot reenter"))) - (lambda () (proc p)) - (lambda () - (close-output-port p) - (set! shot #t)))))) - -(primitive-set! 'with-input-from-file - (lambda (name proc . args) - (unless (string? name) - (error 'with-input-from-file "~s is not a string" name)) - (unless (procedure? proc) - (error 'with-input-from-file "~s is not a procedure" proc)) - (let ([p (apply open-input-file name args)] - [shot #f]) - (parameterize ([current-input-port p]) - (dynamic-wind - (lambda () - (when shot - (error 'with-input-from-file - "cannot reenter"))) - proc - (lambda () - (close-input-port p) - (set! shot #t))))))) - -(primitive-set! 'call-with-input-file - (lambda (name proc . args) - (unless (string? name) - (error 'call-with-input-file "~s is not a string" name)) - (unless (procedure? proc) - (error 'call-with-input-file "~s is not a procedure" proc)) - (let ([p (apply open-input-file name args)] - [shot #f]) - (dynamic-wind - (lambda () - (when shot - (error 'call-with-input-file "cannot reenter"))) - (lambda () (proc p)) - (lambda () - (close-input-port p) - (set! shot #t)))))) - diff --git a/src/libio-6.9.ss b/src/libio-6.9.ss deleted file mode 100644 index 216fb60..0000000 --- a/src/libio-6.9.ss +++ /dev/null @@ -1,407 +0,0 @@ - -;;; OUTPUT PORTS - -(let () - ;;; only file-based ports are supported at this point - ;;; - ;;; an output port is a vector with the following fields: - ;;; 0. id - ;;; 1. file-name - ;;; 2. file-descriptor - ;;; 3. open? - ;;; 4. buffer - ;;; 5. buffer-size - ;;; 6. index - ;;; 7. flush-proc - ;;; 8. close-proc - (define-record output-port - (name fd open? - buffer size index flush-proc close-proc)) - (define fd->port - (lambda (fd filename) - (make-output-port filename fd #t - (make-string 4096) 4096 0 - fd-flush-proc fd-close-proc))) - (define open-output-string - (lambda () - (make-output-port '*string-port* '() #t - (make-string 4096) 4096 0 - str-flush-proc (lambda (port) (void))))) - (define get-output-string - (lambda (p) - (define fill - (lambda (dst src di si sj) - (cond - [(fx= si sj) dst] - [else - (string-set! dst di (string-ref src si)) - (fill dst src (fxadd1 di) (fxadd1 si) sj)]))) - (unless (output-port? p) - (error 'get-output-string "~s is not an output port" p)) - (let ([ls (output-port-fd p)]) - (unless (list? ls) - (error 'get-output-string "~s is not an output port" p)) - (let f ([ls (reverse ls)] [n 0]) - (cond - [(null? ls) - (let ([idx (output-port-index p)] - [buf (output-port-buffer p)]) - (let ([str (make-string (fx+ n idx))]) - (fill str buf n 0 idx)))] - [else - (let ([buf (car ls)]) - (let ([idx (string-length buf)]) - (let ([str (f (cdr ls) (fx+ n idx))]) - (fill str buf n 0 idx))))]))))) - (define open-output-file - (lambda (name mode) - (unless (string? name) - (error 'open-output-file "~s is not a valid file name" name)) - (let ([mode - (cond - [(assq mode '([error 0] [append 1] [replace 2] [truncate 3])) - => cadr] - [else - (error 'open-output-file "~s is not a valid mode" mode)])]) - (let ([fh (foreign-call "ik_open_file" name mode)]) - (fd->port fh name))))) - (define write-char - (lambda (c port) - (unless (char? c) - (error 'write-char "not a char: ~s" c)) - (unless (output-port-open? port) - (error 'write-char "port ~s closed" port)) - (let ([idx (output-port-index port)] [size (output-port-size port)]) - (if (fx< idx size) - (begin - (string-set! (output-port-buffer port) idx c) - (set-output-port-index! port (fxadd1 idx)) - (when ($char= c #\newline) - (flush-output-port port))) - (begin - (flush-output-port port) - (write-char c port)))))) - (define fd-flush-proc - (lambda (port) - (let ([idx (output-port-index port)]) - (when (fx> idx 0) - (foreign-call "ik_write" - (output-port-fd port) - idx - (output-port-buffer port)))) - (set-output-port-index! port 0))) - (define str-flush-proc - (lambda (port) - (let ([idx (output-port-index port)]) - (when (fx> idx 0) - (let ([str (output-port-buffer port)]) - (when (fx= idx (string-length str)) - (set-output-port-fd! port - (cons str (output-port-fd port))) - (set-output-port-buffer! port - (make-string (string-length str))) - (set-output-port-index! port 0))))))) - (define fd-close-proc - (lambda (port) - (let ([idx (output-port-index port)]) - (when (fx> idx 0) - (foreign-call "ik_write" - (output-port-fd port) - idx - (output-port-buffer port)))) - (foreign-call "ik_close" (output-port-fd port)))) - - (define flush-output-port - (lambda (port) - (unless (output-port-open? port) - (error 'flush-output-port "port ~s closed" port)) - ((output-port-flush-proc port) port))) - (define close-output-port - (lambda (port) - (when (output-port-open? port) - ((output-port-close-proc port) port) - (set-output-port-open?! port #f)))) - - ;;; init section - (primitive-set! 'close-output-port - (case-lambda - [() (close-output-port (current-output-port))] - [(p) - (unless (output-port? p) - (error 'close-output-port "~s is not an output port" p)) - (close-output-port p)])) - (primitive-set! 'output-port? output-port?) - (primitive-set! 'open-output-file - (case-lambda - [(filename) (open-output-file filename 'error)] - [(filename mode) (open-output-file filename mode)])) - (primitive-set! 'write-char - (case-lambda - [(c) (write-char c (current-output-port))] - [(c p) - (unless (output-port? p) - (error 'write-char "~s is not an output port" p)) - (write-char c p)])) - (primitive-set! 'flush-output-port - (case-lambda - [() (flush-output-port (current-output-port))] - [(p) - (unless (output-port? p) - (error 'flush-output-port "~s is not an output port" p)) - (flush-output-port p)])) - (primitive-set! 'standard-output-port - (let ([p (fd->port 1 '*stdout*)]) - (lambda () p))) - (primitive-set! 'standard-error-port - (let ([p (fd->port 2 '*stderr*)]) - (lambda () p))) - (primitive-set! 'current-output-port - (make-parameter (standard-output-port) - (lambda (p) - (unless (output-port? p) - (error 'current-output-port "not a port ~s" p)) - p))) - (primitive-set! 'console-output-port - (make-parameter (standard-output-port) - (lambda (p) - (unless (output-port? p) - (error 'console-output-port "not a port ~s" p)) - p))) - (primitive-set! 'newline - (case-lambda - [() (write-char #\newline (current-output-port))] - [(p) - (unless (output-port? p) - (error 'newline "~s is not an output port" p)) - (write-char #\newline p)])) - - (primitive-set! 'open-output-string open-output-string) - (primitive-set! 'get-output-string get-output-string) - (primitive-set! 'output-port-name - (lambda (x) - (if (output-port? x) - (output-port-name x) - (error 'output-port-name "~s is not an output port" x))))) - -;;; INPUT PORTS - -(let () - ;;; input ports are similar to output ports, with the exception of - ;;; the ungetchar buffer - ;;; Fields: - ;;; 0. id - ;;; 1. file-name - ;;; 2. file-descriptor - ;;; 3. open? - ;;; 4. buffer - ;;; 5. buffer-size - ;;; 6. index - ;;; 7. unget - (define-record input-port - (name fd open? buffer size index returned-char)) - (define fd->port - (lambda (fd filename) - (make-input-port filename fd #t (make-string 4096) 0 0 #f))) - (define open-input-file - (lambda (filename) - (unless (string? filename) - (error 'open-input-file "not a string: ~s" filename)) - (let ([fd (foreign-call "ik_open_file" filename 4)]) - (fd->port fd filename)))) - (define close-input-port - (lambda (port) - (foreign-call "ik_close" (input-port-fd port)) - (set-input-port-open?! port #f) - (set-input-port-returned-char! port #f) - (set-input-port-index! port (input-port-size port)))) - (define read-char - (lambda (port) - (if (input-port-returned-char port) - (let ([c (input-port-returned-char port)]) - (set-input-port-returned-char! port #f) - c) - (let ([index (input-port-index port)]) - (if ($fx< index (input-port-size port)) - (begin - (set-input-port-index! port ($fxadd1 index)) - ($string-ref (input-port-buffer port) index)) - (if (input-port-open? port) - (let* ([buffer (input-port-buffer port)] - [bytes - (foreign-call "ik_read" - (input-port-fd port) - buffer - ($string-length buffer))]) - (set-input-port-size! port bytes) - (if ($fxzero? bytes) - (begin - (set-input-port-index! port 0) - (eof-object)) - (let ([c ($string-ref buffer 0)]) - (set-input-port-index! port 1) - c))) - (error 'read-char "input port ~s is not open" port))))))) - (define peek-char - (lambda (port) - (unless (input-port-open? port) - (error 'peek-char "port closed")) - (cond - [(input-port-returned-char port) => - (lambda (c) c)] - [else - (let ([idx (input-port-index port)] - [size (input-port-size port)] - [buf (input-port-buffer port)]) - (if (fx< idx size) - (string-ref buf idx) - (let ([bytes - (foreign-call "ik_read" - (input-port-fd port) - buf - ($string-length buf))]) - (set-input-port-size! port bytes) - (set-input-port-index! port 0) - (if (fxzero? bytes) - (eof-object) - (string-ref buf 0)))))]))) - (define reset-input-port! - (lambda (p) - (unless (input-port? p) - (error 'reset-input-port! "~s is not an input port" p)) - (set-input-port-index! p 0) - (set-input-port-size! p 0) - (set-input-port-returned-char! p #f))) - (define unread-char - (lambda (c port) - (unless (char? c) - (error 'unread-char "not a character ~s" c)) - (unless (input-port-open? port) - (error 'unread-char "port closed")) - (when (input-port-returned-char port) - (error 'unread-char "cannot unread twice")) - (set-input-port-returned-char! port c))) - (define *current-input-port* #f) - (primitive-set! 'open-input-file open-input-file) - (primitive-set! 'close-input-port - (case-lambda - [() (close-input-port *current-input-port*)] - [(p) - (unless (input-port? p) - (error 'close-input-port "~s is not an input port" p)) - (close-input-port p)])) - (primitive-set! 'input-port? input-port?) - (primitive-set! 'read-char - (case-lambda - [() (read-char *current-input-port*)] - [(p) (if (input-port? p) - (read-char p) - (error 'read-char "~s is not an input-port" p))])) - (primitive-set! 'peek-char - (case-lambda - [() (peek-char *current-input-port*)] - [(p) - (unless (input-port? p) - (error 'peek-char "~s is not an input port" p)) - (peek-char p)])) - (primitive-set! 'unread-char - (case-lambda - [(c) (unread-char c *current-input-port*)] - [(c p) - (unless (input-port? p) - (error 'unread-char "~s is not an input port" p)) - (unread-char c p)])) - (primitive-set! 'standard-input-port - (let ([p (fd->port 0 '*stdin*)]) - (lambda () p))) - (set! *current-input-port* (standard-input-port)) - (primitive-set! 'current-input-port - (case-lambda - [() *current-input-port*] - [(x) (if (input-port? x) - (set! *current-input-port* x) - (error 'current-input-port "~s is not an input port" x))])) - (primitive-set! 'console-input-port - (make-parameter (standard-input-port) - (lambda (x) - (unless (input-port? x) - (error 'console-input-port "not an input port ~s" x)) - x))) - (primitive-set! 'input-port-name - (lambda (x) - (if (input-port? x) - (input-port-name x) - (error 'input-port-name "~s is not an input port" x)))) - (primitive-set! 'reset-input-port! reset-input-port!)) - -(primitive-set! 'with-output-to-file - (lambda (name proc . args) - (unless (string? name) - (error 'with-output-to-file "~s is not a string" name)) - (unless (procedure? proc) - (error 'with-output-to-file "~s is not a procedure" proc)) - (let ([p (apply open-output-file name args)] - [shot #f]) - (parameterize ([current-output-port p]) - (dynamic-wind - (lambda () - (when shot - (error 'with-output-to-file - "cannot reenter"))) - proc - (lambda () - (close-output-port p) - (set! shot #t))))))) - -(primitive-set! 'call-with-output-file - (lambda (name proc . args) - (unless (string? name) - (error 'call-with-output-file "~s is not a string" name)) - (unless (procedure? proc) - (error 'call-with-output-file "~s is not a procedure" proc)) - (let ([p (apply open-output-file name args)] - [shot #f]) - (dynamic-wind - (lambda () - (when shot - (error 'call-with-output-file "cannot reenter"))) - (lambda () (proc p)) - (lambda () - (close-output-port p) - (set! shot #t)))))) - -(primitive-set! 'with-input-from-file - (lambda (name proc . args) - (unless (string? name) - (error 'with-input-from-file "~s is not a string" name)) - (unless (procedure? proc) - (error 'with-input-from-file "~s is not a procedure" proc)) - (let ([p (apply open-input-file name args)] - [shot #f]) - (parameterize ([current-input-port p]) - (dynamic-wind - (lambda () - (when shot - (error 'with-input-from-file - "cannot reenter"))) - proc - (lambda () - (close-input-port p) - (set! shot #t))))))) - -(primitive-set! 'call-with-input-file - (lambda (name proc . args) - (unless (string? name) - (error 'call-with-input-file "~s is not a string" name)) - (unless (procedure? proc) - (error 'call-with-input-file "~s is not a procedure" proc)) - (let ([p (apply open-input-file name args)] - [shot #f]) - (dynamic-wind - (lambda () - (when shot - (error 'call-with-input-file "cannot reenter"))) - (lambda () (proc p)) - (lambda () - (close-input-port p) - (set! shot #t)))))) - diff --git a/src/libio.fasl b/src/libio.fasl deleted file mode 100644 index da36080..0000000 Binary files a/src/libio.fasl and /dev/null differ diff --git a/src/libnumerics-7.1.ss b/src/libnumerics-7.1.ss deleted file mode 100644 index 26d081c..0000000 --- a/src/libnumerics-7.1.ss +++ /dev/null @@ -1,53 +0,0 @@ - -(let () - (define (generic+ a b) - (cond - [(fixnum? a) - (cond - [(fixnum? b) (foreign-call "iknum_add_fx_fx" a b)] - [(bignum? b) (foreign-call "iknum_add_fx_bn" a b)] - [else (error '+ "~s is not a number" b)])] - [(bignum? a) - (cond - [(fixnum? b) (foreign-call "iknum_add_fx_bn" b a)] - [(bignum? b) (foreign-call "iknum_add_bn_bn" a b)] - [else (error '+ "~s is not a number" b)])] - [else (error '+ "~s is not a number" a)])) - - (primitive-set! '+ - (case-lambda - [(a b) (generic+ a b)] - [(a b c) (generic+ a (generic+ b c))] - [(a) (if (number? a) a (error '+ "~s is not a number" a))] - [() 0] - [(a b . rest) - (let f ([a a] [b b] [rest rest]) - (generic+ a - (if (null? rest) - b - (f b ($car rest) ($cdr rest)))))])) - - (primitive-set! 'add1 - (lambda (a) - (cond - [(fixnum? a) - (if ($fx< a (most-positive-fixnum)) - ($fxadd1 a) - (foreign-call "iknum_add_fx_fx" a 1))] - [(bignum? a) - (foreign-call "iknum_add_fx_bn" 1 a)] - [else (error 'add1 "~s is not a number" a)]))) - - (primitive-set! 'sub1 - (lambda (a) - (cond - [(fixnum? a) - (if ($fx> a (most-negative-fixnum)) - ($fxsub1 a) - (foreign-call "iknum_add_fx_fx" a -1))] - [(bignum? a) - (foreign-call "iknum_add_fx_bn" -1 a)] - [else (error 'add1 "~s is not a number" a)]))) - - ) - diff --git a/src/libnumerics-9.1.ss b/src/libnumerics-9.1.ss new file mode 100644 index 0000000..a728a4e --- /dev/null +++ b/src/libnumerics-9.1.ss @@ -0,0 +1,376 @@ + +(let () + + (define bignum? + ; FIXME: temporary definition. Compiler should be made aware + ; of numeric representation once it's stable enough. + (lambda (x) + (foreign-call "ikrt_isbignum" x))) + + (define binary+ + (lambda (x y) + (cond + [(fixnum? x) + (cond + [(fixnum? y) + (foreign-call "ikrt_fxfxplus" x y)] + [(bignum? y) + (foreign-call "ikrt_fxbnplus" x y)] + [else + (error '+ "~s is not a number" y)])] + [(bignum? x) + (cond + [(fixnum? y) + (foreign-call "ikrt_fxbnplus" y x)] + [(bignum? y) + (foreign-call "ikrt_bnbnplus" x y)] + [else + (error '+ "~s is not a number" y)])] + [else (error '+ "~s is not a number" x)]))) + + (define binary-logand + (lambda (x y) + (cond + [(fixnum? x) + (cond + [(fixnum? y) (#%$fxlogand x y)] + [(bignum? y) + (foreign-call "ikrt_fxbnlogand" x y)] + [else + (error 'logand "~s is not a number" y)])] + [(bignum? x) + (cond + [(fixnum? y) + (foreign-call "ikrt_fxbnlogand" y x)] + [(bignum? y) + (foreign-call "ikrt_bnbnlogand" x y)] + [else + (error 'logand "~s is not a number" y)])] + [else (error 'logand "~s is not a number" x)]))) + + + (define binary- + (lambda (x y) + (cond + [(fixnum? x) + (cond + [(fixnum? y) + (foreign-call "ikrt_fxfxminus" x y)] + [(bignum? y) + (foreign-call "ikrt_fxbnminus" x y)] + [else + (error '- "~s is not a number" y)])] + [(bignum? x) + (cond + [(fixnum? y) + (foreign-call "ikrt_bnfxminus" x y)] + [(bignum? y) + (foreign-call "ikrt_bnbnminus" x y)] + [else + (error '- "~s is not a number" y)])] + [else (error '- "~s is not a number" x)]))) + + (define binary* + (lambda (x y) + (cond + [(fixnum? x) + (cond + [(fixnum? y) + (foreign-call "ikrt_fxfxmult" x y)] + [(bignum? y) + (foreign-call "ikrt_fxbnmult" x y)] + [else + (error '* "~s is not a number" y)])] + [(bignum? x) + (cond + [(fixnum? y) + (foreign-call "ikrt_fxbnmult" y x)] + [(bignum? y) + (foreign-call "ikrt_bnbnmult" x y)] + [else + (error '* "~s is not a number" y)])] + [else (error '* "~s is not a number" x)]))) + + (define + + (case-lambda + [(x y) (binary+ x y)] + [(x y z) (binary+ (binary+ x y) z)] + [(a) + (cond + [(fixnum? a) a] + [(bignum? a) a] + [else (error '+ "~s is not a number" a)])] + [() 0] + [(a b c d . e*) + (let f ([ac (binary+ (binary+ (binary+ a b) c) d)] + [e* e*]) + (cond + [(null? e*) ac] + [else (f (binary+ ac (car e*)) (cdr e*))]))])) + + (define logand + (case-lambda + [(x y) (binary-logand x y)] + [(x y z) (binary-logand (binary-logand x y) z)] + [(a) + (cond + [(fixnum? a) a] + [(bignum? a) a] + [else (error 'logand "~s is not a number" a)])] + [() -1] + [(a b c d . e*) + (let f ([ac (binary-logand (binary-logand (binary-logand a b) c) d)] + [e* e*]) + (cond + [(null? e*) ac] + [else (f (binary-logand ac (car e*)) (cdr e*))]))])) + + (define - + (case-lambda + [(x y) (binary- x y)] + [(x y z) (binary- (binary- x y) z)] + [(a) (binary- 0 a)] + [(a b c d . e*) + (let f ([ac (binary- (binary- (binary- a b) c) d)] + [e* e*]) + (cond + [(null? e*) ac] + [else (f (binary- ac (car e*)) (cdr e*))]))])) + + (define * + (case-lambda + [(x y) (binary* x y)] + [(x y z) (binary* (binary* x y) z)] + [(a) + (cond + [(fixnum? a) a] + [(bignum? a) a] + [else (error '* "~s is not a number" a)])] + [() 1] + [(a b c d . e*) + (let f ([ac (binary* (binary* (binary* a b) c) d)] + [e* e*]) + (cond + [(null? e*) ac] + [else (f (binary* ac (car e*)) (cdr e*))]))])) + + (define expt + (lambda (n m) + (cond + [(#%$fxzero? m) 1] + [(#%$fxzero? (#%$fxlogand m 1)) + (expt (binary* n n) (#%$fxsra m 1))] + [else + (binary* n (expt (binary* n n) (#%$fxsra m 1)))]))) + + + (define number? + (lambda (x) + (or (fixnum? x) + (bignum? x)))) + + (define positive-bignum? + (lambda (x) + (foreign-call "ikrt_positive_bn" x))) + + + (define even-bignum? + (lambda (x) (error 'even-bignum? "not implemented"))) + + (define number->string + (lambda (x) + (cond + [(fixnum? x) (fixnum->string x)] + [(bignum? x) (foreign-call "ikrt_bntostring" x)] + [else (error 'number->string "~s is not a number" x)]))) + + (define-syntax mk< + (syntax-rules () + [(_ name fxfx< fxbn< bnfx< bnbn<) + (let () + (define err + (lambda (x) (error 'name "~s is not a number" x))) + (define fxloopt + (lambda (x y ls) + (cond + [(fixnum? y) + (if (null? ls) + (fxfx< x y) + (if (fxfx< x y) + (fxloopt y (car ls) (cdr ls)) + (loopf (car ls) (cdr ls))))] + [(bignum? y) + (if (null? ls) + (fxbn< x y) + (if (fxbn< x y) + (bnloopt y (car ls) (cdr ls)) + (loopf (car ls) (cdr ls))))] + [else (err y)]))) + (define bnloopt + (lambda (x y ls) + (cond + [(fixnum? y) + (if (null? ls) + (bnfx< x y) + (if (bnfx< x y) + (fxloopt y (car ls) (cdr ls)) + (loopf (car ls) (cdr ls))))] + [(bignum? y) + (if (null? ls) + (bnbn< x y) + (if (bnbn< x y) + (bnloopt y (car ls) (cdr ls)) + (loopf (car ls) (cdr ls))))] + [else (err y)]))) + (define loopf + (lambda (x ls) + (cond + [(number? x) + (or (null? ls) (loopf (car ls) (cdr ls)))] + [else (err x)]))) + (case-lambda + [(x y) + (cond + [(fixnum? x) + (cond + [(fixnum? y) (fxfx< x y)] + [(bignum? y) (fxbn< x y)] + [else (err y)])] + [(bignum? x) + (cond + [(fixnum? y) (bnfx< x y)] + [(bignum? y) (bnbn< x y)] + [else (err y)])] + [else (err x)])] + [(x y z) + (cond + [(fixnum? x) + (cond + [(fixnum? y) + (cond + [(fixnum? z) (and (fxfx< x y) (fxfx< y z))] + [(bignum? z) + (and (fxfx< x y) (fxbn< y z))] + [else (err z)])] + [(bignum? y) + (cond + [(fixnum? z) #f] + [(bignum? z) + (and (fxbn< x y) (bnbn< y z))] + [else (err z)])] + [else (err y)])] + [(bignum? x) + (cond + [(fixnum? y) + (cond + [(fixnum? z) (and (fxfx< y z) (bnfx< x y))] + [(bignum? z) + (and (bnfx< x y) (bnfx< y z))] + [else (err z)])] + [(bignum? y) + (cond + [(fixnum? z) (and (bnfx< y z) (bnbn< x y))] + [(bignum? z) (and (bnbn< x y) (bnbn< y z))] + [else (err z)])] + [else (err y)])] + [else (err x)])] + [(x) (if (number? x) #t (err x))] + [(x y . ls) + (cond + [(fixnum? x) (fxloopt x y ls)] + [(bignum? x) (bnloopt x y ls)] + [else (err x)])]))])) + + (define-syntax false (syntax-rules () [(_ x y) #f])) + (define-syntax bnbncmp + (syntax-rules () + [(_ x y cmp) + (cmp (foreign-call "ikrt_bnbncomp" x y) 0)])) + (define-syntax bnbn= (syntax-rules () [(_ x y) (bnbncmp x y #%$fx=)])) + (define-syntax bnbn< (syntax-rules () [(_ x y) (bnbncmp x y #%$fx<)])) + (define-syntax bnbn> (syntax-rules () [(_ x y) (bnbncmp x y #%$fx>)])) + (define-syntax bnbn<= (syntax-rules () [(_ x y) (bnbncmp x y #%$fx<=)])) + (define-syntax bnbn>= (syntax-rules () [(_ x y) (bnbncmp x y #%$fx>=)])) + (define-syntax fxbn< (syntax-rules () [(_ x y) (positive-bignum? y)])) + (define-syntax bnfx< (syntax-rules () [(_ x y) (not (positive-bignum? x))])) + (define-syntax fxbn> (syntax-rules () [(_ x y) (not (positive-bignum? y))])) + (define-syntax bnfx> (syntax-rules () [(_ x y) (positive-bignum? x)])) + + + + (primitive-set! '+ +) + (primitive-set! '- -) + (primitive-set! '* *) + (primitive-set! '= (mk< = #%$fx= false false bnbn=)) + (primitive-set! '< (mk< < #%$fx< fxbn< bnfx< bnbn<)) + (primitive-set! '> (mk< > #%$fx> fxbn> bnfx> bnbn>)) + (primitive-set! '<= (mk< <= #%$fx<= fxbn< bnfx< bnbn<=)) + (primitive-set! '>= (mk< >= #%$fx>= fxbn> bnfx> bnbn>=)) + (primitive-set! 'logand logand) + (primitive-set! 'number? number?) + (primitive-set! 'number->string number->string) + + (primitive-set! 'add1 + (lambda (x) + (cond + [(fixnum? x) + (foreign-call "ikrt_fxfxplus" x 1)] + [(bignum? x) + (foreign-call "ikrt_fxbnplus" 1 x)] + [else (error 'add1 "~s is not a number" x)]))) + + (primitive-set! 'sub1 + (lambda (x) + (cond + [(fixnum? x) + (foreign-call "ikrt_fxfxplus" x -1)] + [(bignum? x) + (foreign-call "ikrt_fxbnplus" -1 x)] + [else (error 'sub1 "~s is not a number" x)]))) + + (primitive-set! 'zero? + (lambda (x) + (cond + [(fixnum? x) (eq? x 0)] + [(bignum? x) #f] + [else (error 'zero? "~s is not a number" x)]))) + + (primitive-set! 'expt + (lambda (n m) + (unless (number? n) + (error 'expt "~s is not a numebr" n)) + (cond + [(fixnum? m) + (if (#%$fx>= m 0) + (expt n m) + (error 'expt "power should be positive, got ~s" m))] + [(bignum? m) + (cond + [(eq? n 0) 0] + [(eq? n 1) 1] + [(eq? n -1) + (if (positive-bignum? m) + (if (even-bignum? m) + 1 + -1) + (error 'expt "power should be positive, got ~s" m))] + [else + (if (positive-bignum? m) + (error 'expt "(expt ~s ~s) is too big to compute" n m) + (error 'expt "power should be positive, got ~s" m))])] + [else (error 'expt "~s is not a number" m)]))) + + (primitive-set! 'positive? + (lambda (x) + (cond + [(fixnum? x) (#%$fx> x 0)] + [(bignum? x) (positive-bignum? x)] + [else (error 'positive? "~s is not a number" x)]))) + + (primitive-set! 'negative? + (lambda (x) + (cond + [(fixnum? x) (#%$fx< x 0)] + [(bignum? x) (not (positive-bignum? x))] + [else (error 'negative? "~s is not a number" x)]))) + ) diff --git a/src/librecord-6.0.ss b/src/librecord-6.0.ss deleted file mode 100644 index d3e3e71..0000000 --- a/src/librecord-6.0.ss +++ /dev/null @@ -1,228 +0,0 @@ - - - -(let () - (define record-type-rtd - (let ([rtd ($make-record #f 4)]) - ($record-set! rtd -1 rtd) - ($record-set! rtd 0 "record-type") - ($record-set! rtd 1 4) - ($record-set! rtd 2 '(name length fields printer)) - ($record-set! rtd 3 #f) - rtd)) - - (define rtd? - (lambda (x) - (and ($record? x) - (eq? ($record-rtd x) record-type-rtd)))) - - (define rtd-name - (lambda (rtd) - ($record-ref rtd 0))) - - (define rtd-length - (lambda (rtd) - ($record-ref rtd 1))) - - (define rtd-fields - (lambda (rtd) - ($record-ref rtd 2))) - - (define rtd-printer - (lambda (rtd) - ($record-ref rtd 3))) - - (define set-rtd-name! - (lambda (rtd name) - ($record-set! rtd 0 name))) - - (define set-rtd-length! - (lambda (rtd n) - ($record-set! rtd 1 n))) - - (define set-rtd-fields! - (lambda (rtd fields) - ($record-set! rtd 2 fields))) - - (define set-rtd-printer! - (lambda (rtd printer) - ($record-set! rtd 3 printer))) - - (define make-rtd - (lambda (name fields printer) - (let ([rtd ($make-record record-type-rtd 4)]) - ($record-set! rtd 0 name) - ($record-set! rtd 1 (length fields)) - ($record-set! rtd 2 fields) - ($record-set! rtd 3 printer) - rtd))) - - (define verify-field - (lambda (x) - (unless (symbol? x) - (error 'make-record-type "~s is not a valid field name" x)))) - - (define set-fields - (lambda (r f* i n) - (cond - [(null? f*) - (if ($fx= i n) - r - #f)] - [($fx< i n) - (if (null? f*) - #f - (begin - ($record-set! r i ($car f*)) - (set-fields r ($cdr f*) ($fxadd1 i) n)))] - [else #f]))) - - (define make-record-type - (lambda (name fields) - (unless (string? name) - (error 'make-record-type "name must be a string, got ~s" name)) - (unless (list? fields) - (error 'make-record-type "fields must be a list, got ~s" fields)) - (for-each verify-field fields) - (make-rtd name fields #f))) - - (define record-constructor - (lambda (rtd) - (unless (rtd? rtd) - (error 'record-constructor "~s is not an rtd")) - (lambda args - (let ([n (rtd-length rtd)]) - (let ([r ($make-record rtd n)]) - (or (set-fields r args 0 n) - (error 'record-constructor - "incorrect number of arguments to the constructor of ~s" - rtd))))))) - - (define record-predicate - (lambda (rtd) - (unless (rtd? rtd) - (error 'record-predicate "~s is not an rtd")) - (lambda (x) - (and ($record? x) - (eq? ($record-rtd x) rtd))))) - - (define field-index - (lambda (i rtd who) - (cond - [(fixnum? i) - (unless (and ($fx>= i 0) ($fx< i (rtd-length rtd))) - (error who "~s is out of range for rtd ~s" rtd)) - i] - [(symbol? i) - (letrec ([lookup - (lambda (n ls) - (cond - [(null? ls) - (error who "~s is not a field in ~s" rtd)] - [(eq? i ($car ls)) n] - [else (lookup ($fx+ n 1) ($cdr ls))]))]) - (lookup 0 (rtd-fields rtd)))] - [else (error who "~s is not a valid index" i)]))) - - (define record-field-accessor - (lambda (rtd i) - (unless (rtd? rtd) - (error 'record-field-accessor "~s is not an rtd" rtd)) - (let ([i (field-index i rtd 'record-field-accessor)]) - (lambda (x) - (unless (and ($record? x) - (eq? ($record-rtd x) rtd)) - (error 'record-field-accessor "~s is not of type ~s" x rtd)) - ($record-ref x i))))) - - (define record-field-mutator - (lambda (rtd i) - (unless (rtd? rtd) - (error 'record-field-mutator "~s is not an rtd" rtd)) - (let ([i (field-index i rtd 'record-field-mutator)]) - (lambda (x v) - (unless (and ($record? x) - (eq? ($record-rtd x) rtd)) - (error 'record-field-mutator "~s is not of type ~s" x rtd)) - ($record-set! x i v))))) - - (define record? - (lambda (x . rest) - (if (null? rest) - ($record? x) - (let ([rtd ($car rest)]) - (unless (null? ($cdr rest)) - (error 'record? "too many arguments")) - (unless (rtd? rtd) - (error 'record? "~s is not an rtd")) - (and ($record? x) - (eq? ($record-rtd x) rtd)))))) - - (define record-rtd - (lambda (x) - (if ($record? x) - ($record-rtd x) - (error 'record-rtd "~s is not a record" x)))) - - (define record-length - (lambda (x) - (if ($record? x) - (rtd-length ($record-rtd x)) - (error 'record-length "~s is not a record" x)))) - - (define record-name - (lambda (x) - (if ($record? x) - (rtd-name ($record-rtd x)) - (error 'record-name "~s is not a record" x)))) - - (define record-printer - (lambda (x) - (if ($record? x) - (rtd-printer ($record-rtd x)) - (error 'record-printer "~s is not a record" x)))) - - - - (define record-ref - (lambda (x i) - (unless ($record? x) (error 'record-ref "~s is not a record" x)) - (unless (fixnum? i) (error 'record-ref "~s is not a valid index" i)) - (let ([n (rtd-length ($record-rtd x))]) - (unless (and ($fx>= i 0) ($fx< i n)) - (error 'record-ref "index ~s is out of range for ~s" i x)) - ($record-ref x i)))) - - (define record-set! - (lambda (x i v) - (unless ($record? x) (error 'record-set! "~s is not a record" x)) - (unless (fixnum? i) (error 'record-set! "~s is not a valid index" i)) - (let ([n (rtd-length ($record-rtd x))]) - (unless (and ($fx>= i 0) ($fx< i n)) - (error 'record-set! "index ~s is out of range for ~s" i x)) - ($record-set! x i v)))) - - (primitive-set! 'make-record-type make-record-type) - (primitive-set! 'record-constructor record-constructor) - (primitive-set! 'record-predicate record-predicate) - (primitive-set! 'record-field-accessor record-field-accessor) - (primitive-set! 'record-field-mutator record-field-mutator) - - (primitive-set! 'record? record?) - (primitive-set! 'record-rtd record-rtd) - (primitive-set! 'record-name record-name) - (primitive-set! 'record-printer record-printer) - (primitive-set! 'record-length record-length) - (primitive-set! 'record-ref record-ref) - (primitive-set! 'record-set! record-set!) - - (set-rtd-printer! record-type-rtd - (lambda (x p) - (unless (rtd? x) - (error 'record-type-printer "not an rtd")) - (display "#<" p) - (display (rtd-name x) p) - (display " rtd>" p))) - - ) - diff --git a/src/librecord-6.1.ss b/src/librecord-6.1.ss deleted file mode 100644 index f843013..0000000 --- a/src/librecord-6.1.ss +++ /dev/null @@ -1,222 +0,0 @@ - - - -(let () - - (define rtd? - (lambda (x) - (and ($record? x) - (eq? ($record-rtd x) $base-rtd)))) - - (define rtd-name - (lambda (rtd) - ($record-ref rtd 0))) - - (define rtd-length - (lambda (rtd) - ($record-ref rtd 1))) - - (define rtd-fields - (lambda (rtd) - ($record-ref rtd 2))) - - (define rtd-printer - (lambda (rtd) - ($record-ref rtd 3))) - - (define set-rtd-name! - (lambda (rtd name) - ($record-set! rtd 0 name))) - - (define set-rtd-length! - (lambda (rtd n) - ($record-set! rtd 1 n))) - - (define set-rtd-fields! - (lambda (rtd fields) - ($record-set! rtd 2 fields))) - - (define set-rtd-printer! - (lambda (rtd printer) - ($record-set! rtd 3 printer))) - - (define make-rtd - (lambda (name fields printer) - (let ([rtd ($make-record $base-rtd 4)]) - ($record-set! rtd 0 name) - ($record-set! rtd 1 (length fields)) - ($record-set! rtd 2 fields) - ($record-set! rtd 3 printer) - rtd))) - - (define verify-field - (lambda (x) - (unless (symbol? x) - (error 'make-record-type "~s is not a valid field name" x)))) - - (define set-fields - (lambda (r f* i n) - (cond - [(null? f*) - (if ($fx= i n) - r - #f)] - [($fx< i n) - (if (null? f*) - #f - (begin - ($record-set! r i ($car f*)) - (set-fields r ($cdr f*) ($fxadd1 i) n)))] - [else #f]))) - - (define make-record-type - (lambda (name fields) - (unless (string? name) - (error 'make-record-type "name must be a string, got ~s" name)) - (unless (list? fields) - (error 'make-record-type "fields must be a list, got ~s" fields)) - (for-each verify-field fields) - (make-rtd name fields #f))) - - (define record-constructor - (lambda (rtd) - (unless (rtd? rtd) - (error 'record-constructor "~s is not an rtd")) - (lambda args - (let ([n (rtd-length rtd)]) - (let ([r ($make-record rtd n)]) - (or (set-fields r args 0 n) - (error 'record-constructor - "incorrect number of arguments to the constructor of ~s" - rtd))))))) - - (define record-predicate - (lambda (rtd) - (unless (rtd? rtd) - (error 'record-predicate "~s is not an rtd")) - (lambda (x) - (and ($record? x) - (eq? ($record-rtd x) rtd))))) - - (define field-index - (lambda (i rtd who) - (cond - [(fixnum? i) - (unless (and ($fx>= i 0) ($fx< i (rtd-length rtd))) - (error who "~s is out of range for rtd ~s" rtd)) - i] - [(symbol? i) - (letrec ([lookup - (lambda (n ls) - (cond - [(null? ls) - (error who "~s is not a field in ~s" rtd)] - [(eq? i ($car ls)) n] - [else (lookup ($fx+ n 1) ($cdr ls))]))]) - (lookup 0 (rtd-fields rtd)))] - [else (error who "~s is not a valid index" i)]))) - - (define record-field-accessor - (lambda (rtd i) - (unless (rtd? rtd) - (error 'record-field-accessor "~s is not an rtd" rtd)) - (let ([i (field-index i rtd 'record-field-accessor)]) - (lambda (x) - (unless (and ($record? x) - (eq? ($record-rtd x) rtd)) - (error 'record-field-accessor "~s is not of type ~s" x rtd)) - ($record-ref x i))))) - - (define record-field-mutator - (lambda (rtd i) - (unless (rtd? rtd) - (error 'record-field-mutator "~s is not an rtd" rtd)) - (let ([i (field-index i rtd 'record-field-mutator)]) - (lambda (x v) - (unless (and ($record? x) - (eq? ($record-rtd x) rtd)) - (error 'record-field-mutator "~s is not of type ~s" x rtd)) - ($record-set! x i v))))) - - (define record? - (lambda (x . rest) - (if (null? rest) - ($record? x) - (let ([rtd ($car rest)]) - (unless (null? ($cdr rest)) - (error 'record? "too many arguments")) - (unless (rtd? rtd) - (error 'record? "~s is not an rtd")) - (and ($record? x) - (eq? ($record-rtd x) rtd)))))) - - (define record-rtd - (lambda (x) - (if ($record? x) - ($record-rtd x) - (error 'record-rtd "~s is not a record" x)))) - - (define record-length - (lambda (x) - (if ($record? x) - (rtd-length ($record-rtd x)) - (error 'record-length "~s is not a record" x)))) - - (define record-name - (lambda (x) - (if ($record? x) - (rtd-name ($record-rtd x)) - (error 'record-name "~s is not a record" x)))) - - (define record-printer - (lambda (x) - (if ($record? x) - (rtd-printer ($record-rtd x)) - (error 'record-printer "~s is not a record" x)))) - - - - (define record-ref - (lambda (x i) - (unless ($record? x) (error 'record-ref "~s is not a record" x)) - (unless (fixnum? i) (error 'record-ref "~s is not a valid index" i)) - (let ([n (rtd-length ($record-rtd x))]) - (unless (and ($fx>= i 0) ($fx< i n)) - (error 'record-ref "index ~s is out of range for ~s" i x)) - ($record-ref x i)))) - - (define record-set! - (lambda (x i v) - (unless ($record? x) (error 'record-set! "~s is not a record" x)) - (unless (fixnum? i) (error 'record-set! "~s is not a valid index" i)) - (let ([n (rtd-length ($record-rtd x))]) - (unless (and ($fx>= i 0) ($fx< i n)) - (error 'record-set! "index ~s is out of range for ~s" i x)) - ($record-set! x i v)))) - - (primitive-set! 'make-record-type make-record-type) - (primitive-set! 'record-constructor record-constructor) - (primitive-set! 'record-predicate record-predicate) - (primitive-set! 'record-field-accessor record-field-accessor) - (primitive-set! 'record-field-mutator record-field-mutator) - - (primitive-set! 'record? record?) - (primitive-set! 'record-rtd record-rtd) - (primitive-set! 'record-name record-name) - (primitive-set! 'record-printer record-printer) - (primitive-set! 'record-length record-length) - (primitive-set! 'record-ref record-ref) - (primitive-set! 'record-set! record-set!) - - (set-rtd-fields! $base-rtd '(name fields length printer)) - (set-rtd-name! $base-rtd "base-rtd") - (set-rtd-printer! $base-rtd - (lambda (x p) - (unless (rtd? x) - (error 'record-type-printer "not an rtd")) - (display "#<" p) - (display (rtd-name x) p) - (display " rtd>" p))) - - ) - diff --git a/src/librecord.fasl b/src/librecord.fasl index e69de29..d5bb189 100644 Binary files a/src/librecord.fasl and b/src/librecord.fasl differ diff --git a/src/libtokenizer-6.1.ss b/src/libtokenizer-6.1.ss index 57aaeac..dfb66e8 100644 --- a/src/libtokenizer-6.1.ss +++ b/src/libtokenizer-6.1.ss @@ -359,7 +359,7 @@ (read-char p) '(macro . unquote-splicing)] [else '(macro . unquote)]))] - [($char= #\# c) (tokenize-hash p)] + [($char= #\# c) (tokenize-hash p)] [(digit? c) (cons 'datum (tokenize-number (char->num c) p))] [(initial? c) diff --git a/src/libtokenizer-6.0.ss b/src/libtokenizer-9.0.ss similarity index 59% rename from src/libtokenizer-6.0.ss rename to src/libtokenizer-9.0.ss index 3eaa65c..b4da506 100644 --- a/src/libtokenizer-6.0.ss +++ b/src/libtokenizer-9.0.ss @@ -1,7 +1,7 @@ (let () (define char-whitespace? (lambda (c) - (or (char= #\space c) + (or ($char= #\space c) (memq ($char->fixnum c) '(9 10 11 12 13))))) (define delimiter? (lambda (c) @@ -9,7 +9,7 @@ (memq c '(#\( #\) #\[ #\] #\' #\` #\, #\"))))) (define digit? (lambda (c) - (and (char<= #\0 c) (char<= c #\9)))) + (and ($char<= #\0 c) ($char<= c #\9)))) (define char->num (lambda (c) (fx- ($char->fixnum c) ($char->fixnum #\0)))) @@ -18,15 +18,15 @@ (or (letter? c) (special-initial? c)))) (define letter? (lambda (c) - (or (and (char<= #\a c) (char<= c #\z)) - (and (char<= #\A c) (char<= c #\Z))))) + (or (and ($char<= #\a c) ($char<= c #\z)) + (and ($char<= #\A c) ($char<= c #\Z))))) (define af? (lambda (c) - (or (and (char<= #\a c) (char<= c #\f)) - (and (char<= #\A c) (char<= c #\F))))) + (or (and ($char<= #\a c) ($char<= c #\f)) + (and ($char<= #\A c) ($char<= c #\F))))) (define af->num (lambda (c) - (if (and (char<= #\a c) (char<= c #\f)) + (if (and ($char<= #\a c) ($char<= c #\f)) (fx+ 10 (fx- ($char->fixnum c) ($char->fixnum #\a))) (fx+ 10 (fx- ($char->fixnum c) ($char->fixnum #\A)))))) (define special-initial? @@ -77,9 +77,9 @@ (cons 'datum (tokenize-hex (char->num c) p))] [(af? c) (cons 'datum (tokenize-hex (af->num c) p))] - [(char= c #\-) + [($char= c #\-) (cons 'datum (fx- 0 (tokenize-hex 0 p)))] - [(char= c #\+) + [($char= c #\+) (cons 'datum (tokenize-hex 0 p))] [else (unread-char c p) @@ -104,14 +104,14 @@ (cond [(eof-object? c) (error 'tokenize "end-of-file while inside a string")] - [(char= #\" c) ls] - [(char= #\\ c) + [($char= #\" c) ls] + [($char= #\\ c) (let ([c (read-char p)]) (cond - [(char= #\" c) (tokenize-string (cons #\" ls) p)] - [(char= #\\ c) (tokenize-string (cons #\\ ls) p)] - [(char= #\n c) (tokenize-string (cons #\newline ls) p)] - [(char= #\t c) (tokenize-string (cons #\tab ls) p)] + [($char= #\" c) (tokenize-string (cons #\" ls) p)] + [($char= #\\ c) (tokenize-string (cons #\\ ls) p)] + [($char= #\n c) (tokenize-string (cons #\newline ls) p)] + [($char= #\t c) (tokenize-string (cons #\tab ls) p)] [else (error 'tokenize "invalid string escape \\~a" c)]))] [else (tokenize-string (cons c ls) p)])))) @@ -148,13 +148,13 @@ (cond [(eof-object? c) 'dot] [(delimiter? c) 'dot] - [(char= c #\.) ; this is second dot + [($char= c #\.) ; this is second dot (read-char p) (let ([c (read-char p)]) (cond [(eof-object? c) (error 'tokenize "invalid syntax .. near end of file")] - [(char= c #\.) ; this is the third + [($char= c #\.) ; this is the third (let ([c (peek-char p)]) (cond [(eof-object? c) '(datum . ...)] @@ -180,7 +180,7 @@ (cond [(eof-object? c) (error 'tokenize "invalid eof in the middle of #\\~a" str)] - [(char= c (string-ref str i)) + [($char= c (string-ref str i)) (tokenize-char* (fxadd1 i) str p d)] [else (error 'tokenize @@ -191,7 +191,7 @@ (cond [(eof-object? c) (cons 'datum (string-ref str 0))] [(delimiter? c) (cons 'datum (string-ref str 0))] - [(char= (string-ref str 1) c) + [($char= (string-ref str 1) c) (read-char p) (tokenize-char* 2 str p d)] [else (error 'tokenize "invalid syntax near #\\~a~a" @@ -202,13 +202,13 @@ (cond [(eof-object? c) (error 'tokenize "invalid #\\ near end of file")] - [(char= #\s c) + [($char= #\s c) (tokenize-char-seq p "space" '(datum . #\space))] - [(char= #\n c) + [($char= #\n c) (tokenize-char-seq p "newline" '(datum . #\newline))] - [(char= #\t c) + [($char= #\t c) (tokenize-char-seq p "tab" '(datum . #\tab))] - [(char= #\r c) + [($char= #\r c) (tokenize-char-seq p "return" '(datum . #\return))] [else (let ([n (peek-char p)]) @@ -226,17 +226,17 @@ (let ([c (read-char p)]) (cond [(eof-object? c) (multiline-error)] - [(char= #\| c) + [($char= #\| c) (let ([c (read-char p)]) (cond [(eof-object? c) (multiline-error)] - [(char= #\# c) (void)] + [($char= #\# c) (void)] [else (multiline-comment p)]))] - [(char= #\# c) + [($char= #\# c) (let ([c (read-char p)]) (cond [(eof-object? c) (multiline-error)] - [(char= #\| c) + [($char= #\| c) (multiline-comment p) (multiline-comment p)] [else @@ -247,8 +247,8 @@ (let ([c (read-char p)]) (cond [(eof-object? c) ac] - [(char= #\0 c) (read-binary (fxsll ac 1) (cons c chars) p)] - [(char= #\1 c) (read-binary (fx+ (fxsll ac 1) 1) (cons c chars) p)] + [($char= #\0 c) (read-binary (fxsll ac 1) (cons c chars) p)] + [($char= #\1 c) (read-binary (fx+ (fxsll ac 1) 1) (cons c chars) p)] [(delimiter? c) (unread-char c p) ac] [else (unread-char c) @@ -259,85 +259,99 @@ (let ([c (read-char p)]) (cond [(eof-object? c) (error 'tokenize "invalid # near end of file")] - [(char= c #\t) + [($char= c #\t) (let ([c (peek-char p)]) (cond [(eof-object? c) '(datum . #t)] [(delimiter? c) '(datum . #t)] [else (error 'tokenize "invalid syntax near #t")]))] - [(char= c #\f) + [($char= c #\f) (let ([c (peek-char p)]) (cond [(eof-object? c) '(datum . #f)] [(delimiter? c) '(datum . #f)] [else (error 'tokenize "invalid syntax near #f")]))] - [(char= #\\ c) (tokenize-char p)] - [(char= #\( c) 'vparen] - [(char= #\x c) (tokenize-hex-init p)] - [(char= #\' c) '(macro . syntax)] - [(char= #\; c) 'hash-semi] - [(char= #\% c) '(macro . |#primitive|)] - [(char= #\| c) (multiline-comment p) (tokenize p)] - [(char= #\b c) + [($char= #\\ c) (tokenize-char p)] + [($char= #\( c) 'vparen] + [($char= #\x c) (tokenize-hex-init p)] + [($char= #\' c) '(macro . syntax)] + [($char= #\; c) 'hash-semi] + [($char= #\% c) '(macro . |#primitive|)] + [($char= #\| c) (multiline-comment p) (tokenize p)] + [($char= #\b c) (let ([c (read-char p)]) (cond [(eof-object? c) (error 'tokenize "invalid eof while reading #b")] - [(char= #\- c) + [($char= #\- c) (let ([c (read-char p)]) (cond [(eof-object? c) (error 'tokenize "invalid eof while reading #b-")] - [(char= #\0 c) + [($char= #\0 c) (cons 'datum (fx- 0 (read-binary 0 '(#\0 #\-) p)))] - [(char= #\1 c) + [($char= #\1 c) (cons 'datum (fx- 0 (read-binary 1 '(#\1 #\-) p)))] [else (unread-char c p) (error 'tokenize "invalid binary syntax #b-~a" c)]))] - [(char= #\0 c) + [($char= #\0 c) (cons 'datum (read-binary 0 '(#\0) p))] - [(char= #\1 c) + [($char= #\1 c) (cons 'datum (read-binary 1 '(#\1) p))] [else (unread-char c p) (error 'tokenize "invalid syntax #b~a" c)] ))] - [(char= #\! c) + [($char= #\! c) (let ([e (read-char p)]) (when (eof-object? e) (error 'tokenize "invalid eof near #!")) - (unless (char= #\e e) + (unless ($char= #\e e) (error 'tokenize "invalid syntax near #!~a" e)) (let ([o (read-char p)]) (when (eof-object? o) (error 'tokenize "invalid eof near #!e")) - (unless (char= #\o o) + (unless ($char= #\o o) (error 'tokenize "invalid syntax near #!e~a" o)) (let ([f (read-char p)]) (when (eof-object? f) (error 'tokenize "invalid syntax near #!eo")) - (unless (char= #\f f) + (unless ($char= #\f f) (error 'tokenize "invalid syntax near #!eo~a" f)) (cons 'datum (eof-object)))))] + [(digit? c) + (tokenize-hashnum p (char->num c))] [else (unread-char c p) (error 'tokenize "invalid syntax #~a" c)])))) + (define (tokenize-hashnum p n) + (let ([c (read-char p)]) + (cond + [(eof-object? c) + (error 'tokenize "invalid eof inside #n mark/ref")] + [($char= #\= c) (cons 'mark n)] + [($char= #\# c) (cons 'ref n)] + [(digit? c) + (tokenize-hashnum p (fx+ (fx* n 10) (char->num c)))] + [else + (unread-char c p) + (error 'tokenize "invalid char ~a while inside a #n mark/ref" c)]))) (define tokenize-bar (lambda (p ac) (let ([c (read-char p)]) (cond [(eof-object? c) (error 'tokenize "unexpected eof while reading symbol")] - [(char= #\\ c) + [($char= #\\ c) (let ([c (read-char p)]) (cond [(eof-object? c) (error 'tokenize "unexpected eof while reading symbol")] [else (tokenize-bar p (cons c ac))]))] - [(char= #\| c) ac] + [($char= #\| c) ac] [else (tokenize-bar p (cons c ac))])))) (define tokenize (lambda (p) @@ -345,39 +359,39 @@ (cond [(eof-object? c) (eof-object)] [(char-whitespace? c) (tokenize p)] - [(char= #\( c) 'lparen] - [(char= #\) c) 'rparen] - [(char= #\[ c) 'lbrack] - [(char= #\] c) 'rbrack] - [(char= #\' c) '(macro . quote)] - [(char= #\` c) '(macro . quasiquote)] - [(char= #\, c) + [($char= #\( c) 'lparen] + [($char= #\) c) 'rparen] + [($char= #\[ c) 'lbrack] + [($char= #\] c) 'rbrack] + [($char= #\' c) '(macro . quote)] + [($char= #\` c) '(macro . quasiquote)] + [($char= #\, c) (let ([c (peek-char p)]) (cond [(eof-object? c) '(macro . unquote)] - [(char= c #\@) + [($char= c #\@) (read-char p) '(macro . unquote-splicing)] [else '(macro . unquote)]))] - [(char= #\# c) (tokenize-hash p)] + [($char= #\# c) (tokenize-hash p)] [(digit? c) (cons 'datum (tokenize-number (char->num c) p))] [(initial? c) (let ([ls (reverse (tokenize-identifier (cons c '()) p))]) (cons 'datum (string->symbol (list->string ls))))] - [(char= #\" c) + [($char= #\" c) (let ([ls (tokenize-string '() p)]) (cons 'datum (list->string (reverse ls))))] - [(char= #\; c) + [($char= #\; c) (skip-comment p) (tokenize p)] - [(char= #\+ c) + [($char= #\+ c) (tokenize-plus p)] - [(char= #\- c) + [($char= #\- c) (tokenize-minus p)] - [(char= #\. c) + [($char= #\. c) (tokenize-dot p)] - [(char= #\| c) + [($char= #\| c) (let ([ls (reverse (tokenize-bar p '()))]) (cons 'datum (string->symbol (list->string ls))))] [else @@ -388,122 +402,212 @@ ;;;--------------------------------------------------------------* READ *--- ;;; (define read-list-rest - (lambda (p end mis) + (lambda (p locs k end mis) (let ([t (read-token p)]) (cond [(eof-object? t) (error 'read "end of file encountered while reading list")] - [(eq? t end) '()] + [(eq? t end) (values '() locs k)] [(eq? t mis) (error 'read "paren mismatch")] [(eq? t 'dot) - (let ([d (read p)]) + (let-values ([(d locs k) (read-expr p locs k)]) (let ([t (read-token p)]) (cond - [(eq? t end) d] - [(eq? t mis) + [(eq? t end) (values d locs k)] + [(eq? t mis) (error 'read "paren mismatch")] [(eq? t 'dot) (error 'read "cannot have two dots in a list")] [else (error 'read "expecting ~a, got ~a" end t)])))] [(eq? t 'hash-semi) - (read p) - (read-list-rest p end mis)] + (let-values ([(ignored locs k) (read-expr p locs k)]) + (read-list-rest p locs k end mis))] [else - (let ([a (parse-token p t)]) - (let ([d (read-list-rest p end mis)]) - (cons a d)))])))) + (let-values ([(a locs k) (parse-token p locs k t)]) + (let-values ([(d locs k) (read-list-rest p locs k end mis)]) + (let ([x (cons a d)]) + (values x locs + (if (or (loc? a) (loc? d)) + (extend-k-pair x k) + k)))))])))) (define read-list-init - (lambda (p end mis) + (lambda (p locs k end mis) (let ([t (read-token p)]) (cond [(eof-object? t) (error 'read "end of file encountered while reading list")] - [(eq? t end) '()] + [(eq? t end) (values '() locs k)] [(eq? t mis) (error 'read "paren mismatch")] [(eq? t 'dot) (error 'read "invalid dot while reading list")] [(eq? t 'hash-semi) - (read p) - (read-list-init p end mis)] + (let-values ([(ignored locs k) (read-expr p locs k)]) + (read-list-init p locs k end mis))] [else - (let ([a (parse-token p t)]) - (cons a (read-list-rest p end mis)))])))) - (define vector-put! - (lambda (v i ls) + (let-values ([(a locs k) (parse-token p locs k t)]) + (let-values ([(d locs k) (read-list-rest p locs k end mis)]) + (let ([x (cons a d)]) + (values x locs + (if (or (loc? a) (loc? d)) + (extend-k-pair x k) + k)))))])))) + (define extend-k-pair + (lambda (x k) + (lambda () + (let ([a (car x)]) + (when (loc? a) + (set-car! x (loc-value a)))) + (let ([d (cdr x)]) + (when (loc? d) + (set-cdr! x (loc-value d)))) + (k)))) + (define vector-put + (lambda (v k i ls) (cond - [(null? ls) v] + [(null? ls) k] [else - (vector-set! v i (car ls)) - (vector-put! v (fxsub1 i) (cdr ls))]))) + (let ([a (car ls)]) + (vector-set! v i a) + (vector-put v + (if (loc? a) + (lambda () + (vector-set! v i (loc-value (vector-ref v i))) + (k)) + k) + (fxsub1 i) (cdr ls)))]))) (define read-vector - (lambda (p count ls) + (lambda (p locs k count ls) (let ([t (read-token p)]) (cond - [(eof-object? t) - (error 'read "end of file encountered while reading a vector")] - [(eq? t 'rparen) - (let ([v (make-vector count)]) - (vector-put! v (fxsub1 count) ls))] - [(eq? t 'rbrack) - (error 'read "unexpected ] while reading a vector")] - [(eq? t 'dot) - (error 'read "unexpected . while reading a vector")] - [(eq? t 'hash-semi) - (read p) - (read-vector p count ls)] - [else - (let ([a (parse-token p t)]) - (read-vector p (fxadd1 count) (cons a ls)))])))) + [(eof-object? t) + (error 'read "end of file encountered while reading a vector")] + [(eq? t 'rparen) + (let ([v (make-vector count)]) + (let ([k (vector-put v k (fxsub1 count) ls)]) + (values v locs k)))] + [(eq? t 'rbrack) + (error 'read "unexpected ] while reading a vector")] + [(eq? t 'dot) + (error 'read "unexpected . while reading a vector")] + [(eq? t 'hash-semi) + (let-values ([(ignored locs k) (read-expr p locs k)]) + (read-vector p locs k count ls))] + [else + (let-values ([(a locs k) (parse-token p locs k t)]) + (read-vector p locs k (fxadd1 count) (cons a ls)))])))) + (define-record loc (value set?)) (define parse-token - (lambda (p t) + (lambda (p locs k t) (cond - [(eof-object? t) (eof-object)] - [(eq? t 'lparen) (read-list-init p 'rparen 'rbrack)] - [(eq? t 'lbrack) (read-list-init p 'rbrack 'rparen)] - [(eq? t 'vparen) (read-vector p 0 '())] - [(eq? t 'hash-semi) - (read p) ; ignored expression - (read p)] + [(eof-object? t) (values (eof-object) locs k)] + [(eq? t 'lparen) (read-list-init p locs k 'rparen 'rbrack)] + [(eq? t 'lbrack) (read-list-init p locs k 'rbrack 'rparen)] + [(eq? t 'vparen) (read-vector p locs k 0 '())] + [(eq? t 'hash-semi) + (let-values ([(ignored locs k) (read-expr p locs k)]) + (read-expr p locs k))] [(pair? t) (cond - [(eq? (car t) 'datum) (cdr t)] + [(eq? (car t) 'datum) (values (cdr t) locs k)] [(eq? (car t) 'macro) - (cons (cdr t) (cons (read p) '()))] + (let-values ([(expr locs k) (read-expr p locs k)]) + (let ([x (list expr)]) + (values (cons (cdr t) x) locs + (if (loc? expr) + (lambda () + (set-car! x (loc-value expr)) + (k)) + k))))] + [(eq? (car t) 'mark) + (let ([n (cdr t)]) + (let-values ([(expr locs k) (read-expr p locs k)]) + (cond + [(assq n locs) => + (lambda (x) + (let ([loc (cdr x)]) + (when (loc-set? loc) + (error 'read "duplicate mark ~s" n)) + (set-loc-value! loc expr) + (set-loc-set?! loc #t) + (values expr locs k)))] + [else + (let ([loc (make-loc expr #t)]) + (let ([locs (cons (cons n loc) locs)]) + (values expr locs k)))])))] + [(eq? (car t) 'ref) + (let ([n (cdr t)]) + (cond + [(assq n locs) => + (lambda (x) + (values (cdr x) locs k))] + [else + (let ([loc (make-loc #f #f)]) + (let ([locs (cons (cons n loc) locs)]) + (values loc locs k)))]))] [else (error 'read "invalid token! ~s" t)])] [else (error 'read "unexpected ~s found" t)]))) - (define read - (lambda (p) (parse-token p (read-token p)))) + (define read-expr + (lambda (p locs k) + (parse-token p locs k (read-token p)))) + (define reduce-loc! + (lambda (x) + (let ([loc (cdr x)]) + (unless (loc-set? loc) + (error 'read "referenced mark ~s not set" (car x))) + (when (loc? (loc-value loc)) + (let f ([h loc] [t loc]) + (if (loc? h) + (let ([h1 (loc-value h)]) + (if (loc? h1) + (begin + (when (eq? h1 t) + (error 'read "circular marks")) + (let ([v (f (loc-value h1) (loc-value t))]) + (set-loc-value! h1 v) + (set-loc-value! h v) + v)) + (begin + (set-loc-value! h h1) + h1))) + h)))))) + + (define read + (lambda (p) + (let-values ([(expr locs k) (read-expr p '() void)]) + (cond + [(null? locs) expr] + [else + (for-each reduce-loc! locs) + (k) + (if (loc? expr) + (loc-value expr) + expr)])))) + + + + ;;; ;;;--------------------------------------------------------------* INIT *--- ;;; (primitive-set! 'read-token - (lambda p - (if (null? p) - (tokenize (current-input-port)) - (if (null? (cdr p)) - (let ([a (car p)]) - (if (input-port? a) - (tokenize a) - (error 'read-token - "not an input port: ~s ~s ~s" - (vector? a) (vector-length a) a))) - (error 'read-token "too many arguments"))))) + (case-lambda + [() (tokenize (current-input-port))] + [(p) + (if (input-port? p) + (tokenize p) + (error 'read-token "~s is not an input port" p))])) (primitive-set! 'read - (lambda p - (if (null? p) - (read (current-input-port)) - (if (null? (cdr p)) - (let ([a (car p)]) - (if (input-port? a) - (read a) - (error 'read "not an input port: ~s" a))) - (error 'read "too many arguments"))))) - + (case-lambda + [() (read (current-input-port))] + [(p) + (if (input-port? p) + (read p) + (error 'read "~s is not an input port" p))])) (let () (define read-and-eval (lambda (p) diff --git a/src/libtokenizer-9.1.ss b/src/libtokenizer-9.1.ss new file mode 100644 index 0000000..b578587 --- /dev/null +++ b/src/libtokenizer-9.1.ss @@ -0,0 +1,630 @@ + +;;; 9.1: bignum reader +;;; 9.0: graph marks/refs +;;; +(let () + (define char-whitespace? + (lambda (c) + (or ($char= #\space c) + (memq ($char->fixnum c) '(9 10 11 12 13))))) + (define delimiter? + (lambda (c) + (or (char-whitespace? c) + (memq c '(#\( #\) #\[ #\] #\' #\` #\, #\"))))) + (define digit? + (lambda (c) + (and ($char<= #\0 c) ($char<= c #\9)))) + (define char->num + (lambda (c) + (fx- ($char->fixnum c) ($char->fixnum #\0)))) + (define initial? + (lambda (c) + (or (letter? c) (special-initial? c)))) + (define letter? + (lambda (c) + (or (and ($char<= #\a c) ($char<= c #\z)) + (and ($char<= #\A c) ($char<= c #\Z))))) + (define af? + (lambda (c) + (or (and ($char<= #\a c) ($char<= c #\f)) + (and ($char<= #\A c) ($char<= c #\F))))) + (define af->num + (lambda (c) + (if (and ($char<= #\a c) ($char<= c #\f)) + (fx+ 10 (fx- ($char->fixnum c) ($char->fixnum #\a))) + (fx+ 10 (fx- ($char->fixnum c) ($char->fixnum #\A)))))) + (define special-initial? + (lambda (c) + (memq c '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\^ #\_ #\~)))) + (define subsequent? + (lambda (c) + (or (initial? c) (digit? c) (special-subsequent? c)))) + (define special-subsequent? + (lambda (c) + (memq c '(#\+ #\- #\. #\@)))) + (define tokenize-number + (lambda (n p) + (let ([c (read-char p)]) + (cond + [(eof-object? c) n] + [(digit? c) + (tokenize-number (+ (* n 10) (char->num c)) p)] + [(delimiter? c) + (unread-char c p) + n] + [else + (unread-char c p) + (error 'tokenize "invalid number syntax: ~a~a" n c)])))) + (define tokenize-hex + (lambda (n p) + (let ([c (read-char p)]) + (cond + [(eof-object? c) n] + [(digit? c) + (tokenize-hex (+ (* n 16) (char->num c)) p)] + [(af? c) + (tokenize-hex (+ (* n 16) (af->num c)) p)] + [(delimiter? c) + (unread-char c p) + n] + [else + (unread-char c p) + (error 'tokenize "invalid hex number sequence: ~a~a" n c)])))) + (define tokenize-hex-init + (lambda (p) + (let ([c (read-char p)]) + (cond + [(eof-object? c) + (unread-char c p) + (error 'tokenize "invalid #x near end of file")] + [(digit? c) + (cons 'datum (tokenize-hex (char->num c) p))] + [(af? c) + (cons 'datum (tokenize-hex (af->num c) p))] + [($char= c #\-) + (cons 'datum (* -1 (tokenize-hex 0 p)))] + [($char= c #\+) + (cons 'datum (tokenize-hex 0 p))] + [else + (unread-char c p) + (error 'tokenize "invalid number syntax: #x~a" c)])))) + (define tokenize-identifier + (lambda (ls p) + (let ([c (read-char p)]) + (cond + [(eof-object? c) ls] + [(subsequent? c) + (tokenize-identifier (cons c ls) p)] + [(delimiter? c) + (unread-char c p) + ls] + [else + (unread-char c p) + (error 'tokenize "invalid identifier syntax: ~a" + (list->string (reverse (cons c ls))))])))) + (define tokenize-string + (lambda (ls p) + (let ([c (read-char p)]) + (cond + [(eof-object? c) + (error 'tokenize "end-of-file while inside a string")] + [($char= #\" c) ls] + [($char= #\\ c) + (let ([c (read-char p)]) + (cond + [($char= #\" c) (tokenize-string (cons #\" ls) p)] + [($char= #\\ c) (tokenize-string (cons #\\ ls) p)] + [($char= #\n c) (tokenize-string (cons #\newline ls) p)] + [($char= #\t c) (tokenize-string (cons #\tab ls) p)] + [else (error 'tokenize "invalid string escape \\~a" c)]))] + [else + (tokenize-string (cons c ls) p)])))) + (define skip-comment + (lambda (p) + (let ([c (read-char p)]) + (unless (eof-object? c) + (let ([i ($char->fixnum c)]) + (unless (or (fx= i 10) (fx= i 13)) + (skip-comment p))))))) + (define tokenize-plus + (lambda (p) + (let ([c (peek-char p)]) + (cond + [(eof-object? c) '(datum . +)] + [(delimiter? c) '(datum . +)] + [(digit? c) + (read-char p) + (cons 'datum (tokenize-number (char->num c) p))] + [else (error 'tokenize "invalid sequence +~a" c)])))) + (define tokenize-minus + (lambda (p) + (let ([c (peek-char p)]) + (cond + [(eof-object? c) '(datum . -)] + [(delimiter? c) '(datum . -)] + [(digit? c) + (read-char p) + (cons 'datum (* -1 (tokenize-number (char->num c) p)))] + [else (error 'tokenize "invalid sequence -~a" c)])))) + (define tokenize-dot + (lambda (p) + (let ([c (peek-char p)]) + (cond + [(eof-object? c) 'dot] + [(delimiter? c) 'dot] + [($char= c #\.) ; this is second dot + (read-char p) + (let ([c (read-char p)]) + (cond + [(eof-object? c) + (error 'tokenize "invalid syntax .. near end of file")] + [($char= c #\.) ; this is the third + (let ([c (peek-char p)]) + (cond + [(eof-object? c) '(datum . ...)] + [(delimiter? c) '(datum . ...)] + [else + (error 'tokenize "invalid syntax ...~a" c)]))] + [else + (unread-char c) + (error 'tokenize "invalid syntax ..~a" c)]))] + [else + (error 'tokenize "invalid syntax .~a" c)])))) + (define tokenize-char* + (lambda (i str p d) + (cond + [(fx= i (string-length str)) + (let ([c (peek-char p)]) + (cond + [(eof-object? c) d] + [(delimiter? c) d] + [else (error 'tokenize "invalid character after #\\~a" str)]))] + [else + (let ([c (read-char p)]) + (cond + [(eof-object? c) + (error 'tokenize "invalid eof in the middle of #\\~a" str)] + [($char= c (string-ref str i)) + (tokenize-char* (fxadd1 i) str p d)] + [else + (error 'tokenize + "invalid char ~a while scanning #\\~a" c str)]))]))) + (define tokenize-char-seq + (lambda (p str d) + (let ([c (peek-char p)]) + (cond + [(eof-object? c) (cons 'datum (string-ref str 0))] + [(delimiter? c) (cons 'datum (string-ref str 0))] + [($char= (string-ref str 1) c) + (read-char p) + (tokenize-char* 2 str p d)] + [else (error 'tokenize "invalid syntax near #\\~a~a" + (string-ref str 0) c)])))) + (define tokenize-char + (lambda (p) + (let ([c (read-char p)]) + (cond + [(eof-object? c) + (error 'tokenize "invalid #\\ near end of file")] + [($char= #\s c) + (tokenize-char-seq p "space" '(datum . #\space))] + [($char= #\n c) + (tokenize-char-seq p "newline" '(datum . #\newline))] + [($char= #\t c) + (tokenize-char-seq p "tab" '(datum . #\tab))] + [($char= #\r c) + (tokenize-char-seq p "return" '(datum . #\return))] + [else + (let ([n (peek-char p)]) + (cond + [(eof-object? n) (cons 'datum c)] + [(delimiter? n) (cons 'datum c)] + [else + (error 'tokenize "invalid syntax #\\~a~a" c n)]))])))) + (define multiline-error + (lambda () + (error 'tokenize + "end of file encountered while inside a #|-style comment"))) + (define multiline-comment + (lambda (p) + (let ([c (read-char p)]) + (cond + [(eof-object? c) (multiline-error)] + [($char= #\| c) + (let ([c (read-char p)]) + (cond + [(eof-object? c) (multiline-error)] + [($char= #\# c) (void)] + [else (multiline-comment p)]))] + [($char= #\# c) + (let ([c (read-char p)]) + (cond + [(eof-object? c) (multiline-error)] + [($char= #\| c) + (multiline-comment p) + (multiline-comment p)] + [else + (multiline-comment p)]))] + [else (multiline-comment p)])))) + (define read-binary + (lambda (ac chars p) + (let ([c (read-char p)]) + (cond + [(eof-object? c) ac] + [($char= #\0 c) (read-binary (* ac 2) (cons c chars) p)] + [($char= #\1 c) (read-binary (+ (* ac 2) 1) (cons c chars) p)] + [(delimiter? c) (unread-char c p) ac] + [else + (unread-char c) + (error 'tokenize "invalid syntax #b~a" + (list->string (reverse (cons c chars))))])))) + (define tokenize-hash + (lambda (p) + (let ([c (read-char p)]) + (cond + [(eof-object? c) (error 'tokenize "invalid # near end of file")] + [($char= c #\t) + (let ([c (peek-char p)]) + (cond + [(eof-object? c) '(datum . #t)] + [(delimiter? c) '(datum . #t)] + [else (error 'tokenize "invalid syntax near #t")]))] + [($char= c #\f) + (let ([c (peek-char p)]) + (cond + [(eof-object? c) '(datum . #f)] + [(delimiter? c) '(datum . #f)] + [else (error 'tokenize "invalid syntax near #f")]))] + [($char= #\\ c) (tokenize-char p)] + [($char= #\( c) 'vparen] + [($char= #\x c) (tokenize-hex-init p)] + [($char= #\' c) '(macro . syntax)] + [($char= #\; c) 'hash-semi] + [($char= #\% c) '(macro . |#primitive|)] + [($char= #\| c) (multiline-comment p) (tokenize p)] + [($char= #\b c) + (let ([c (read-char p)]) + (cond + [(eof-object? c) + (error 'tokenize "invalid eof while reading #b")] + [($char= #\- c) + (let ([c (read-char p)]) + (cond + [(eof-object? c) + (error 'tokenize "invalid eof while reading #b-")] + [($char= #\0 c) + (cons 'datum + (* -1 (read-binary 0 '(#\0 #\-) p)))] + [($char= #\1 c) + (cons 'datum + (* -1 (read-binary 1 '(#\1 #\-) p)))] + [else + (unread-char c p) + (error 'tokenize "invalid binary syntax #b-~a" c)]))] + [($char= #\0 c) + (cons 'datum (read-binary 0 '(#\0) p))] + [($char= #\1 c) + (cons 'datum (read-binary 1 '(#\1) p))] + [else + (unread-char c p) + (error 'tokenize "invalid syntax #b~a" c)] + ))] + [($char= #\! c) + (let ([e (read-char p)]) + (when (eof-object? e) + (error 'tokenize "invalid eof near #!")) + (unless ($char= #\e e) + (error 'tokenize "invalid syntax near #!~a" e)) + (let ([o (read-char p)]) + (when (eof-object? o) + (error 'tokenize "invalid eof near #!e")) + (unless ($char= #\o o) + (error 'tokenize "invalid syntax near #!e~a" o)) + (let ([f (read-char p)]) + (when (eof-object? f) + (error 'tokenize "invalid syntax near #!eo")) + (unless ($char= #\f f) + (error 'tokenize "invalid syntax near #!eo~a" f)) + (cons 'datum (eof-object)))))] + [(digit? c) + (tokenize-hashnum p (char->num c))] + [else + (unread-char c p) + (error 'tokenize "invalid syntax #~a" c)])))) + (define (tokenize-hashnum p n) + (let ([c (read-char p)]) + (cond + [(eof-object? c) + (error 'tokenize "invalid eof inside #n mark/ref")] + [($char= #\= c) (cons 'mark n)] + [($char= #\# c) (cons 'ref n)] + [(digit? c) + (tokenize-hashnum p (fx+ (fx* n 10) (char->num c)))] + [else + (unread-char c p) + (error 'tokenize "invalid char ~a while inside a #n mark/ref" c)]))) + (define tokenize-bar + (lambda (p ac) + (let ([c (read-char p)]) + (cond + [(eof-object? c) + (error 'tokenize "unexpected eof while reading symbol")] + [($char= #\\ c) + (let ([c (read-char p)]) + (cond + [(eof-object? c) + (error 'tokenize "unexpected eof while reading symbol")] + [else (tokenize-bar p (cons c ac))]))] + [($char= #\| c) ac] + [else (tokenize-bar p (cons c ac))])))) + (define tokenize + (lambda (p) + (let ([c (read-char p)]) + (cond + [(eof-object? c) (eof-object)] + [(char-whitespace? c) (tokenize p)] + [($char= #\( c) 'lparen] + [($char= #\) c) 'rparen] + [($char= #\[ c) 'lbrack] + [($char= #\] c) 'rbrack] + [($char= #\' c) '(macro . quote)] + [($char= #\` c) '(macro . quasiquote)] + [($char= #\, c) + (let ([c (peek-char p)]) + (cond + [(eof-object? c) '(macro . unquote)] + [($char= c #\@) + (read-char p) + '(macro . unquote-splicing)] + [else '(macro . unquote)]))] + [($char= #\# c) (tokenize-hash p)] + [(digit? c) + (cons 'datum (tokenize-number (char->num c) p))] + [(initial? c) + (let ([ls (reverse (tokenize-identifier (cons c '()) p))]) + (cons 'datum (string->symbol (list->string ls))))] + [($char= #\" c) + (let ([ls (tokenize-string '() p)]) + (cons 'datum (list->string (reverse ls))))] + [($char= #\; c) + (skip-comment p) + (tokenize p)] + [($char= #\+ c) + (tokenize-plus p)] + [($char= #\- c) + (tokenize-minus p)] + [($char= #\. c) + (tokenize-dot p)] + [($char= #\| c) + (let ([ls (reverse (tokenize-bar p '()))]) + (cons 'datum (string->symbol (list->string ls))))] + [else + (unread-char c p) + (error 'tokenize "invalid syntax ~a" c)])))) + + ;;; + ;;;--------------------------------------------------------------* READ *--- + ;;; + (define read-list-rest + (lambda (p locs k end mis) + (let ([t (read-token p)]) + (cond + [(eof-object? t) + (error 'read "end of file encountered while reading list")] + [(eq? t end) (values '() locs k)] + [(eq? t mis) + (error 'read "paren mismatch")] + [(eq? t 'dot) + (let-values ([(d locs k) (read-expr p locs k)]) + (let ([t (read-token p)]) + (cond + [(eq? t end) (values d locs k)] + [(eq? t mis) + (error 'read "paren mismatch")] + [(eq? t 'dot) + (error 'read "cannot have two dots in a list")] + [else + (error 'read "expecting ~a, got ~a" end t)])))] + [(eq? t 'hash-semi) + (let-values ([(ignored locs k) (read-expr p locs k)]) + (read-list-rest p locs k end mis))] + [else + (let-values ([(a locs k) (parse-token p locs k t)]) + (let-values ([(d locs k) (read-list-rest p locs k end mis)]) + (let ([x (cons a d)]) + (values x locs + (if (or (loc? a) (loc? d)) + (extend-k-pair x k) + k)))))])))) + (define read-list-init + (lambda (p locs k end mis) + (let ([t (read-token p)]) + (cond + [(eof-object? t) + (error 'read "end of file encountered while reading list")] + [(eq? t end) (values '() locs k)] + [(eq? t mis) + (error 'read "paren mismatch")] + [(eq? t 'dot) + (error 'read "invalid dot while reading list")] + [(eq? t 'hash-semi) + (let-values ([(ignored locs k) (read-expr p locs k)]) + (read-list-init p locs k end mis))] + [else + (let-values ([(a locs k) (parse-token p locs k t)]) + (let-values ([(d locs k) (read-list-rest p locs k end mis)]) + (let ([x (cons a d)]) + (values x locs + (if (or (loc? a) (loc? d)) + (extend-k-pair x k) + k)))))])))) + (define extend-k-pair + (lambda (x k) + (lambda () + (let ([a (car x)]) + (when (loc? a) + (set-car! x (loc-value a)))) + (let ([d (cdr x)]) + (when (loc? d) + (set-cdr! x (loc-value d)))) + (k)))) + (define vector-put + (lambda (v k i ls) + (cond + [(null? ls) k] + [else + (let ([a (car ls)]) + (vector-set! v i a) + (vector-put v + (if (loc? a) + (lambda () + (vector-set! v i (loc-value (vector-ref v i))) + (k)) + k) + (fxsub1 i) (cdr ls)))]))) + (define read-vector + (lambda (p locs k count ls) + (let ([t (read-token p)]) + (cond + [(eof-object? t) + (error 'read "end of file encountered while reading a vector")] + [(eq? t 'rparen) + (let ([v (make-vector count)]) + (let ([k (vector-put v k (fxsub1 count) ls)]) + (values v locs k)))] + [(eq? t 'rbrack) + (error 'read "unexpected ] while reading a vector")] + [(eq? t 'dot) + (error 'read "unexpected . while reading a vector")] + [(eq? t 'hash-semi) + (let-values ([(ignored locs k) (read-expr p locs k)]) + (read-vector p locs k count ls))] + [else + (let-values ([(a locs k) (parse-token p locs k t)]) + (read-vector p locs k (fxadd1 count) (cons a ls)))])))) + (define-record loc (value set?)) + (define parse-token + (lambda (p locs k t) + (cond + [(eof-object? t) (values (eof-object) locs k)] + [(eq? t 'lparen) (read-list-init p locs k 'rparen 'rbrack)] + [(eq? t 'lbrack) (read-list-init p locs k 'rbrack 'rparen)] + [(eq? t 'vparen) (read-vector p locs k 0 '())] + [(eq? t 'hash-semi) + (let-values ([(ignored locs k) (read-expr p locs k)]) + (read-expr p locs k))] + [(pair? t) + (cond + [(eq? (car t) 'datum) (values (cdr t) locs k)] + [(eq? (car t) 'macro) + (let-values ([(expr locs k) (read-expr p locs k)]) + (let ([x (list expr)]) + (values (cons (cdr t) x) locs + (if (loc? expr) + (lambda () + (set-car! x (loc-value expr)) + (k)) + k))))] + [(eq? (car t) 'mark) + (let ([n (cdr t)]) + (let-values ([(expr locs k) (read-expr p locs k)]) + (cond + [(assq n locs) => + (lambda (x) + (let ([loc (cdr x)]) + (when (loc-set? loc) + (error 'read "duplicate mark ~s" n)) + (set-loc-value! loc expr) + (set-loc-set?! loc #t) + (values expr locs k)))] + [else + (let ([loc (make-loc expr #t)]) + (let ([locs (cons (cons n loc) locs)]) + (values expr locs k)))])))] + [(eq? (car t) 'ref) + (let ([n (cdr t)]) + (cond + [(assq n locs) => + (lambda (x) + (values (cdr x) locs k))] + [else + (let ([loc (make-loc #f #f)]) + (let ([locs (cons (cons n loc) locs)]) + (values loc locs k)))]))] + [else (error 'read "invalid token! ~s" t)])] + [else + (error 'read "unexpected ~s found" t)]))) + (define read-expr + (lambda (p locs k) + (parse-token p locs k (read-token p)))) + + (define reduce-loc! + (lambda (x) + (let ([loc (cdr x)]) + (unless (loc-set? loc) + (error 'read "referenced mark ~s not set" (car x))) + (when (loc? (loc-value loc)) + (let f ([h loc] [t loc]) + (if (loc? h) + (let ([h1 (loc-value h)]) + (if (loc? h1) + (begin + (when (eq? h1 t) + (error 'read "circular marks")) + (let ([v (f (loc-value h1) (loc-value t))]) + (set-loc-value! h1 v) + (set-loc-value! h v) + v)) + (begin + (set-loc-value! h h1) + h1))) + h)))))) + + (define read + (lambda (p) + (let-values ([(expr locs k) (read-expr p '() void)]) + (cond + [(null? locs) expr] + [else + (for-each reduce-loc! locs) + (k) + (if (loc? expr) + (loc-value expr) + expr)])))) + + + + + ;;; + ;;;--------------------------------------------------------------* INIT *--- + ;;; + (primitive-set! 'read-token + (case-lambda + [() (tokenize (current-input-port))] + [(p) + (if (input-port? p) + (tokenize p) + (error 'read-token "~s is not an input port" p))])) + (primitive-set! 'read + (case-lambda + [() (read (current-input-port))] + [(p) + (if (input-port? p) + (read p) + (error 'read "~s is not an input port" p))])) + (let () + (define read-and-eval + (lambda (p) + (let ([x (read p)]) + (unless (eof-object? x) + (eval x) + (read-and-eval p))))) + (primitive-set! 'load + (lambda (x) + (unless (string? x) + (error 'load "~s is not a string" x)) + (let ([p (open-input-file x)]) + (read-and-eval p) + (close-input-port p))))) + ) + diff --git a/src/libtokenizer.fasl b/src/libtokenizer.fasl index 6060fa1..bf05eab 100644 Binary files a/src/libtokenizer.fasl and b/src/libtokenizer.fasl differ diff --git a/src/libtoplevel-6.0.ss b/src/libtoplevel-6.0.ss deleted file mode 100644 index d2fa9fa..0000000 --- a/src/libtoplevel-6.0.ss +++ /dev/null @@ -1,8 +0,0 @@ - -(for-each - (lambda (x) - (let ([v (primitive-ref x)]) - (when (procedure? v) - (set-top-level-value! x v)))) - (oblist)) - diff --git a/src/libtoplevel.fasl b/src/libtoplevel.fasl index c93904f..072360a 100644 Binary files a/src/libtoplevel.fasl and b/src/libtoplevel.fasl differ diff --git a/src/libwriter-6.2.ss b/src/libwriter-6.2.ss index 1dc06ca..2f114f8 100644 --- a/src/libwriter-6.2.ss +++ b/src/libwriter-6.2.ss @@ -308,15 +308,13 @@ (error 'fprintf "~s is not an output port" port)) (unless (string? fmt) (error 'fprintf "~s is not a string" fmt)) - (formatter 'fprintf port fmt args) - (flush-output-port port))) + (formatter 'fprintf port fmt args))) (define printf (lambda (fmt . args) (unless (string? fmt) (error 'printf "~s is not a string" fmt)) - (formatter 'printf (current-output-port) fmt args) - (flush-output-port (current-output-port)))) + (formatter 'printf (current-output-port) fmt args))) (define format (lambda (fmt . args) @@ -371,6 +369,5 @@ (error 'current-error-handler "~s is not a procedure" x))))) (primitive-set! 'error (lambda args - (apply (current-error-handler) args))) - ) + (apply (current-error-handler) args)))) diff --git a/src/libwriter-6.1.ss b/src/libwriter-9.0.ss similarity index 62% rename from src/libwriter-6.1.ss rename to src/libwriter-9.0.ss index 9528868..9654775 100644 --- a/src/libwriter-6.1.ss +++ b/src/libwriter-9.0.ss @@ -1,4 +1,6 @@ +;;; 6.2: * added a printer for bwp-objects + ;;; WRITER provides display and write. (let () @@ -26,46 +28,54 @@ (write-fixnum i p)])) (write-char x p)))) (define write-list - (lambda (x p m) + (lambda (x p m h i) (cond - [(pair? x) + [(and (pair? x) + (or (not (get-hash-table h x #f)) + (fxzero? (get-hash-table h x 0)))) (write-char #\space p) - (writer (car x) p m) - (write-list (cdr x) p m)] - [(not (null? x)) + (write-list (cdr x) p m h + (writer (car x) p m h i))] + [(null? x) i] + [else (write-char #\space p) (write-char #\. p) (write-char #\space p) - (writer x p m)]))) + (writer x p m h i)]))) (define write-vector - (lambda (x p m) + (lambda (x p m h i) (write-char #\# p) (write-char #\( p) (let ([n (vector-length x)]) - (when (fx> n 0) - (writer (vector-ref x 0) p m) - (letrec ([f - (lambda (i) - (unless (fx= i n) - (write-char #\space p) - (writer (vector-ref x i) p m) - (f (fxadd1 i))))]) - (f 1)))) - (write-char #\) p))) + (let ([i + (cond + [(fx> n 0) + (let f ([idx 1] [i (writer (vector-ref x 0) p m h i)]) + (cond + [(fx= idx n) + i] + [else + (write-char #\space p) + (f (fxadd1 idx) + (writer (vector-ref x idx) p m h i))]))] + [else i])]) + (write-char #\) p) + i)))) (define write-record - (lambda (x p m) + (lambda (x p m h i) (write-char #\# p) (write-char #\[ p) - (writer (record-name x) p m) - (let ([n (record-length x)]) - (letrec ([f - (lambda (i) - (unless (fx= i n) - (write-char #\space p) - (writer (record-ref x i) p m) - (f (fxadd1 i))))]) - (f 0))) - (write-char #\] p))) + (let ([i (writer (record-name x) p m h i)]) + (let ([n (record-length x)]) + (let f ([idx 0] [i i]) + (cond + [(fx= idx n) + (write-char #\] p) + i] + [else + (write-char #\space p) + (f (fxadd1 idx) + (writer (record-ref x idx) p m h i))])))))) (define initial? (lambda (c) (or (letter? c) (special-initial? c)))) @@ -123,7 +133,7 @@ (write-symbol-esc str p)) (write-char* str p))))) (define write-gensym - (lambda (x p m) + (lambda (x p m h i) (cond [(and m (print-gensym)) (let ([str (symbol->string x)]) @@ -134,8 +144,11 @@ (write-symbol-esc str p)) (write-char #\space p) (write-symbol-esc (gensym->unique-string x) p) - (write-char #\} p))] - [else (write-symbol x p m)]))) + (write-char #\} p)) + i] + [else + (write-symbol x p m) + i]))) (define write-string-escape (lambda (x p) (define loop @@ -201,70 +214,183 @@ (and (pair? d) (null? ($cdr d)))) (assq ($car x) macro-forms)))) - (define writer - (lambda (x p m) + (define write-pair + (lambda (x p m h i) + (write-char #\( p) + (let ([i (writer (car x) p m h i)]) + (let ([i (write-list (cdr x) p m h i)]) + (write-char #\) p) + i)))) + (define write-ref + (lambda (n p) + (write-char #\# p) + (write-fixnum (fx- -1 n) p) + (write-char #\# p))) + (define write-mark + (lambda (n p) + (write-char #\# p) + (write-fixnum (fx- -1 n) p) + (write-char #\= p))) + (define write-shareable + (lambda (x p m h i k) + (cond + [(get-hash-table h x #f) => + (lambda (n) + (cond + [(fx< n 0) + (write-ref n p) + i] + [(fx= n 0) + (k x p m h i)] + [else + (let ([i (fx- i 1)]) + (put-hash-table! h x i) + (write-mark i p) + (k x p m h i))]))] + [else (k x p m h i)]))) + (define writer + (lambda (x p m h i) (cond - [(macro x) => - (lambda (y) - (write-char* (cdr y) p) - (writer (cadr x) p m))] [(pair? x) - (write-char #\( p) - (writer (car x) p m) - (write-list (cdr x) p m) - (write-char #\) p)] - [(symbol? x) + (write-shareable x p m h i write-pair)] + [(symbol? x) (if (gensym? x) - (write-gensym x p m) - (write-symbol x p m))] + (write-gensym x p m h i) + (begin (write-symbol x p m) i))] [(fixnum? x) - (write-fixnum x p)] + (write-fixnum x p) + i] [(string? x) - (write-string x p m)] + (write-string x p m) + i] [(boolean? x) - (write-char* (if x "#t" "#f") p)] + (write-char* (if x "#t" "#f") p) + i] [(char? x) - (write-character x p m)] + (write-character x p m) + i] [(procedure? x) - (write-char* "#" p)] + (write-char* "#" p) + i] [(output-port? x) (write-char* "# p)] + (let ([i (writer (output-port-name x) p #t h i)]) + (write-char #\> p) + i)] [(input-port? x) (write-char* "# p)] + (let ([i (writer (input-port-name x) p #t h i)]) + (write-char #\> p) + i)] [(vector? x) - (write-vector x p m)] + (write-shareable x p m h i write-vector)] [(null? x) (write-char #\( p) - (write-char #\) p)] + (write-char #\) p) + i] [(eq? x (void)) - (write-char* "#" p)] + (write-char* "#" p) + i] [(eof-object? x) - (write-char* "#!eof" p)] + (write-char* "#!eof" p) + i] + [(bwp-object? x) + (write-char* "#!bwp" p) + i] [(record? x) (let ([printer (record-printer x)]) (if (procedure? printer) - (printer x p) - (write-record x p m)))] + (begin (printer x p) i) + (write-shareable x p m h i write-record)))] ;[(code? x) ; (write-char* "#" p)] [(hash-table? x) - (write-char* "#" p)] + (write-char* "#" p) + i] [($unbound-object? x) - (write-char* "#" p)] + (write-char* "#" p) + i] [($forward-ptr? x) - (write-char* "#" p)] + (write-char* "#" p) + i] [else - (write-char* "#" p)]))) + (write-char* "#" p) + i]))) + + (define print-graph (make-parameter #f)) + + (define (hasher x h) + (define (vec-graph x i j h) + (unless (fx= i j) + (graph (vector-ref x i) h) + (vec-graph x (fxadd1 i) j h))) + (define (vec-dynamic x i j h) + (unless (fx= i j) + (dynamic (vector-ref x i) h) + (vec-dynamic x (fxadd1 i) j h))) + (define (graph x h) + (cond + [(pair? x) + (cond + [(get-hash-table h x #f) => + (lambda (n) + (put-hash-table! h x (fxadd1 n)))] + [else + (put-hash-table! h x 0) + (graph (car x) h) + (graph (cdr x) h)])] + [(vector? x) + (cond + [(get-hash-table h x #f) => + (lambda (n) + (put-hash-table! h x (fxadd1 n)))] + [else + (put-hash-table! h x 0) + (vec-graph x 0 (vector-length x) h)])] + [(gensym? x) + (cond + [(get-hash-table h x #f) => + (lambda (n) + (put-hash-table! h x (fxadd1 n)))])])) + (define (dynamic x h) + (cond + [(pair? x) + (cond + [(get-hash-table h x #f) => + (lambda (n) + (put-hash-table! h x (fxadd1 n)))] + [else + (put-hash-table! h x 0) + (dynamic (car x) h) + (dynamic (cdr x) h) + (when (and (get-hash-table h x #f) + (fxzero? (get-hash-table h x #f))) + (put-hash-table! h x #f))])] + [(vector? x) + (cond + [(get-hash-table h x #f) => + (lambda (n) + (put-hash-table! h x (fxadd1 n)))] + [else + (put-hash-table! h x 0) + (vec-dynamic x 0 (vector-length x) h) + (when (and (get-hash-table h x #f) + (fxzero? (get-hash-table h x #f))) + (put-hash-table! h x #f))])])) + (if (print-graph) + (graph x h) + (dynamic x h))) (define (write x p) - (writer x p #t) + (let ([h (make-hash-table)]) + (hasher x h) + (writer x p #t h 0)) (flush-output-port p)) + ;;; (define (display x p) - (writer x p #f) + (let ([h (make-hash-table)]) + (hasher x h) + (writer x p #f h 0)) (flush-output-port p)) ;;; (define formatter @@ -337,6 +463,7 @@ (primitive-set! 'format format) (primitive-set! 'printf printf) (primitive-set! 'fprintf fprintf) + (primitive-set! 'print-graph print-graph) (primitive-set! 'write (case-lambda [(x) (write x (current-output-port))] diff --git a/src/libwriter-6.0.ss b/src/libwriter-9.1.ss similarity index 56% rename from src/libwriter-6.0.ss rename to src/libwriter-9.1.ss index 2a3fbc8..4f8f010 100644 --- a/src/libwriter-6.0.ss +++ b/src/libwriter-9.1.ss @@ -1,4 +1,6 @@ +;;; 6.2: * added a printer for bwp-objects + ;;; WRITER provides display and write. (let () @@ -26,46 +28,54 @@ (write-fixnum i p)])) (write-char x p)))) (define write-list - (lambda (x p m) + (lambda (x p m h i) (cond - [(pair? x) + [(and (pair? x) + (or (not (get-hash-table h x #f)) + (fxzero? (get-hash-table h x 0)))) (write-char #\space p) - (writer (car x) p m) - (write-list (cdr x) p m)] - [(not (null? x)) + (write-list (cdr x) p m h + (writer (car x) p m h i))] + [(null? x) i] + [else (write-char #\space p) (write-char #\. p) (write-char #\space p) - (writer x p m)]))) + (writer x p m h i)]))) (define write-vector - (lambda (x p m) + (lambda (x p m h i) (write-char #\# p) (write-char #\( p) (let ([n (vector-length x)]) - (when (fx> n 0) - (writer (vector-ref x 0) p m) - (letrec ([f - (lambda (i) - (unless (fx= i n) - (write-char #\space p) - (writer (vector-ref x i) p m) - (f (fxadd1 i))))]) - (f 1)))) - (write-char #\) p))) + (let ([i + (cond + [(fx> n 0) + (let f ([idx 1] [i (writer (vector-ref x 0) p m h i)]) + (cond + [(fx= idx n) + i] + [else + (write-char #\space p) + (f (fxadd1 idx) + (writer (vector-ref x idx) p m h i))]))] + [else i])]) + (write-char #\) p) + i)))) (define write-record - (lambda (x p m) + (lambda (x p m h i) (write-char #\# p) (write-char #\[ p) - (writer (record-name x) p m) - (let ([n (record-length x)]) - (letrec ([f - (lambda (i) - (unless (fx= i n) - (write-char #\space p) - (writer (record-ref x i) p m) - (f (fxadd1 i))))]) - (f 0))) - (write-char #\] p))) + (let ([i (writer (record-name x) p m h i)]) + (let ([n (record-length x)]) + (let f ([idx 0] [i i]) + (cond + [(fx= idx n) + (write-char #\] p) + i] + [else + (write-char #\space p) + (f (fxadd1 idx) + (writer (record-ref x idx) p m h i))])))))) (define initial? (lambda (c) (or (letter? c) (special-initial? c)))) @@ -123,7 +133,7 @@ (write-symbol-esc str p)) (write-char* str p))))) (define write-gensym - (lambda (x p m) + (lambda (x p m h i) (cond [(and m (print-gensym)) (let ([str (symbol->string x)]) @@ -134,8 +144,11 @@ (write-symbol-esc str p)) (write-char #\space p) (write-symbol-esc (gensym->unique-string x) p) - (write-char #\} p))] - [else (write-symbol x p m)]))) + (write-char #\} p)) + i] + [else + (write-symbol x p m) + i]))) (define write-string-escape (lambda (x p) (define loop @@ -143,10 +156,10 @@ (unless (fx= i n) (let ([c (string-ref x i)]) (cond - [(or (char= #\" c) (char= #\\ c)) + [(or ($char= #\" c) ($char= #\\ c)) (write-char #\\ p) (write-char c p)] - [(char= #\tab c) + [($char= #\tab c) (write-char #\\ p) (write-char #\t p)] [else @@ -201,78 +214,187 @@ (and (pair? d) (null? ($cdr d)))) (assq ($car x) macro-forms)))) - (define writer - (lambda (x p m) + (define write-pair + (lambda (x p m h i) + (write-char #\( p) + (let ([i (writer (car x) p m h i)]) + (let ([i (write-list (cdr x) p m h i)]) + (write-char #\) p) + i)))) + (define write-ref + (lambda (n p) + (write-char #\# p) + (write-fixnum (fx- -1 n) p) + (write-char #\# p))) + (define write-mark + (lambda (n p) + (write-char #\# p) + (write-fixnum (fx- -1 n) p) + (write-char #\= p))) + (define write-shareable + (lambda (x p m h i k) + (cond + [(get-hash-table h x #f) => + (lambda (n) + (cond + [(fx< n 0) + (write-ref n p) + i] + [(fx= n 0) + (k x p m h i)] + [else + (let ([i (fx- i 1)]) + (put-hash-table! h x i) + (write-mark i p) + (k x p m h i))]))] + [else (k x p m h i)]))) + (define writer + (lambda (x p m h i) (cond - [(macro x) => - (lambda (y) - (write-char* (cdr y) p) - (writer (cadr x) p m))] [(pair? x) - (write-char #\( p) - (writer (car x) p m) - (write-list (cdr x) p m) - (write-char #\) p)] - [(symbol? x) + (write-shareable x p m h i write-pair)] + [(symbol? x) (if (gensym? x) - (write-gensym x p m) - (write-symbol x p m))] + (write-gensym x p m h i) + (begin (write-symbol x p m) i))] [(fixnum? x) - (write-fixnum x p)] + (write-fixnum x p) + i] [(string? x) - (write-string x p m)] + (write-string x p m) + i] [(boolean? x) - (write-char* (if x "#t" "#f") p)] + (write-char* (if x "#t" "#f") p) + i] [(char? x) - (write-character x p m)] + (write-character x p m) + i] [(procedure? x) - (write-char* "#" p)] + (write-char* "#" p) + i] [(output-port? x) (write-char* "# p)] + (let ([i (writer (output-port-name x) p #t h i)]) + (write-char #\> p) + i)] [(input-port? x) (write-char* "# p)] + (let ([i (writer (input-port-name x) p #t h i)]) + (write-char #\> p) + i)] [(vector? x) - (write-vector x p m)] + (write-shareable x p m h i write-vector)] [(null? x) (write-char #\( p) - (write-char #\) p)] + (write-char #\) p) + i] [(eq? x (void)) - (write-char* "#" p)] + (write-char* "#" p) + i] [(eof-object? x) - (write-char* "#!eof" p)] + (write-char* "#!eof" p) + i] + [(bwp-object? x) + (write-char* "#!bwp" p) + i] [(record? x) (let ([printer (record-printer x)]) (if (procedure? printer) - (printer x p) - (write-record x p m)))] + (begin (printer x p) i) + (write-shareable x p m h i write-record)))] ;[(code? x) ; (write-char* "#" p)] [(hash-table? x) - (write-char* "#" p)] + (write-char* "#" p) + i] [($unbound-object? x) - (write-char* "#" p)] + (write-char* "#" p) + i] [($forward-ptr? x) - (write-char* "#" p)] + (write-char* "#" p) + i] + [(number? x) + (write-char* (number->string x) p) + i] [else - (write-char* "#" p)]))) - (define generic-writer - (lambda (who) - (lambda (x . p) - (let ([port - (if (null? p) - (current-output-port) - (if (null? (cdr p)) - (let ([p (car p)]) - (if (output-port? p) - p - (error who "not an output port ~s" p))) - (error who "too many arguments")))]) - (writer x port (eq? who 'write)) - (flush-output-port port))))) + (write-char* "#" p) + i]))) + + (define print-graph (make-parameter #f)) + + (define (hasher x h) + (define (vec-graph x i j h) + (unless (fx= i j) + (graph (vector-ref x i) h) + (vec-graph x (fxadd1 i) j h))) + (define (vec-dynamic x i j h) + (unless (fx= i j) + (dynamic (vector-ref x i) h) + (vec-dynamic x (fxadd1 i) j h))) + (define (graph x h) + (cond + [(pair? x) + (cond + [(get-hash-table h x #f) => + (lambda (n) + (put-hash-table! h x (fxadd1 n)))] + [else + (put-hash-table! h x 0) + (graph (car x) h) + (graph (cdr x) h)])] + [(vector? x) + (cond + [(get-hash-table h x #f) => + (lambda (n) + (put-hash-table! h x (fxadd1 n)))] + [else + (put-hash-table! h x 0) + (vec-graph x 0 (vector-length x) h)])] + [(gensym? x) + (cond + [(get-hash-table h x #f) => + (lambda (n) + (put-hash-table! h x (fxadd1 n)))])])) + (define (dynamic x h) + (cond + [(pair? x) + (cond + [(get-hash-table h x #f) => + (lambda (n) + (put-hash-table! h x (fxadd1 n)))] + [else + (put-hash-table! h x 0) + (dynamic (car x) h) + (dynamic (cdr x) h) + (when (and (get-hash-table h x #f) + (fxzero? (get-hash-table h x #f))) + (put-hash-table! h x #f))])] + [(vector? x) + (cond + [(get-hash-table h x #f) => + (lambda (n) + (put-hash-table! h x (fxadd1 n)))] + [else + (put-hash-table! h x 0) + (vec-dynamic x 0 (vector-length x) h) + (when (and (get-hash-table h x #f) + (fxzero? (get-hash-table h x #f))) + (put-hash-table! h x #f))])])) + (if (print-graph) + (graph x h) + (dynamic x h))) + + (define (write x p) + (let ([h (make-hash-table)]) + (hasher x h) + (writer x p #t h 0)) + (flush-output-port p)) + ;;; + (define (display x p) + (let ([h (make-hash-table)]) + (hasher x h) + (writer x p #f h 0)) + (flush-output-port p)) ;;; (define formatter (lambda (who p fmt args) @@ -280,21 +402,21 @@ (unless (fx= i (string-length fmt)) (let ([c (string-ref fmt i)]) (cond - [(char= c #\~) + [($char= c #\~) (let ([i (fxadd1 i)]) (when (fx= i (string-length fmt)) (error who "invalid ~~ at end of format string ~s" fmt)) (let ([c (string-ref fmt i)]) (cond - [(char= c #\~) + [($char= c #\~) (write-char #\~ p) (f (fxadd1 i) args)] - [(char= c #\a) + [($char= c #\a) (when (null? args) (error who "insufficient arguments")) (display (car args) p) (f (fxadd1 i) (cdr args))] - [(char= c #\s) + [($char= c #\s) (when (null? args) (error who "insufficient arguments")) (write (car args) p) @@ -344,15 +466,28 @@ (primitive-set! 'format format) (primitive-set! 'printf printf) (primitive-set! 'fprintf fprintf) - (primitive-set! 'display (generic-writer 'display)) - (primitive-set! 'write (generic-writer 'write)) + (primitive-set! 'print-graph print-graph) + (primitive-set! 'write + (case-lambda + [(x) (write x (current-output-port))] + [(x p) + (unless (output-port? p) + (error 'write "~s is not an output port" p)) + (write x p)])) + (primitive-set! 'display + (case-lambda + [(x) (display x (current-output-port))] + [(x p) + (unless (output-port? p) + (error 'display "~s is not an output port" p)) + (display x p)])) (primitive-set! 'print-error print-error) (primitive-set! 'current-error-handler (make-parameter (lambda args (apply print-error args) - (display "exiting\n") - (flush-output-port) + (display "exiting\n" (console-output-port)) + (flush-output-port (console-output-port)) (exit -100)) (lambda (x) (if (procedure? x) diff --git a/src/libwriter.fasl b/src/libwriter.fasl index c6f70d2..18b4f9e 100644 Binary files a/src/libwriter.fasl and b/src/libwriter.fasl differ diff --git a/src/makepp.ss b/src/makepp.ss deleted file mode 100644 index 69ac05b..0000000 --- a/src/makepp.ss +++ /dev/null @@ -1,34 +0,0 @@ -(define primitive-set! set-top-level-value!) -(define chez-expand sc-expand) -(define-syntax |#primitive| - (lambda (x) - (syntax-case x () - [(_ n) #'n]))) - -(printf "loading psyntax.pp ...\n") -(load "psyntax-7.1.pp") - -(current-expand - (lambda (x . args) - (apply chez-expand (sc-expand x) args))) - -(printf "loading psyntax.ss ...\n") -(load "psyntax-7.1.ss") -(current-expand - (lambda (x . args) - (apply chez-expand (sc-expand x) args))) - -(printf "making xpsyntax.pp ...\n") - -(with-output-to-file "xpsyntax.pp" - (lambda () - (load "psyntax-7.1.ss" - (lambda (x) - (parameterize ([print-gensym #f] - [print-graph #f] - [expand-mode 'bootstrap] - [print-vector-length #f]) - (pretty-print (sc-expand x)) - (newline))))) - 'replace) - diff --git a/src/psyntax-7.1-6.9.ss b/src/psyntax-7.1-6.9.ss index 9fe5ef9..e50e456 100644 --- a/src/psyntax-7.1-6.9.ss +++ b/src/psyntax-7.1-6.9.ss @@ -4637,6 +4637,7 @@ "~s is not a record of type ~s" x 'rtd)))) ... )))]))) + (define-syntax $define-record-syntax (lambda (x) (syntax-case x () @@ -4688,7 +4689,6 @@ [(_ x v) ($record-set! x i v)])) ... )))]))) - (define-syntax trace (lambda (x) (syntax-case x () diff --git a/src/psyntax-7.1-6.8.ss b/src/psyntax-7.1-9.0.ss similarity index 97% rename from src/psyntax-7.1-6.8.ss rename to src/psyntax-7.1-9.0.ss index 9a57d6c..b403dd7 100644 --- a/src/psyntax-7.1-6.8.ss +++ b/src/psyntax-7.1-9.0.ss @@ -663,7 +663,7 @@ ;;; AZIZ (define generate-id (lambda (name) - (if name (gensym (symbol->string name)) (gensym)))) + (if name (gensym name) (gensym)))) ) @@ -768,8 +768,9 @@ ;;; ((_ ae level name) name))) (define-syntax build-primref (syntax-rules () - [(_ ae name) `(|#primitive| ,name)] - [(_ ae level name) `(|#primitive| ,name)])) + [(_ ae name) (build-primref ae 1 name)] + [(_ ae level name) + `(|#primitive| ,name)])) ;;; AZIZ @@ -3110,8 +3111,12 @@ (global-extend 'core '|#primitive| (lambda (e r mr w ae m?) (syntax-case e () - ((_ e) (id? #'e) - (build-primref ae (strip (syntax e) w))) + ((_ name) (id? #'name) + (let ([name (strip (syntax name) w)]) + (if (or (memq name (public-primitives)) + (memq name (system-primitives))) + (build-primref ae name) + (syntax-error (source-wrap e w ae))))) (_ (syntax-error (source-wrap e w ae)))))) (global-extend 'core 'syntax @@ -4576,7 +4581,6 @@ - (define-syntax define-record (lambda (x) (syntax-case x () @@ -4593,6 +4597,12 @@ (datum->syntax-object #'name (string->symbol (string-append namestr "?")))] + [(i ...) + (datum->syntax-object #'name + (let f ([i 0] [f* fieldstr*]) + (cond + [(null? f*) '()] + [else (cons i (f (fxadd1 i) (cdr f*)))])))] [(getters ...) (datum->syntax-object #'name (map (lambda (x) @@ -4608,9 +4618,94 @@ [rtd rtd]) #'(begin (define-syntax name (cons '$rtd 'rtd)) - (define constr (record-constructor 'rtd)) - (define pred (record-predicate 'rtd)) - (define getters (record-field-accessor 'rtd 'field*)) ... - (define setters (record-field-mutator 'rtd 'field*)) ... + (define constr + (lambda (field* ...) + ($record 'rtd field* ...))) + (define pred + (lambda (x) ($record/rtd? x 'rtd))) + (define getters + (lambda (x) + (if ($record/rtd? x 'rtd) + ($record-ref x i) + (error 'getters + "~s is not a record of type ~s" x 'rtd)))) ... + (define setters + (lambda (x v) + (if ($record/rtd? x 'rtd) + ($record-set! x i v) + (error 'setters + "~s is not a record of type ~s" x 'rtd)))) ... )))]))) + +(define-syntax $define-record-syntax + (lambda (x) + (syntax-case x () + [(_ name (field* ...)) + (let* ([namestr (symbol->string (syntax-object->datum #'name))] + [fields (syntax-object->datum #'(field* ...))] + [fieldstr* (map symbol->string fields)] + [rtd (make-record-type namestr fields)]) + (with-syntax ([constr + (datum->syntax-object #'name + (string->symbol + (string-append "make-" namestr)))] + [pred + (datum->syntax-object #'name + (string->symbol + (string-append namestr "?")))] + [(i ...) + (datum->syntax-object #'name + (let f ([i 0] [f* fieldstr*]) + (cond + [(null? f*) '()] + [else (cons i (f (fxadd1 i) (cdr f*)))])))] + [(getters ...) + (datum->syntax-object #'name + (map (lambda (x) + (string->symbol + (string-append namestr "-" x))) + fieldstr*))] + [(setters ...) + (datum->syntax-object #'name + (map (lambda (x) + (string->symbol + (string-append "set-" namestr "-" x "!"))) + fieldstr*))] + [rtd rtd]) + #'(begin + (define-syntax name (cons '$rtd 'rtd)) + (define-syntax constr + (syntax-rules () + [(_ field* ...) ($record 'rtd field* ...)])) + (define-syntax pred + (syntax-rules () + [(_ x) ($record/rtd? x 'rtd)])) + (define-syntax getters + (syntax-rules () + [(_ x) ($record-ref x i)])) ... + (define-syntax setters + (syntax-rules () + [(_ x v) ($record-set! x i v)])) ... + )))]))) + +(define-syntax trace + (lambda (x) + (syntax-case x () + [(_ id) (identifier? #'id) + #'(trace-symbol! 'id)]))) + + +(define-syntax untrace + (lambda (x) + (syntax-case x () + [(_ id) (identifier? #'id) + #'(untrace-symbol! 'id)]))) + + +(define-syntax trace-lambda + (lambda (x) + (syntax-case x () + [(_ name args body body* ...) + #'(make-traced-procedure 'name (lambda args body body* ...))]))) + diff --git a/src/psyntax-7.1-6.5.ss b/src/psyntax-7.1-9.1.ss similarity index 97% rename from src/psyntax-7.1-6.5.ss rename to src/psyntax-7.1-9.1.ss index d45f439..a05d33e 100644 --- a/src/psyntax-7.1-6.5.ss +++ b/src/psyntax-7.1-9.1.ss @@ -663,7 +663,7 @@ ;;; AZIZ (define generate-id (lambda (name) - (if name (gensym (symbol->string name)) (gensym)))) + (if name (gensym name) (gensym)))) ) @@ -768,8 +768,9 @@ ;;; ((_ ae level name) name))) (define-syntax build-primref (syntax-rules () - [(_ ae name) `(|#primitive| ,name)] - [(_ ae level name) `(|#primitive| ,name)])) + [(_ ae name) (build-primref ae 1 name)] + [(_ ae level name) + `(|#primitive| ,name)])) ;;; AZIZ @@ -790,7 +791,7 @@ (if (null? (cdr exps)) (car exps) ; weed out leading void calls, assuming ordinary list representation - (if (equal? (car exps) '(void)) + (if (equal? (car exps) '(#%void)) (loop (cdr exps)) `(begin ,@exps)))))) @@ -846,7 +847,7 @@ (syntax-rules () ((_ e) (let ((x e)) - (or (boolean? x) (fixnum? x) (string? x) (char? x) (null? x)))))) + (or (boolean? x) (fixnum? x) (string? x) (char? x) (null? x) (number? x)))))) ) (define-syntax unannotate @@ -2458,6 +2459,9 @@ (case type ((lexical) (build-lexical-reference 'value ae value)) + ;;; AZIZ + ((core-primitive) + (build-primref ae value)) ((core) (value e r mr w ae m?)) ((lexical-call) (chi-application @@ -3107,8 +3111,12 @@ (global-extend 'core '|#primitive| (lambda (e r mr w ae m?) (syntax-case e () - ((_ e) (id? #'e) - (build-primref ae (strip (syntax e) w))) + ((_ name) (id? #'name) + (let ([name (strip (syntax name) w)]) + (if (or (memq name (public-primitives)) + (memq name (system-primitives))) + (build-primref ae name) + (syntax-error (source-wrap e w ae))))) (_ (syntax-error (source-wrap e w ae)))))) (global-extend 'core 'syntax @@ -4573,7 +4581,6 @@ - (define-syntax define-record (lambda (x) (syntax-case x () @@ -4590,6 +4597,12 @@ (datum->syntax-object #'name (string->symbol (string-append namestr "?")))] + [(i ...) + (datum->syntax-object #'name + (let f ([i 0] [f* fieldstr*]) + (cond + [(null? f*) '()] + [else (cons i (f (fxadd1 i) (cdr f*)))])))] [(getters ...) (datum->syntax-object #'name (map (lambda (x) @@ -4605,9 +4618,94 @@ [rtd rtd]) #'(begin (define-syntax name (cons '$rtd 'rtd)) - (define constr (record-constructor 'rtd)) - (define pred (record-predicate 'rtd)) - (define getters (record-field-accessor 'rtd 'field*)) ... - (define setters (record-field-mutator 'rtd 'field*)) ... + (define constr + (lambda (field* ...) + ($record 'rtd field* ...))) + (define pred + (lambda (x) ($record/rtd? x 'rtd))) + (define getters + (lambda (x) + (if ($record/rtd? x 'rtd) + ($record-ref x i) + (error 'getters + "~s is not a record of type ~s" x 'rtd)))) ... + (define setters + (lambda (x v) + (if ($record/rtd? x 'rtd) + ($record-set! x i v) + (error 'setters + "~s is not a record of type ~s" x 'rtd)))) ... )))]))) + +(define-syntax $define-record-syntax + (lambda (x) + (syntax-case x () + [(_ name (field* ...)) + (let* ([namestr (symbol->string (syntax-object->datum #'name))] + [fields (syntax-object->datum #'(field* ...))] + [fieldstr* (map symbol->string fields)] + [rtd (make-record-type namestr fields)]) + (with-syntax ([constr + (datum->syntax-object #'name + (string->symbol + (string-append "make-" namestr)))] + [pred + (datum->syntax-object #'name + (string->symbol + (string-append namestr "?")))] + [(i ...) + (datum->syntax-object #'name + (let f ([i 0] [f* fieldstr*]) + (cond + [(null? f*) '()] + [else (cons i (f (fxadd1 i) (cdr f*)))])))] + [(getters ...) + (datum->syntax-object #'name + (map (lambda (x) + (string->symbol + (string-append namestr "-" x))) + fieldstr*))] + [(setters ...) + (datum->syntax-object #'name + (map (lambda (x) + (string->symbol + (string-append "set-" namestr "-" x "!"))) + fieldstr*))] + [rtd rtd]) + #'(begin + (define-syntax name (cons '$rtd 'rtd)) + (define-syntax constr + (syntax-rules () + [(_ field* ...) ($record 'rtd field* ...)])) + (define-syntax pred + (syntax-rules () + [(_ x) ($record/rtd? x 'rtd)])) + (define-syntax getters + (syntax-rules () + [(_ x) ($record-ref x i)])) ... + (define-syntax setters + (syntax-rules () + [(_ x v) ($record-set! x i v)])) ... + )))]))) + +(define-syntax trace + (lambda (x) + (syntax-case x () + [(_ id) (identifier? #'id) + #'(trace-symbol! 'id)]))) + + +(define-syntax untrace + (lambda (x) + (syntax-case x () + [(_ id) (identifier? #'id) + #'(untrace-symbol! 'id)]))) + + +(define-syntax trace-lambda + (lambda (x) + (syntax-case x () + [(_ name args body body* ...) + #'(make-traced-procedure 'name (lambda args body body* ...))]))) + diff --git a/src/psyntax-7.1.ss b/src/psyntax-7.1.ss deleted file mode 100644 index f128c8c..0000000 --- a/src/psyntax-7.1.ss +++ /dev/null @@ -1,4608 +0,0 @@ -;;; Portable implementation of syntax-case -;;; Extracted from Chez Scheme Version 7.1 (Aug 01, 2006) -;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman - -;;; Copyright (c) 1992-2002 Cadence Research Systems -;;; Permission to copy this software, in whole or in part, to use this -;;; software for any lawful purpose, and to redistribute this software -;;; is granted subject to the restriction that all copies made of this -;;; software must include this copyright notice in full. This software -;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED, -;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY -;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE -;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY -;;; NATURE WHATSOEVER. - -;;; Before attempting to port this code to a new implementation of -;;; Scheme, please read the notes below carefully. - -;;; This file defines the syntax-case expander, sc-expand, and a set -;;; of associated syntactic forms and procedures. Of these, the -;;; following are documented in The Scheme Programming Language, -;;; Third Edition (R. Kent Dybvig, MIT Press, 2003), which can be -;;; found online at http://www.scheme.com/tspl3/. Most are also documented -;;; in the R4RS and draft R5RS. -;;; -;;; bound-identifier=? -;;; datum->syntax-object -;;; define-syntax -;;; fluid-let-syntax -;;; free-identifier=? -;;; generate-temporaries -;;; identifier? -;;; identifier-syntax -;;; let-syntax -;;; letrec-syntax -;;; syntax -;;; syntax-case -;;; syntax-object->datum -;;; syntax-rules -;;; with-syntax -;;; -;;; All standard Scheme syntactic forms are supported by the expander -;;; or syntactic abstractions defined in this file. Only the R4RS -;;; delay is omitted, since its expansion is implementation-dependent. - -;;; Also defined are three forms that support modules: module, import, -;;; and import-only. These are documented in the Chez Scheme User's -;;; Guide (R. Kent Dybvig, Cadence Research Systems, 1998), which can -;;; also be found online at http://www.scheme.com/csug/. They are -;;; described briefly here as well. - -;;; All are definitions and may appear where and only where other -;;; definitions may appear. modules may be named: -;;; -;;; (module id (ex ...) defn ... init ...) -;;; -;;; or anonymous: -;;; -;;; (module (ex ...) defn ... init ...) -;;; -;;; The latter form is semantically equivalent to: -;;; -;;; (module T (ex ...) defn ... init ...) -;;; (import T) -;;; -;;; where T is a fresh identifier. -;;; -;;; In either form, each of the exports in (ex ...) is either an -;;; identifier or of the form (id ex ...). In the former case, the -;;; single identifier ex is exported. In the latter, the identifier -;;; id is exported and the exports ex ... are "implicitly" exported. -;;; This listing of implicit exports is useful only when id is a -;;; keyword bound to a transformer that expands into references to -;;; the listed implicit exports. In the present implementation, -;;; listing of implicit exports is necessary only for top-level -;;; modules and allows the implementation to avoid placing all -;;; identifiers into the top-level environment where subsequent passes -;;; of the compiler will be unable to deal effectively with them. -;;; -;;; Named modules may be referenced in import statements, which -;;; always take one of the forms: -;;; -;;; (import id) -;;; (import-only id) -;;; -;;; id must name a module. Each exported identifier becomes visible -;;; within the scope of the import form. In the case of import-only, -;;; all other identifiers become invisible in the scope of the -;;; import-only form, except for those established by definitions -;;; that appear textually after the import-only form. - -;;; import and import-only also support a variety of identifier -;;; selection and renaming forms: only, except, add-prefix, -;;; drop-prefix, rename, and alias. -;;; -;;; (import (only m x y)) -;;; -;;; imports x and y (and nothing else) from m. -;;; -;;; (import (except m x y)) -;;; -;;; imports all of m's imports except for x and y. -;;; -;;; (import (add-prefix (only m x y) m:)) -;;; -;;; imports x and y as m:x and m:y. -;;; -;;; (import (drop-prefix m foo:)) -;;; -;;; imports all of m's imports, dropping the common foo: prefix -;;; (which must appear on all of m's exports). -;;; -;;; (import (rename (except m a b) (m-c c) (m-d d))) -;;; -;;; imports all of m's imports except for x and y, renaming c -;;; m-c and d m-d. -;;; -;;; (import (alias (except m a b) (m-c c) (m-d d))) -;;; -;;; imports all of m's imports except for x and y, with additional -;;; aliases m-c for c and m-d for d. -;;; -;;; multiple imports may be specified with one import form: -;;; -;;; (import (except m1 x) (only m2 x)) -;;; -;;; imports all of m1's exports except for x plus x from m2. - -;;; Another form, meta, may be used as a prefix for any definition and -;;; causes any resulting variable bindings to be created at expansion -;;; time. Meta variables (variables defined using meta) are available -;;; only at expansion time. Meta definitions are often used to create -;;; data and helpers that can be shared by multiple macros, for example: - -;;; (module (alpha beta) -;;; (meta define key-error -;;; (lambda (key) -;;; (syntax-error key "invalid key"))) -;;; (meta define parse-keys -;;; (lambda (keys) -;;; (let f ((keys keys) (c #'white) (s 10)) -;;; (syntax-case keys (color size) -;;; (() (list c s)) -;;; (((color c) . keys) (f #'keys #'c s)) -;;; (((size s) . keys) (f #'keys c #'s)) -;;; ((k . keys) (key-error #'k)))))) -;;; (define-syntax alpha -;;; (lambda (x) -;;; (syntax-case x () -;;; ((_ (k ...) ) -;;; (with-syntax (((c s) (parse-keys (syntax (k ...))))) -;;; ---))))) -;;; (define-syntax beta -;;; (lambda (x) -;;; (syntax-case x () -;;; ((_ (k ...) ) -;;; (with-syntax (((c s) (parse-keys (syntax (k ...))))) -;;; ---)))))) - -;;; As with define-syntax rhs expressions, meta expressions can evaluate -;;; references only to identifiers whose values are (already) available -;;; in the compile-time environment, e.g., macros and meta variables. -;;; They can, however, like define-syntax rhs expressions, build syntax -;;; objects containing occurrences of any identifiers in their scope. - -;;; meta definitions propagate through macro expansion, so one can write, -;;; for example: -;;; -;;; (module (a) -;;; (meta define-structure (foo x)) -;;; (define-syntax a -;;; (let ((q (make-foo (syntax 'q)))) -;;; (lambda (x) -;;; (foo-x q))))) -;;; a -> q -;;; -;;; where define-record is a macro that expands into a set of defines. -;;; -;;; It is also sometimes convenient to write -;;; -;;; (meta begin defn ...) -;;; -;;; or -;;; -;;; (meta module {exports} defn ...) -;;; -;;; to create groups of meta bindings. - -;;; Another form, alias, is used to create aliases from one identifier -;;; to another. This is used primarily to support the extended import -;;; syntaxes (add-prefix, drop-prefix, rename, and alias). - -;;; (let ((x 3)) (alias y x) y) -> 3 - -;;; The remaining exports are listed below. sc-expand, eval-when, and -;;; syntax-error are described in the Chez Scheme User's Guide. -;;; -;;; (sc-expand datum) -;;; if datum represents a valid expression, sc-expand returns an -;;; expanded version of datum in a core language that includes no -;;; syntactic abstractions. The core language includes begin, -;;; define, if, lambda, letrec, quote, and set!. -;;; (eval-when situations expr ...) -;;; conditionally evaluates expr ... at compile-time or run-time -;;; depending upon situations -;;; (syntax-error object message) -;;; used to report errors found during expansion -;;; ($syntax-dispatch e p) -;;; used by expanded code to handle syntax-case matching -;;; ($sc-put-cte symbol val top-token) -;;; used to establish top-level compile-time (expand-time) bindings. - -;;; The following nonstandard procedures must be provided by the -;;; implementation for this code to run. -;;; -;;; (void) -;;; returns the implementation's cannonical "unspecified value". The -;;; following usually works: -;;; -;;; (define void (lambda () (if #f #f))). -;;; -;;; (andmap proc list1 list2 ...) -;;; returns true if proc returns true when applied to each element of list1 -;;; along with the corresponding elements of list2 .... The following -;;; definition works but does no error checking: -;;; -;;; (define andmap -;;; (lambda (f first . rest) -;;; (or (null? first) -;;; (if (null? rest) -;;; (let andmap ((first first)) -;;; (let ((x (car first)) (first (cdr first))) -;;; (if (null? first) -;;; (f x) -;;; (and (f x) (andmap first))))) -;;; (let andmap ((first first) (rest rest)) -;;; (let ((x (car first)) -;;; (xr (map car rest)) -;;; (first (cdr first)) -;;; (rest (map cdr rest))) -;;; (if (null? first) -;;; (apply f (cons x xr)) -;;; (and (apply f (cons x xr)) (andmap first rest))))))))) -;;; -;;; (ormap proc list1) -;;; returns the first non-false return result of proc applied to -;;; the elements of list1 or false if none. The following definition -;;; works but does no error checking: -;;; -;;; (define ormap -;;; (lambda (proc list1) -;;; (and (not (null? list1)) -;;; (or (proc (car list1)) (ormap proc (cdr list1)))))) -;;; -;;; The following nonstandard procedures must also be provided by the -;;; implementation for this code to run using the standard portable -;;; hooks and output constructors. They are not used by expanded code, -;;; and so need be present only at expansion time. -;;; -;;; (eval x) -;;; where x is always in the form ("noexpand" expr). -;;; returns the value of expr. the "noexpand" flag is used to tell the -;;; evaluator/expander that no expansion is necessary, since expr has -;;; already been fully expanded to core forms. -;;; -;;; eval will not be invoked during the loading of psyntax.pp. After -;;; psyntax.pp has been loaded, the expansion of any macro definition, -;;; whether local or global, results in a call to eval. If, however, -;;; sc-expand has already been registered as the expander to be used -;;; by eval, and eval accepts one argument, nothing special must be done -;;; to support the "noexpand" flag, since it is handled by sc-expand. -;;; -;;; (error who format-string why what) -;;; where who is either a symbol or #f, format-string is always "~a ~s", -;;; why is always a string, and what may be any object. error should -;;; signal an error with a message something like -;;; -;;; "error in : " -;;; -;;; (gensym) -;;; returns a unique symbol each time it's called. In Chez Scheme, gensym -;;; returns a symbol with a "globally" unique name so that gensyms that -;;; end up in the object code of separately compiled files cannot conflict. -;;; This is necessary only if you intend to support compiled files. -;;; -;;; (gensym? x) -;;; returns #t if x is a gensym, otherwise false. -;;; -;;; (putprop symbol key value) -;;; (getprop symbol key) -;;; (remprop symbol key) -;;; key is always a symbol; value may be any object. putprop should -;;; associate the given value with the given symbol and key in some way -;;; that it can be retrieved later with getprop. getprop should return -;;; #f if no value is associated with the given symbol and key. remprop -;;; should remove the association between the given symbol and key. - -;;; When porting to a new Scheme implementation, you should define the -;;; procedures listed above, load the expanded version of psyntax.ss -;;; (psyntax.pp, which should be available whereever you found -;;; psyntax.ss), and register sc-expand as the current expander (how -;;; you do this depends upon your implementation of Scheme). You may -;;; change the hooks and constructors defined toward the beginning of -;;; the code below, but to avoid bootstrapping problems, do so only -;;; after you have a working version of the expander. - -;;; Chez Scheme allows the syntactic form (syntax