conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

import from compiler4

This commit is contained in:
Abdulaziz Ghuloum 2006-11-23 19:44:29 -05:00
parent 03e9649064
commit 3815bebb4c
84 changed files with 43947 additions and 56974 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Makefile
View File

@ -2,7 +2,7 @@
all: ikarus.fasl
ikarus.fasl:
echo '(load "compiler-6.2.ss")' | petite
echo '(load "compiler-6.9.ss")' | petite
clean:
rm -f *.fasl

2
src/build-date.tmp
View File

@ -1 +1 @@
2006-08-02
2006-08-22

22
src/chez-compat.ss
View File

@ -31,5 +31,27 @@
(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))

3199
src/compiler-6.3.ss Normal file
View File

File diff suppressed because it is too large Load Diff

98
src/compiler-6.4.ss Normal file
View File

@ -0,0 +1,98 @@
;;; 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")

96
src/compiler-6.5.ss Normal file
View File

@ -0,0 +1,96 @@
;;; 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")

97
src/compiler-6.6.ss Normal file
View File

@ -0,0 +1,97 @@
;;; 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")

98
src/compiler-6.7.ss Normal file
View File

@ -0,0 +1,98 @@
;;; 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")

98
src/compiler-6.8.ss Normal file
View File

@ -0,0 +1,98 @@
;;; 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")

256
src/compiler-6.9.ss Normal file
View File

@ -0,0 +1,256 @@
;;;
;;; 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<=? 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<=? 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
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
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
))
(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!
call/cf trace-symbol! untrace-symbol! make-traced-procedure
fixnum->string date-string
vector-memq vector-memv
))
(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.6.ss") ; uses make-code, etc.
(load "libfasl-6.7.ss") ; uses code? etc.
(load "libcompile-6.7.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"]
))
(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)
(compile-library (car x) (cadr 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 cadr scheme-library-files))))

261
src/compiler-8.0.ss Normal file
View File

@ -0,0 +1,261 @@
;;;
;;; 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<=? 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<=? 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
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
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
))
(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!
call/cf trace-symbol! untrace-symbol! make-traced-procedure
fixnum->string date-string
vector-memq vector-memv
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
))
(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.6.ss") ; uses make-code, etc.
(load "libfasl-6.7.ss") ; uses code? etc.
(load "libcompile-6.7.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"]
))
(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)
(compile-library (car x) (cadr 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 cadr scheme-library-files))))

289
src/compiler-8.1.ss Normal file
View File

@ -0,0 +1,289 @@
;;; 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<=? 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<=? 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 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-output-string get-output-string
with-output-to-file call-with-output-file
with-input-from-file call-with-input-file
))
(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!
call/cf trace-symbol! untrace-symbol! make-traced-procedure
fixnum->string date-string
vector-memq vector-memv
;;; must open-code
$make-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!
;;; 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.6.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"]
["libcore-6.9.ss" #t "libcore.fasl"]
["libchezio-8.1.ss" #t "libchezio.fasl"]
["libwriter-6.2.ss" #t "libwriter.fasl"]
["libtokenizer-6.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-8.1.ss" #t "libcompile.fasl"]
["psyntax-7.1-6.9.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"]
["libhash-6.2.ss" #t "libhash.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)
(printf "done\n")))
(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))))

7
src/geninstr/gen.pl
View File

@ -48,7 +48,12 @@ sub gen3{
}
}
gen1 "movb \$0, 4(r1)\n";
gen1 "movl \$0x1234, 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";
#gen2 "xorl r1,r2\n";

16
src/geninstr/tmp.dump
View File

@ -4,11 +4,11 @@ tmp.o: file format elf32-i386
Disassembly of section .text:
00000000 <.text>:
0: c6 40 04 00 movb $0x0,0x4(%eax)
4: c6 41 04 00 movb $0x0,0x4(%ecx)
8: c6 42 04 00 movb $0x0,0x4(%edx)
c: c6 43 04 00 movb $0x0,0x4(%ebx)
10: c6 44 24 04 00 movb $0x0,0x4(%esp)
15: c6 45 04 00 movb $0x0,0x4(%ebp)
19: c6 46 04 00 movb $0x0,0x4(%esi)
1d: c6 47 04 00 movb $0x0,0x4(%edi)
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

16
src/geninstr/tmp.s
View File

@ -1,9 +1,9 @@
.text
movb $0, 4(%eax)
movb $0, 4(%ecx)
movb $0, 4(%edx)
movb $0, 4(%ebx)
movb $0, 4(%esp)
movb $0, 4(%ebp)
movb $0, 4(%esi)
movb $0, 4(%edi)
movl $0x1234, %eax
movl $0x1234, %ecx
movl $0x1234, %edx
movl $0x1234, %ebx
movl $0x1234, %esp
movl $0x1234, %ebp
movl $0x1234, %esi
movl $0x1234, %edi

BIN
src/ikarus.fasl
View File

Binary file not shown.

56
src/libassembler-6.7.ss Normal file
View File

@ -0,0 +1,56 @@
(primitive-set! 'make-code
(lambda (code-size freevars)
(unless (and (fixnum? code-size) ($fx>= code-size 0))
(error 'make-code "~s is not a valid code size" code-size))
(unless (and (fixnum? freevars) ($fx>= freevars 0))
(error 'make-code "~s is not a valid number of free vars" freevars))
(foreign-call "ikrt_make_code" code-size freevars '#())))
(primitive-set! 'code?
(lambda (x) ($code? x)))
(primitive-set! 'code-reloc-vector
(lambda (x)
(unless ($code? x) (error 'code-reloc-vector "~s is not a code" x))
($code-reloc-vector x)))
(primitive-set! 'code-freevars
(lambda (x)
(unless ($code? x) (error 'code-closure-size "~s is not a code" x))
($code-freevars x)))
(primitive-set! 'code-size
(lambda (x)
(unless ($code? x) (error 'code-size "~s is not a code" x))
($code-size x)))
(primitive-set! 'code-set!
(lambda (x i v)
(unless ($code? x) (error 'code-set! "~s is not a code" x))
(unless (and (fixnum? i)
($fx>= i 0)
($fx< i ($code-size x)))
(error 'code-set! "~s is not a valid index" i))
(unless (and (fixnum? v)
($fx>= v 0)
($fx< v 256))
(error 'code-set! "~s is not a valid byte" v))
($code-set! x i v)))
(primitive-set! 'code-ref
(lambda (x i)
(unless ($code? x) (error 'code-ref "~s is not a code" x))
(unless (and (fixnum? i)
($fx>= i 0)
($fx< i ($code-size x)))
(error 'code-ref "~s is not a valid index" i))
($code-ref x i)))
(primitive-set! 'set-code-reloc-vector!
(lambda (x v)
(unless ($code? x)
(error 'set-code-reloc-vector! "~s is not a code" x))
(unless (vector? v)
(error 'set-code-reloc-vector! "~s is not a vector" v))
(foreign-call "ikrt_set_code_reloc_vector" x v)))

107
src/libassembler-compat-6.0.ss
View File

@ -1,56 +1,67 @@
(define-record code (closure-size code-vec reloc-vec))
(define make-code
(let ([make-code make-code])
(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)))))))
(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)))
(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!))

32
src/libassembler-compat-6.6.ss Normal file
View File

@ -0,0 +1,32 @@
(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!))

32
src/libassembler-compat-6.7.ss Normal file
View File

@ -0,0 +1,32 @@
(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!))

BIN
src/libassembler-compat.ss Normal file
View File

Binary file not shown.

BIN
src/libassembler.ss Normal file
View File

Binary file not shown.

3
src/libcafe-6.1.ss
View File

@ -30,7 +30,6 @@
(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 ()
@ -64,7 +63,7 @@
(primitive-set! 'new-cafe
(case-lambda
[() (new-cafe (current-eval))]
[() (new-cafe eval)]
[(p)
(unless (procedure? p)
(error 'new-cafe "~s is not a procedure" p))

BIN
src/libcafe.fasl
View File

Binary file not shown.

750
src/libchezio-8.1.ss Normal file
View File

@ -0,0 +1,750 @@
(let ()
(include "unsafe-record.ss")
;;;
;;; GENERIC PORTS: BASIC PRIMITIVES
;;;
;;; Exports:
;;; * Constructors:
;;; (make-input-port handler input-buffer)
;;; (make-output-port handler output-buffer)
;;; (make-input/output-port handler input-buffer output-buffer)
;;;
;;; * Predicates:
;;; (port? x)
;;; (input-port? x)
;;; (output-port? x)
;;;
;;; * Accessors:
;;; (port-handler port)
;;; (port-input-buffer port)
;;; (port-input-index port)
;;; (port-input-size port)
;;; (port-output-buffer port)
;;; (port-output-index port)
;;; (port-output-size port)
;;;
;;; * Mutators:
;;; (set-port-input-index! port fixnum)
;;; (set-port-input-size! port fixnum)
;;; (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)))])))
;;;
(primitive-set! 'port?
(lambda (x) (port? x)))
;;;
(primitive-set! 'input-port?
(lambda (x) (input-port? x)))
;;;
(primitive-set! 'output-port?
(lambda (x) (output-port? x)))
;;;
(primitive-set! '$make-input-port
(lambda (handler buffer)
($make-port handler buffer 0 ($string-length buffer) #f 0 0)))
;;;
(primitive-set! 'make-input-port
(lambda (handler buffer)
(if (procedure? handler)
(if (string? buffer)
($make-input-port handler buffer)
(error 'make-input-port "~s is not a string" buffer))
(error 'make-input-port "~s is not a procedure" handler))))
;;;
(primitive-set! '$make-output-port
(lambda (handler buffer)
($make-port handler #f 0 0 buffer 0 ($string-length buffer))))
;;;
(primitive-set! 'make-output-port
(lambda (handler buffer)
(if (procedure? handler)
(if (string? buffer)
($make-output-port handler buffer)
(error 'make-output-port "~s is not a string" buffer))
(error 'make-output-port "~s is not a procedure" handler))))
;;;
(primitive-set! '$make-input/output-port
(lambda (handler input-buffer output-buffer)
($make-port handler
input-buffer 0 ($string-length input-buffer)
output-buffer 0 ($string-length output-buffer))))
(primitive-set! 'make-input/output-port
(lambda (handler input-buffer output-buffer)
(if (procedure? handler)
(if (string? input-buffer)
(if (string? output-buffer)
($make-input/output-port handler input-buffer output-buffer)
(error 'make-input/output-port
"~s is not a string"
output-buffer))
(error 'make-input/output-port "~s is not a string" input-buffer))
(error 'make-input/output-port "~s is not a procedure" handler))))
;;;
(primitive-set! '$port-handler
(lambda (x) ($port-handler x)))
;;;
(primitive-set! 'port-handler
(lambda (x)
(if (port? x)
($port-handler x)
(error 'port-handler "~s is not a port" x))))
;;;
(primitive-set! '$port-input-buffer
(lambda (x) ($port-input-buffer x)))
;;;
(primitive-set! 'port-input-buffer
(lambda (x)
(if (input-port? x)
($port-input-buffer x)
(error 'port-input-buffer "~s is not an input-port" x))))
;;;
(primitive-set! '$port-input-index
(lambda (x) ($port-input-index x)))
;;;
(primitive-set! 'port-input-index
(lambda (x)
(if (input-port? x)
($port-input-index x)
(error 'port-input-index "~s is not an input-port" x))))
;;;
(primitive-set! '$port-input-size
(lambda (x) ($port-input-size x)))
;;;
(primitive-set! 'port-input-size
(lambda (x)
(if (input-port? x)
($port-input-size x)
(error 'port-input-size "~s is not an input-port" x))))
;;;
(primitive-set! '$port-output-buffer
(lambda (x) ($port-output-buffer x)))
;;;
(primitive-set! 'port-output-buffer
(lambda (x)
(if (output-port? x)
($port-output-buffer x)
(error 'port-output-buffer "~s is not an output-port" x))))
;;;
(primitive-set! '$port-output-index
(lambda (x) ($port-output-index x)))
;;;
(primitive-set! 'port-output-index
(lambda (x)
(if (output-port? x)
($port-output-index x)
(error 'port-output-index "~s is not an output-port" x))))
;;;
(primitive-set! '$port-output-size
(lambda (x) ($port-output-size x)))
;;;
(primitive-set! 'port-output-size
(lambda (x)
(if (output-port? x)
($port-output-size x)
(error 'port-output-size "~s is not an output-port" x))))
;;;
(primitive-set! '$set-port-input-index!
(lambda (p i) ($set-port-input-index! p i)))
;;;
(primitive-set! 'set-port-input-index!
(lambda (p i)
(if (input-port? p)
(if (fixnum? i)
(if ($fx>= i 0)
(if ($fx<= i ($port-input-size p))
($set-port-input-index! p i)
(error 'set-port-input-index! "index ~s is too big" i))
(error 'set-port-input-index! "index ~s is negative" i))
(error 'set-port-input-index! "~s is not a valid index" i))
(error 'set-port-input-index! "~s is not an input-port" p))))
;;;
(primitive-set! '$set-port-input-size!
(lambda (p i)
($set-port-input-index! p 0)
($set-port-input-size! p i)))
;;;
(primitive-set! 'set-port-input-size!
(lambda (p i)
(if (input-port? p)
(if (fixnum? i)
(if ($fx>= i 0)
(if ($fx<= i ($string-length ($port-input-buffer p)))
(begin
($set-port-input-index! p 0)
($set-port-input-size! p i))
(error 'set-port-input-size! "size ~s is too big" i))
(error 'set-port-input-size! "size ~s is negative" i))
(error 'set-port-input-size! "~s is not a valid size" i))
(error 'set-port-input-size! "~s is not an input-port" p))))
;;;
(primitive-set! '$set-port-output-index!
(lambda (p i) ($set-port-output-index! p i)))
;;;
(primitive-set! 'set-port-output-index!
(lambda (p i)
(if (output-port? p)
(if (fixnum? i)
(if ($fx>= i 0)
(if ($fx<= i ($port-output-size p))
($set-port-output-index! p i)
(error 'set-port-output-index! "index ~s is too big" i))
(error 'set-port-output-index! "index ~s is negative" i))
(error 'set-port-output-index! "~s is not a valid index" i))
(error 'set-port-output-index! "~s is not an output-port" p))))
;;;
(primitive-set! '$set-port-output-size!
(lambda (p i)
($set-port-output-index! p 0)
($set-port-output-size! p i)))
;;;
(primitive-set! 'set-port-output-size!
(lambda (p i)
(if (output-port? p)
(if (fixnum? i)
(if ($fx>= i 0)
(if ($fx<= i ($string-length ($port-output-buffer p)))
(begin
($set-port-output-index! p 0)
($set-port-output-size! p i))
(error 'set-port-output-size! "size ~s is too big" i))
(error 'set-port-output-size! "size ~s is negative" i))
(error 'set-port-output-size! "~s is not a valid size" i))
(error 'set-port-output-size! "~s is not an output-port" p)))))
(let ()
;;; IO PRIMITIVES
;;;
(primitive-set! '$write-char
(lambda (c p)
(let ([idx ($port-output-index p)])
(if ($fx< idx ($port-output-size p))
(begin
($string-set! ($port-output-buffer p) idx c)
($set-port-output-index! p ($fxadd1 idx)))
(($port-handler p) 'write-char c p)))))
;;;
(primitive-set! 'write-char
(case-lambda
[(c)
(if (char? c)
($write-char c (current-output-port))
(error 'write-char "~s is not a character" c))]
[(c p)
(if (char? c)
(if (output-port? p)
($write-char c p)
(error 'write-char "~s is not an output-port" p))
(error 'write-char "~s is not a character" c))]))
;;;
(primitive-set! 'newline
(case-lambda
[()
($write-char #\newline (current-output-port))
($flush-output-port (current-output-port))]
[(p)
(if (output-port? p)
(begin
($write-char #\newline p)
($flush-output-port p))
(error 'newline "~s is not an output port" p))]))
;;;
(primitive-set! 'port-name
(lambda (p)
(if (port? p)
(($port-handler p) 'port-name p)
(error 'port-name "~s is not a port" p))))
(primitive-set! 'input-port-name port-name)
(primitive-set! 'output-port-name port-name)
(primitive-set! '$read-char
(lambda (p)
(let ([idx ($port-input-index p)])
(if ($fx< idx ($port-input-size p))
(begin
($set-port-input-index! p ($fxadd1 idx))
($string-ref ($port-input-buffer p) idx))
(begin
(($port-handler p) 'read-char p))))))
;;;
(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! '$unread-char
(lambda (c p)
(let ([idx ($fxsub1 ($port-input-index p))])
(if (and ($fx>= idx 0)
($fx< idx ($port-input-size p)))
(begin
($set-port-input-index! p idx)
($string-set! ($port-input-buffer p) idx c))
(($port-handler p) 'unread-char c p)))))
;;;
(primitive-set! 'unread-char
(case-lambda
[(c) (if (char? c)
($unread-char c (current-input-port))
(error 'unread-char "~s is not a character" c))]
[(c p)
(if (input-port? p)
(if (char? c)
($unread-char c p)
(error 'unread-char "~s is not a character" c))
(error 'unread-char "~s is not an input-port" p))]))
;;;
(primitive-set! '$peek-char
(lambda (p)
(let ([idx ($port-input-index p)])
(if ($fx< idx ($port-input-size p))
($string-ref ($port-input-buffer p) idx)
(($port-handler p) 'peek-char p)))))
;;;
(primitive-set! 'peek-char
(case-lambda
[() ($peek-char (current-input-port))]
[(p)
(if (input-port? p)
($peek-char p)
(error 'peek-char "~s is not an input-port" p))]))
;;;
(primitive-set! '$unread-char
(lambda (c p)
(let ([idx ($fxsub1 ($port-input-index p))])
(if (and ($fx>= idx 0)
($fx< idx ($port-input-size p)))
(begin
($set-port-input-index! p idx)
($string-set! ($port-input-buffer p) idx c))
(($port-handler p) 'unread-char c p)))))
;;;
(primitive-set! '$reset-input-port!
(lambda (p)
($set-port-input-size! p 0)))
;;;
(primitive-set! 'reset-input-port!
(case-lambda
[() ($reset-input-port! (current-input-port))]
[(p)
(if (input-port? p)
($reset-input-port! p)
(error 'reset-input-port! "~s is not an input-port" p))]))
;;;
(primitive-set! '$close-input-port
(lambda (p)
(($port-handler p) 'close-port p)))
;;;
(primitive-set! 'close-input-port
(case-lambda
[() ($close-input-port (current-input-port))]
[(p)
(if (input-port? p)
($close-input-port p)
(error 'close-input-port! "~s is not an input-port" p))]))
;;;
(primitive-set! '$close-output-port
(lambda (p)
(($port-handler p) 'close-port p)))
;;;
(primitive-set! 'close-output-port
(case-lambda
[() ($close-output-port (current-output-port))]
[(p)
(if (output-port? p)
($close-output-port p)
(error 'close-output-port "~s is not an output-port" p))]))
;;;
(primitive-set! '$flush-output-port
(lambda (p)
(($port-handler p) 'flush-output-port p)))
;;;
(primitive-set! 'flush-output-port
(case-lambda
[() ($flush-output-port (current-output-port))]
[(p)
(if (output-port? p)
($flush-output-port p)
(error 'flush-output-port "~s is not an output-port" p))])))
(let ()
;;; INPUT FILES
(include "message-case.ss")
(define make-input-file-handler
(lambda (fd port-name)
(let ((open? #t))
(lambda (msg . args)
(message-case msg args
[(read-char p)
(unless (input-port? p)
(error 'read-char "~s is not an input port" p))
(let ([idx ($port-input-index p)])
(if ($fx< idx ($port-input-size p))
(begin
($set-port-input-index! p ($fxadd1 idx))
($string-ref ($port-input-buffer p) idx))
(if open?
(let ([bytes
(foreign-call "ikrt_read" fd
($port-input-buffer p))])
(cond
[(not bytes)
(error 'read-char "Cannot read from ~s" port-name)]
[($fx= bytes 0)
(eof-object)]
[else
($set-port-input-size! p bytes)
($read-char p)]))
(error 'read-char "port ~s is closed" p))))]
[(peek-char p)
(unless (input-port? p)
(error 'peek-char "~s is not an input port" p))
(let ([idx ($port-input-index p)])
(if ($fx< idx ($port-input-size p))
($string-ref ($port-input-buffer p) idx)
(if open?
(let ([bytes
(foreign-call "ikrt_read" fd
(port-input-buffer p))])
(cond
[(not bytes)
(error 'peek-char
"Cannot read from ~s" port-name)]
[($fx= bytes 0)
(eof-object)]
[else
($set-port-input-size! p bytes)
($peek-char p)]))
(error 'peek-char "port ~s is closed" p))))]
[(unread-char c p)
(unless (input-port? p)
(error 'unread-char "~s is not an input port" p))
(let ([idx ($fxsub1 ($port-input-index p))])
(if (and ($fx>= idx 0)
($fx< idx ($port-input-size p)))
(begin
($set-port-input-index! p idx)
($string-set! ($port-input-buffer p) idx c))
(if open?
(error 'unread-char "port ~s is closed" p)
(error 'unread-char "too many unread-chars"))))]
[(port-name p) port-name]
[(close-port p)
(unless (input-port? p)
(error 'close-input-port "~s is not an input port" p))
(when open?
($set-port-input-size! p 0)
(set! open? #f)
(unless (foreign-call "ikrt_close_file" fd)
(error 'close-input-port "cannot close ~s" port-name)))]
[else
(error 'input-file-handler
"message not handled ~s" (cons msg args))])))))
(define open-input-file
(lambda (filename)
(let ([fd/error (foreign-call "ikrt_open_input_file" filename)])
(if (fixnum? fd/error)
(let ([port (make-input-port
(make-input-file-handler fd/error filename)
(make-string 4096))])
(set-port-input-size! port 0)
port)
(error 'open-input-file "cannot open ~s: ~a" filename fd/error)))))
(primitive-set! '*standard-input-port*
(let ([p (make-input-port
(make-input-file-handler 0 '*stdin*)
(make-string 4096))])
(set-port-input-size! p 0)
p))
(primitive-set! 'console-input-port (lambda () *standard-input-port*))
(primitive-set! '*current-input-port* *standard-input-port*)
(primitive-set! 'current-input-port
(case-lambda
[() *current-input-port*]
[(p)
(if (input-port? p)
(primitive-set! '*current-input-port* p)
(error 'current-input-port "~s is not an input-port" p))]))
(primitive-set! 'open-input-file
(lambda (filename)
(if (string? filename)
(open-input-file filename)
(error 'open-input-file "~s is not a string" filename)))))
(let ()
;;; OUTPUT FILES
(include "message-case.ss")
(define do-write-buffer
(lambda (fd port-name p caller)
(let ([bytes (foreign-call "ikrt_write_file"
fd
(port-output-buffer p)
(port-output-index p))])
(if (fixnum? bytes)
(set-port-output-index! p 0)
(error caller "cannot write to file ~s: ~a" port-name bytes)))))
(define make-output-file-handler
(lambda (fd port-name)
(define open? #t)
(define output-file-handler
(lambda (msg . args)
(message-case msg args
[(write-char c p)
(if (char? c)
(if (output-port? p)
(let ([idx ($port-output-index p)])
(if ($fx< idx ($port-output-size p))
(begin
($string-set! ($port-output-buffer p) idx c)
($set-port-output-index! p ($fxadd1 idx)))
(if open?
(begin
(do-write-buffer fd port-name p 'write-char)
($write-char c p))
(error 'write-char "port ~s is closed" p))))
(error 'write-char "~s is not an output-port" p))
(error 'write-char "~s is not a character" c))]
[(flush-output-port p)
(if (output-port? p)
(if open?
(do-write-buffer fd port-name p 'flush-output-port)
(error 'flush-output-port "port ~s is closed" p))
(error 'flush-output-port "~s is not an output-port" p))]
[(close-port p)
(when open?
(flush-output-port p)
($set-port-output-size! p 0)
(set! open? #f)
(unless (foreign-call "ikrt_close_file" fd)
(error 'close-output-port "cannot close ~s" port-name)))]
[(port-name p) port-name]
[else (error 'output-file-handler
"unhandled message ~s" (cons msg args))])))
output-file-handler))
(define (option-id x)
(case x
[(error) 0]
[(replace) 1]
[(truncate) 2]
[(append) 3]
[else (error 'open-output-file "~s is not a valid mode" x)]))
(define open-output-file
(lambda (filename options)
(let ([fd/error
(foreign-call "ikrt_open_output_file"
filename
(option-id options))])
(if (fixnum? fd/error)
(make-output-port
(make-output-file-handler fd/error filename)
(make-string 4096))
(error 'open-output-file "cannot open ~s: ~a" filename fd/error)))))
(primitive-set! '*standard-output-port*
(make-output-port
(make-output-file-handler 1 '*stdout*)
(make-string 4096)))
(primitive-set! '*current-output-port* *standard-output-port*)
(primitive-set! '*standard-error-port*
(make-output-port
(make-output-file-handler 2 '*stderr*)
(make-string 4096)))
(primitive-set! 'standard-output-port
(lambda () *standard-output-port*))
(primitive-set! 'standard-error-port
(lambda () *standard-error-port*))
(primitive-set! 'console-output-port
(lambda () *standard-output-port*))
(primitive-set! 'current-output-port
(case-lambda
[() *current-output-port*]
[(p)
(if (output-port? p)
(primitive-set! '*current-output-port* p)
(error 'current-output-port "~s is not an output port" p))]))
(primitive-set! 'open-output-file
(case-lambda
[(filename)
(if (string? filename)
(open-output-file filename 'error)
(error 'open-output-file "~s is not a string" filename))]
[(filename options)
(if (string? filename)
(open-output-file filename options)
(error 'open-output-file "~s is not a string" filename))])))
(let ()
(include "message-case.ss")
;;; OUTPUT STRINGS
(define string-copy
(lambda (s)
(substring s 0 (string-length s))))
(define concat
(lambda (str i ls)
(let ([n (sum i ls)])
(let ([outstr ($make-string n)])
(let f ([n (copy outstr str i n)] [ls ls])
(if (null? ls)
outstr
(let ([a ($car ls)])
(f (copy outstr a ($string-length a) n) ($cdr ls)))))))))
(define sum
(lambda (ac ls)
(cond
[(null? ls) ac]
[else (sum ($fx+ ac ($string-length ($car ls))) ($cdr ls))])))
(define copy
(lambda (dst src n end)
(let f ([di end]
[si n])
(cond
[($fx= si 0) di]
[else
(let ([di ($fxsub1 di)] [si ($fxsub1 si)])
($string-set! dst di ($string-ref src si))
(f di si))]))))
(define make-output-string-handler
(lambda ()
(define buffer-list '())
(define open? #t)
(define output-handler
(lambda (msg . args)
(message-case msg args
[(write-char c p)
(if (char? c)
(if (output-port? p)
(let ([idx ($port-output-index p)])
(if ($fx< idx ($port-output-size p))
(begin
($string-set! ($port-output-buffer p) idx c)
($set-port-output-index! p ($fxadd1 idx)))
(if open?
(begin
(set! buffer-list
(cons (string-copy (port-output-buffer p))
buffer-list))
($set-port-output-size! p
($string-length ($port-output-buffer p)))
($write-char c p))
(error 'write-char "port ~s is closed" p))))
(error 'write-char "~s is not an output-port" p))
(error 'write-char "~s is not a character" c))]
[(flush-output-port p)
(void)]
[(close-port p)
(set! open? #f)]
[(port-name p) 'string-port]
[(get-output-string p)
(concat ($port-output-buffer p)
($port-output-index p)
buffer-list)]
[else (error 'output-handler
"unhandled message ~s" (cons msg args))])))
output-handler))
(primitive-set! 'open-output-string
(lambda ()
(make-output-port
(make-output-string-handler)
(make-string 10))))
(primitive-set! 'get-output-string
(lambda (p)
(if (output-port? p)
(($port-handler p) 'get-output-string p)
(error 'get-output-string "~s is not an output port" p))))
)
(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)
(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 (open-input-file name)]
[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)
(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 (open-input-file name)]
[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))))))

BIN
src/libcollect.fasl
View File

Binary file not shown.

3035
src/libcompile-6.4.ss Normal file
View File

File diff suppressed because it is too large Load Diff

3435
src/libcompile-6.5.ss Normal file
View File

File diff suppressed because it is too large Load Diff

3446
src/libcompile-6.6.ss Normal file
View File

File diff suppressed because it is too large Load Diff

3660
src/libcompile-6.7.ss Normal file
View File

File diff suppressed because it is too large Load Diff

3677
src/libcompile-8.1.ss Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
src/libcontrol.fasl
View File

Binary file not shown.

1664
src/libcore-6.9.ss Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
src/libcore.fasl
View File

Binary file not shown.

BIN
src/libcxr.fasl
View File

Binary file not shown.

BIN
src/libexpand.fasl
View File

Binary file not shown.

67
src/libfasl-6.0.ss
View File

@ -1,4 +1,3 @@
;;; not finished yet
;;; FASL
;;;
@ -20,7 +19,10 @@
;;; "V" + 4-bytes(n) + object ... : a vector of length n followed by n
;;; objects
;;; "S" + 4-bytes(n) + char ... : a string
;;; "M" + object + object : a symbol with name field and a unique-name field
;;; "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
;;;
@ -41,7 +43,6 @@
(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)
@ -86,11 +87,11 @@
(f x (fxadd1 i) n)]))]
[(gensym? x)
(write-char #\G p)
(do-write (gensym->unique-name x) p h
(do-write (symbol->string x) p h m))]
(fasl-write (gensym->unique-string x) p h
(fasl-write (symbol->string x) p h m))]
[(symbol? x)
(write-char #\M p)
(do-write (symbol->string x) p h m)]
(fasl-write (symbol->string x) p h m)]
[(code? x)
(write-char #\X p)
(let ([code-vec (code-code-vec x)]
@ -132,6 +133,36 @@
(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)
@ -153,7 +184,7 @@
(write-char #\< p)
(write-int (fx- 0 mark) p)
m]))]
[else (error 'fasl-write "BUG: not in hash table")])))
[else (error 'fasl-write "BUG: not in hash table ~s" x)])))
(define make-graph
(lambda (x h)
(unless (immediate? x)
@ -172,7 +203,9 @@
(unless (fx= i n)
(make-graph (vector-ref x i) h)
(f x (fxadd1 i) n)))]
[(symbol? x) (void)]
[(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)])
@ -188,6 +221,24 @@
(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)

217
src/libfasl-6.6.ss Normal file
View File

@ -0,0 +1,217 @@
;;; 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)])))

217
src/libfasl-6.7.ss Normal file
View File

@ -0,0 +1,217 @@
;;; 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-fixnum (code-freevars 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)])))

45
src/libhandlers-6.9.ss Normal file
View File

@ -0,0 +1,45 @@
(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")))
(primitive-set! 'top-level-value-error
(lambda (x)
(cond
[(symbol? x)
(if (top-level-bound? x)
(error 'top-level-value "BUG in ~s" x)
(error 'top-level-value "~s is unbound" x))]
[else
(error 'top-level-value "~s is not a symbol" x)])))
(primitive-set! 'car-error
(lambda (x)
(error 'car "~s is not a pair" x)))
(primitive-set! 'cdr-error
(lambda (x)
(error 'cdr "~s is not a pair" x)))

BIN
src/libhandlers.fasl
View File

Binary file not shown.

15
src/libhash-6.2.ss
View File

@ -91,6 +91,8 @@
($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))])
@ -98,7 +100,6 @@
(let ([n ($vector-ref vec idx)])
($set-tcbucket-next! b n)
($vector-set! vec idx b)
($set-tcbucket-tconc! b (get-tc h))
(void))))))))
(define get-hash
@ -129,9 +130,15 @@
($set-tcbucket-val! b v)
(void))]
[else
($vector-set! vec idx
($make-tcbucket (get-tc h) x v
($vector-ref vec idx)))
(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 ([ct (get-count h)])
(set-count! h ($fxadd1 ct))
(when ($fx> ct ($vector-length vec))

14
src/libintelasm-6.0.ss
View File

@ -375,13 +375,13 @@
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 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

920
src/libintelasm-6.4.ss Normal file
View File

@ -0,0 +1,920 @@
;;;
;;; 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*)
)

932
src/libintelasm-6.6.ss Normal file
View File

@ -0,0 +1,932 @@
;;;
;;; 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*)
)

887
src/libintelasm-6.9.ss Normal file
View File

@ -0,0 +1,887 @@
;;;
;;; 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 with-args
; (lambda (ls f)
; (apply f (cdr ls))))
(define-syntax with-args
(syntax-rules (lambda)
[(_ x (lambda (a0 a1) b b* ...))
(let ([t x])
(if (pair? t)
(let ([t ($cdr t)])
(if (pair? t)
(let ([a0 ($car t)] [t ($cdr t)])
(if (pair? t)
(let ([a1 ($car t)])
(if (null? ($cdr t))
(let () b b* ...)
(error 'with-args "too many args")))
(error 'with-args "too few args")))
(error 'with-args "too few args")))
(error 'with-args "too few args")))]))
;(define byte
; (lambda (x)
; (cons 'byte (fxlogand x 255))))
(define-syntax byte
(syntax-rules ()
[(_ x) (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 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)))]
[(imm? i)
(CODE c (ModRM 2 d s (IMM32 i ac)))]
[else (error 'CODErri "invalid i=~s" i)])))
(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
(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 CODEdi
(lambda (c disp n ac)
(with-args disp
(lambda (a1 a2)
(cond
[(and (reg? a1) (reg? a2))
(error 'CODEdi "unsupported1")]
[(and (imm? a1) (reg? a2))
(CODErri c '/0 a2 a1 (IMM32 n ac))]
[(and (imm? a1) (imm? a2))
(error 'CODEdi "unsupported2")]
[else (error 'CODEdi "unhandled ~s" disp)])))))
(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 2)
(if (fx= (length args) 2)
(proc a ac (car args) (cadr args))
(error 'convert-instruction "incorrect args in ~s" a))]
[(fx= n 1)
(if (fx= (length args) 1)
(proc a ac (car args))
(error 'convert-instruction "incorrect args in ~s" a))]
[(fx= n 0)
(if (fx= (length args) 0)
(proc a ac)
(error 'convert-instruction "incorrect args in ~s" a))]
[else
(if (fx= (length args) n)
(apply proc a ac args)
(error 'convert-instruction "incorrect args in ~s" a))])))]
[else (error 'convert-instruction "unknown instruction in ~s" a)]))
;;; instr/null is for 1-byte instructions that take no arguments
;(define (instr/null code ac)
; (cons code ac))
;(define (instr/ir arg1 arg2 ac ircode)
; (CODE+r ircode arg2 (IMM32 arg1 ac)))
;
;(define (instr/im arg1 arg2 ac imcode)
; (error 'instr/im "not implemented"))
;
;(define (instr/rr arg1 arg2 ac rrcode)
; (CODErr rrcode arg1 arg2 ac))
;
;(define (instr/rm arg1 arg2 ac rmcode)
; (CODErd rmcode arg1 arg2 ac))
(define (instr/2 arg1 arg2 ac ircode imcode rrcode rmcode mrcode)
(cond
[(imm? arg1)
(cond
[(reg? arg2) (CODEri ircode arg2 arg1 ac)]
[(mem? arg2) (CODEdi imcode arg2 arg1 ac)]
[else (error 'instr/2 "invalid args ~s ~s" arg1 arg2)])]
[(reg? arg1)
(cond
[(reg? arg2) (CODErr rrcode arg1 arg2 ac)]
[(mem? arg2) (CODErd rmcode arg1 arg2 ac)]
[else (error 'instr/2 "invalid args ~s ~s" arg1 arg2)])]
[(mem? arg1)
(cond
[(reg? arg2) (CODErd mrcode arg2 arg1 ac)]
[else (error 'instr/2 "invalid args ~s ~s" arg1 arg2)])]
[else (error 'instr/2 "invalid args ~s ~s" arg1 arg2)]))
(module ()
(define who 'assembler)
(define (conditional-set c dst ac)
(cond
[(reg8? dst)
(CODE #x0F (CODE c (ModRM 3 '/0 dst ac)))]
[else (error who "invalid condition-set to ~s" dst)]))
(define (conditional-jump c dst ac)
(cond
[(imm? dst)
(CODE #x0F (CODE c (IMM32 dst ac)))]
[(label? dst)
(CODE #x0F (CODE c (cons (cons 'relative (label-name dst)) ac)))]
[else (error who "invalid conditional jump target ~s" dst)]))
(add-instructions instr ac
[(ret) (CODE #xC3 ac)]
[(cltd) (CODE #x99 ac)]
[(movl src dst) (instr/2 src dst ac #xB8 #xC7 #x89 #x89 #x8B)]
[(movb src dst)
(cond
[(and (imm8? src) (mem? dst)) (CODEdi8 #xC6 dst src 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
[(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)))]
[(and (reg? src) (reg? dst))
(CODE #x01 (ModRM 3 src dst ac))]
[(and (mem? src) (reg? dst))
(CODErd #x03 dst src ac)]
[else (error who "invalid ~s" instr)])]
[(subl src dst)
(cond
[(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)))]
[(and (reg? src) (reg? dst))
(CODE #x29 (ModRM 3 src dst ac))]
[(and (mem? src) (reg? dst))
(CODErd #x2B dst src ac)]
[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 (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? src) (reg? dst))
(CODE #x21 (ModRM 3 src dst ac))]
[(and (mem? src) (reg? dst))
(CODErd #x23 dst src ac)]
[else (error who "invalid ~s" instr)])]
[(orl src dst)
(cond
[(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)))]
[(and (reg? src) (reg? dst))
(CODE #x09 (ModRM 3 src dst ac))]
[(and (mem? src) (reg? dst))
(CODErd #x0B dst src ac)]
[else (error who "invalid ~s" instr)])]
[(xorl src dst)
(cond
[(and (reg? src) (reg? dst))
(CODE #x31 (ModRM 3 src dst ac))]
[(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)])]
[(jmp 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 target ~s" dst)])]
[(call 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 target ~s" dst)])]
[(seta dst) (conditional-set #x97 dst ac)]
[(setae dst) (conditional-set #x93 dst ac)]
[(setb dst) (conditional-set #x92 dst ac)]
[(setbe dst) (conditional-set #x96 dst ac)]
[(setg dst) (conditional-set #x9F dst ac)]
[(setge dst) (conditional-set #x9D dst ac)]
[(setl dst) (conditional-set #x9C dst ac)]
[(setle dst) (conditional-set #x9E dst ac)]
[(sete dst) (conditional-set #x94 dst ac)]
[(setna dst) (conditional-set #x96 dst ac)]
[(setnae dst) (conditional-set #x92 dst ac)]
[(setnb dst) (conditional-set #x93 dst ac)]
[(setnbe dst) (conditional-set #x97 dst ac)]
[(setng dst) (conditional-set #x9E dst ac)]
[(setnge dst) (conditional-set #x9C dst ac)]
[(setnl dst) (conditional-set #x9D dst ac)]
[(setnle dst) (conditional-set #x9F dst ac)]
[(setne dst) (conditional-set #x95 dst ac)]
[(ja dst) (conditional-jump #x87 dst ac)]
[(jae dst) (conditional-jump #x83 dst ac)]
[(jb dst) (conditional-jump #x82 dst ac)]
[(jbe dst) (conditional-jump #x86 dst ac)]
[(jg dst) (conditional-jump #x8F dst ac)]
[(jge dst) (conditional-jump #x8D dst ac)]
[(jl dst) (conditional-jump #x8C dst ac)]
[(jle dst) (conditional-jump #x8E dst ac)]
[(je dst) (conditional-jump #x84 dst ac)]
[(jna dst) (conditional-jump #x86 dst ac)]
[(jnae dst) (conditional-jump #x82 dst ac)]
[(jnb dst) (conditional-jump #x83 dst ac)]
[(jnbe dst) (conditional-jump #x87 dst ac)]
[(jng dst) (conditional-jump #x8E dst ac)]
[(jnge dst) (conditional-jump #x8C dst ac)]
[(jnl dst) (conditional-jump #x8D dst ac)]
[(jnle dst) (conditional-jump #x8F dst ac)]
[(jne dst) (conditional-jump #x85 dst ac)]
[(byte x)
(unless (byte? x) (error who "~s is not a byte" x))
(cons (byte x) ac)]
[(byte-vector x) (append (map (lambda (x) (byte x)) (vector->list x)) ac)]
[(int a) (IMM32 instr ac)]
[(label L)
(unless (symbol? L) (error who "label ~s is not a symbol" L))
(cons (cons 'label L) ac)]
[(label-address L)
(unless (symbol? L) (error who "label-address ~s is not a symbol" L))
(cons (cons 'label-addr L) ac)]
[(current-frame-offset)
(cons '(current-frame-offset) ac)]
[(nop) ac]
))
(define compute-code-size
(lambda (ls)
(fold (lambda (x ac)
(if (fixnum? x)
(fx+ ac 1)
(case (car x)
[(byte) (fx+ ac 1)]
[(word reloc-word reloc-word+ label-addr foreign-label
relative local-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 (optimize-local-jumps ls)
(define locals '())
(define g (gensym))
(for-each
(lambda (x)
(when (and (pair? x) (eq? (car x) 'label))
(putprop (cdr x) g 'local)
(set! locals (cons (cdr x) locals))))
ls)
(for-each
(lambda (x)
(when (and (pair? x)
(eq? (car x) 'relative)
(eq? (getprop (cdr x) g) 'local))
(set-car! x 'local-relative)))
ls)
(for-each (lambda (x) (remprop x g)) locals)
ls)
(define whack-instructions
(lambda (x ls)
(define f
(lambda (ls idx reloc)
(cond
[(null? ls) reloc]
[else
(let ([a (car ls)])
(if (fixnum? a)
(begin
(code-set! x idx a)
(f (cdr ls) (fxadd1 idx) reloc))
(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))]
[(local-relative 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)
(if (fixnum? 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 local-relative) ac]
[else (error 'compute-reloc-size "unknown instr ~s" x)])))
0
ls)))
(define whack-reloc
(lambda (code 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))]
[(local-relative)
(let ([loc (label-loc v)])
(let ([obj (car loc)] [disp (cdr loc)])
(unless (eq? obj code)
(error 'whack-reloc "local-relative differ"))
(let ([rel (fx- disp (fx+ idx 4))])
(code-set! code (fx+ idx 0) (fxlogand rel #xFF))
(code-set! code (fx+ idx 1) (fxlogand (fxsra rel 8) #xFF))
(code-set! code (fx+ idx 2) (fxlogand (fxsra rel 16) #xFF))
(code-set! code (fx+ idx 3) (fxlogand (fxsra rel 24) #xFF)))))]
[(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*)]
[ls* (map optimize-local-jumps 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 (foo reloc*)
(for-each (whack-reloc (car foo) (cdr foo)) reloc*))
(map cons code* 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*)
)

324
src/libinterpret-6.5.ss Normal file
View File

@ -0,0 +1,324 @@
;;; Changes:
;;; 6.5: handles letrec
;;; 6.1: adding case-lambda, dropping lambda
;;; 6.0: basic version working
;;;
;;; Expand : Scheme -> Core Scheme
;;;
;;; <CS> ::= (quote datum)
;;; | <gensym>
;;; | (if <CS> <CS> <CS>)
;;; | (set! <gensym> <CS>)
;;; | (begin <CS> <CS> ...)
;;; | (case-lambda (<FML> <CS>) (<FML> <CS>) ...)
;;; | (<prim> <CS> <CS> ...)
;;; | (primref <primname>)
;;; | (<CS> <CS> ...)
;;; <FML> ::= ()
;;; | <gensym>
;;; | (<gensym> . <FML>)
;;; <prim> ::= 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 'letrec)
(let ([bind* (car d)] [body* (cdr d)])
(if (null? bind*)
(C*->last (car body*) (cdr body*) env)
(let ([lhs* (map car bind*)] [rhs* (map cadr bind*)])
(let ([env (extend-env lhs* env)])
(let ([body* (C*->last (car body*) (cdr body*) env)]
[rhs* (C*->list (car rhs*) (cdr rhs*) env)]
[n (length lhs*)])
(lambda (renv)
(let ([v (make-vector n)])
(let ([renv (cons v renv)])
(let f ([i 0] [ls (rhs* renv)])
(if (null? ls)
(body* renv)
(begin
(vector-set! v i (car ls))
(f (fxadd1 i) (cdr ls))))))))
)))))]
[(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 '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))))

BIN
src/libinterpret.fasl
View File

Binary file not shown.

407
src/libio-6.9.ss Normal file
View File

@ -0,0 +1,407 @@
;;; 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))))))

BIN
src/libio.fasl
View File

Binary file not shown.

53
src/libnumerics-7.1.ss Normal file
View File

@ -0,0 +1,53 @@
(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)])))
)

254
src/librecord-6.4.ss Normal file
View File

@ -0,0 +1,254 @@
(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 rtd-symbol
(lambda (rtd)
($record-ref rtd 4)))
(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 set-rtd-symbol!
(lambda (rtd symbol)
($record-set! rtd 4 symbol)))
(define make-rtd
(lambda (name fields printer symbol)
(let ([rtd ($make-record $base-rtd 5)])
($record-set! rtd 0 name)
($record-set! rtd 1 (length fields))
($record-set! rtd 2 fields)
($record-set! rtd 3 printer)
($record-set! rtd 4 symbol)
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 (gensym name))))
(define record-type-name
(lambda (rtd)
(unless (rtd? rtd)
(error 'record-type-name "~s is not an rtd" rtd))
(rtd-name rtd)))
(define record-type-symbol
(lambda (rtd)
(unless (rtd? rtd)
(error 'record-type-symbol "~s is not an rtd" rtd))
(rtd-symbol rtd)))
(define record-type-field-names
(lambda (rtd)
(unless (rtd? rtd)
(error 'record-type-field-names "~s is not an rtd" rtd))
(rtd-fields rtd)))
(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-type-name record-type-name)
(primitive-set! 'record-type-symbol record-type-symbol)
(primitive-set! 'record-type-field-names record-type-field-names)
(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-type-descriptor 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 symbol))
(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)))
)

BIN
src/librecord.fasl
View File

Binary file not shown.

534
src/libsyncase-6.2.ss
View File

@ -1,534 +0,0 @@
;;; 6.2: initial syncase implementation
;;;
;;; Expand : Scheme -> Core Scheme
;;;
;;; <CS> ::= (quote datum)
;;; | <gensym>
;;; | (if <CS> <CS> <CS>)
;;; | (set! <gensym> <CS>)
;;; | (begin <CS> <CS> ...)
;;; | (letrec ([<gensym> <CS>] ...) <CS> <CS> ...)
;;; | (lambda <FMLS> <CS> <CS> ...)
;;; | (<prim> <CS> <CS> ...)
;;; | (#primitive| <primname>)
;;; | (<CS> <CS> ...)
;;; <FML> ::= ()
;;; | <gensym>
;;; | (<gensym> . <FML>)
;;; <prim> ::= void | memv | top-level-value | set-top-level-value!
;;; | primitive-set! | foreign-call | $apply
(let ([*stx* (make-record-type "*stx*" '(e marks ribcage))]
[*rib* (make-record-type "*rib*" '(sym* marks* lab*))]
[*top* (make-record-type "*top*" '())])
(define stx? (record-predicate *stx*))
(define make-stx (record-constructor *stx*))
(define stx-e (record-field-accessor *stx* 'e))
(define stx-marks (record-field-accessor *stx* 'marks))
(define stx-ribcage (record-field-accessor *stx* 'ribcage))
(define make-rib (record-constructor *rib*))
(define rib-sym* (record-field-accessor *rib* 'sym*))
(define rib-marks* (record-field-accessor *rib* 'marks*))
(define rib-lab* (record-field-accessor *rib* 'lab*))
(define *top-ribcage* ((record-constructor *top*)))
(define (top? x) (eq? x *top-ribcage*))
(define *syncase-macro* (gensym "*syncase-macro*"))
(define (build-data x) `(quote ,x))
(define (build-global-ref x) `(top-level-value ',x))
(define (build-lexical-ref x) x)
(define (build-app a d) `(,a . ,d))
(define (build-lambda fml* body)
(cond
[(and (pair? body) (eq? (car body) 'begin))
`(lambda ,fml* . ,(cdr body))]
[else
`(lambda ,fml* ,body)]))
(define (build-begin body*) `(begin . ,body*))
(define (build-void) `(void))
(define (build-if e0 e1 e2) `(if ,e0 ,e1 ,e2))
(define (build-foreign-call e e*) `(foreign-call ,e ,e*))
(define (id? x)
(and (stx? x)
(symbol? (stx-e x))))
(define (stx->datum x) ;;;; use strip
(cond
[(stx? x) (stx-e x)]
[else x]))
(define (stx-pair? x)
(and (stx? x)
(pair? (stx-e x))))
(define (strip x)
(cond
[(stx? x) (stx-e x)]
[else x]))
(define label? string?)
(define (eqmarks? m1* m2*)
(cond
[(null? m1*) (null? m2*)]
[(memq (car m1*) m2*) (eqmarks? (cdr m1*) (remq (car m1*) m2*))]
[else #f]))
(define (rib-lookup sym m* sym* m** lab*)
(and (pair? sym*)
(if (and (eq? sym (car sym*))
(eqmarks? m* (car m**)))
(car lab*)
(rib-lookup sym m* (cdr sym*) (cdr m**) (cdr lab*)))))
(define (ribcage-lookup sym m* rc)
(cond
[(pair? rc)
(let ([r (car rc)])
(cond
[(eq? r 'shift)
(ribcage-lookup sym (cdr m*) (cdr rc))]
[else
(or (rib-lookup sym m* (rib-sym* r) (rib-marks* r) (rib-lab* r))
(ribcage-lookup sym m* (cdr rc)))]))]
[(top? rc) #f]
[else (error "BUG1")]))
(define (resolve x)
(unless (id? x) (error "BUG2"))
(let ([sym (stx-e x)]
[m* (stx-marks x)]
[rc (stx-ribcage x)])
(or (ribcage-lookup sym m* rc) ; bound -> label
(getprop sym *syncase-macro*) ; top-level-macros -> pair
sym ; global -> symbol
)))
(define (remove-last ls)
(let ([d (cdr ls)])
(cond
[(null? d) '()]
[else (cons (car ls) (remove-last d))])))
(define (unshift rc)
(cond
[(pair? rc)
(if (eq? (car rc) 'shift)
(cdr rc)
(cons (car rc) (unshift (cdr rc))))]
[else (error "BUG3: missing shift")]))
(define (push-wrap m r x)
(cond
[(stx? x)
(let ([xm (stx-marks x)])
(cond
[(and (pair? xm) (eq? (car xm) #f))
(make-stx (stx-e x)
(append (remove-last m) (cdr xm))
(unshift (append r (stx-ribcage x))))]
[else
(make-stx (stx-e x)
(append m xm)
(append r (stx-ribcage x)))]))]
[else (make-stx x m r)]))
(define (push-subst sym* marks* lab* x)
(cond
[(stx? x)
(make-stx (stx-e x)
(stx-marks x)
(cons (make-rib sym* marks* lab*) (stx-ribcage x)))]
[else
(make-stx x
'()
(cons (make-rib sym* marks* lab*) '()))]))
(define (push-antimark x)
(cond
[(stx? x)
(make-stx (stx-e x)
(cons #f (stx-marks x))
(stx-ribcage x))]
[else (make-stx x (cons #f '()) '())]))
(define (push-mark m x)
(cond
[(stx? x)
(let ([m* (stx-marks x)])
(cond
[(and (pair? m*) (eq? (car m*) #f))
(make-stx (stx-e x) (cdr m*) (stx-ribcage x))]
[else
(make-stx (stx-e x) (cons m m*) (cons 'shift (stx-ribcage x)))]))]
[else
(make-stx x (list m) '(shift))]))
(define (push-rib rib x)
(cond
[(stx? x)
(make-stx (stx-e x) (stx-marks x) (cons rib (stx-ribcage x)))]
[else (make-stx x '() (list rib))]))
(define (expose-stx x)
(let ([e (stx-e x)])
(cond
[(pair? e)
(let ([m (stx-marks x)]
[r (stx-ribcage x)])
(cons
(push-wrap m r (car e))
(push-wrap m r (cdr e))))]
[(vector? e)
(let ([m (stx-marks x)]
[r (stx-ribcage x)])
(list->vector
(map (lambda (x) (push-wrap m r x))
(vector->list e))))]
[(null? e) e]
[else x])))
(define (expose x)
(cond
[(stx? x) (expose-stx x)]
[else x]))
(define (expose-ls ox)
(let loop ([x (expose ox)])
(cond
[(pair? x) (cons (car x) (loop (expose (cdr x))))]
[(null? x) '()]
[else (error 'expose-ls "BUG: not a list: ~s" x)])))
(define (expose* x)
(cond
[(id? x) x]
[(stx? x) (expose* (expose x))]
[(pair? x) (cons (expose* (car x)) (expose* (cdr x)))]
[(vector? x)
(list->vector (map expose* (vector->list x)))]
[else x]))
(define (lookup lab r)
(define (lookup1 lab lab* g*)
(cond
[(null? lab*) #f]
[(eq? lab (car lab*)) (car g*)]
[else (lookup1 lab (cdr lab*) (cdr g*))]))
(cond
[(null? r) #f]
[(eq? (car r) 'lexical-barrier)
(let ([v (lookup lab (cdr r))])
(cond
[(not (symbol? v)) v]
[else #f]))]
[else
(or (lookup1 lab (caar r) (cdar r))
(lookup lab (cdr r)))]))
(define (genmark) (gensym "M"))
(define (newsym x)
(gensym))
;(gensym (symbol->string x)))
(define (apply-macro proc x r)
(expand-ctx (push-mark (genmark) (proc (push-antimark x))) r))
(define (identifier-macro? x r)
(and (id? x)
(let ([a (resolve x)])
(or (and (label? a)
(let ([a (lookup a r)])
(and (procedure? a) a)))
(and (pair? a)
(eq? (car a) '*user-macro*)
(cdr a))))))
(define (macro-call? x r)
(if (id? x)
(identifier-macro? x r)
(let ([x (expose x)])
(and (pair? x)
(identifier-macro? (car x) r)))))
(define (core? x)
(and (pair? x) (eq? (car x) '*core-macro*)))
(define (apply-core-form a d ctx r)
(unless (core? a) (syntax-error ctx))
((cdr a) a d ctx r))
(define (E* d r ctx)
(let ([d (expose-ls d)])
(map (lambda (x) (E x r)) d)))
(define (extend-core name proc)
(putprop name *syncase-macro* (cons '*core-macro* proc)))
(define (extend-user-macro name proc)
(putprop name *syncase-macro* (cons '*user-macro* proc)))
(define (E ctx r)
(let ([x (expose ctx)])
(cond
[(macro-call? x r) =>
(lambda (proc)
(apply-macro proc ctx r))]
[(pair? x)
(let ([a (car x)] [d (cdr x)])
(cond
[(id? a)
(let ([a (resolve a)])
(cond
[(label? a)
(cond
[(lookup a r) =>
(lambda (g)
(cond
[(symbol? g)
(build-app (build-lexical-ref g)
(E* d r ctx))]
[(and (pair? g) (eq? (car g) 'pat))
(syntax-error ctx)]
[else (error 'expand "BUG4")]))]
[else (syntax-error ctx)])]
[(core? a)
(apply-core-form a d ctx r)]
[(symbol? a)
(build-app (build-global-ref a)
(E* d r ctx))]
[else (syntax-error ctx)]))]
[else
(build-app
(E a r)
(E* d r ctx))]))]
[(id? x)
(let ([a (resolve x)])
(cond
[(label? a)
(cond
[(lookup a r) =>
(lambda (g)
(cond
[(symbol? g) (build-lexical-ref g)]
[(and (pair? g) (eq? (car g) 'pat))
(syntax-error ctx)]
[else (error 'expand "BUG5")]))]
[else (syntax-error ctx)])]
[(core? a) (syntax-error ctx)]
[(symbol? a)
(build-global-ref a)]
[else (syntax-error ctx)]))]
[else (build-data (strip x))])))
(define (core-expand x)
(E (make-stx x '() *top-ribcage*) '()))
(define (process-fml* bind* ctx)
(define (assert-no-dups s m* s* m**)
(unless (null? s*)
(when (and (eq? s (car s*))
(eqmarks? m* (car m**)))
(syntax-error ctx))
(assert-no-dups s m* (cdr s*) (cdr m*))))
(let loop ([bind* (expose bind*)])
(cond
[(null? bind*) (values '() '() '() '() '())]
[(pair? bind*)
(let ([b (car bind*)])
(unless (id? b) (syntax-error ctx))
(let-values ([(fml* s* m** g* lab*)
(loop (expose (cdr bind*)))])
(let ([s (stx-e b)] [m* (stx-marks b)])
(assert-no-dups s m* s* m**)
(let ([lab (string #\i)] [g (newsym s)])
(values (cons g fml*)
(cons s s*)
(cons m* m**)
(cons g g*)
(cons lab lab*))))))]
[else (syntax-error ctx)])))
(define (top-level-macro? x r sym)
(let ([x (expose x)])
(and (pair? x)
(id? (car x))
(let ([loc (resolve (car x))])
(and (or (and (pair? loc)
(eq? (car loc) '*core-macro*))
(symbol? loc))
(eq? (stx->datum (car x)) sym))))))
(define (define? x r)
(top-level-macro? x r 'define))
(define (begin? x r)
(top-level-macro? x r 'begin))
(define (begin-e* x ctx)
(let ([x (expose x)])
(let loop ([x (expose (cdr x))])
(cond
[(null? x) '()]
[(pair? x) (cons (car x) (loop (expose (cdr x))))]
[else (syntax-error ctx)]))))
(define (expand-body* body* ctx r)
(let ([rib (make-rib '() '() '())])
(let loop ([body* (expose (push-rib rib body*))]
[r r]
[lab* '()] [sym* '()] [marks* '()] [vrhs* '()])
(cond
[(null? body*) (syntax-error ctx)]
[(pair? body*)
(let ([a (car body*)] [d (cdr body*)])
(cond
[(macro-call? a r) =>
(lambda (proc)
(loop (cons (push-mark (genmark) (proc (push-antimark a))) d)
r lab* sym* marks* vrhs*))]
[(define? a r)
(let-values ([(lhs rhs) (extract-define a ctx)])
(loop (expose d)
r
(cons (string #\p) lab*)
(cons (stx-e lhs) sym*)
(cons (stx-marks lhs) marks*)
(cons rhs vrhs*)))]
[(begin? a r)
(loop (expose (append (begin-e* a ctx) d))
r lab* sym* marks* vrhs*)]
[else
;;; done
(cond
[(null? sym*)
(let ([body* (E* body* r ctx)])
(build-begin body*))]
[else
(let ([g* (map newsym sym*)])
(let* ([r (cons (cons lab* g*) r)]
[rhs*
(E* (push-subst sym* marks* lab* vrhs*)
r ctx)]
[body*
(E* (push-subst sym* marks* lab* body*)
r ctx)])
(build-letrec g* rhs* (build-begin body*))))])]))]
[else (syntax-error ctx)]))))
(define (extract-bindings bind* ctx)
(let ([bind* (expose bind*)])
(cond
[(null? bind*) (values '() '())]
[(not (pair? bind*)) (syntax-error ctx)]
[else
(let ([a (car bind*)] [d (cdr bind*)])
(let ([a (expose-ls a)])
(cond
[(fx= (length a) 2)
(let-values ([(lhs* rhs*)
(extract-bindings d ctx)])
(values (cons (car a) lhs*)
(cons (cadr a) rhs*)))]
[else (syntax-error ctx)])))])))
(define (core-stx x)
(make-stx x '() *top-ribcage*))
(extend-core 'quote
(lambda (a d ctx r)
(let ([d (expose-ls d)])
(cond
[(and (list? d) (fx= (length d) 1))
(build-data (strip (car d)))]
[else (syntax-error ctx)]))))
(extend-core 'lambda
(lambda (a d ctx r)
(let ([d (expose d)])
(cond
[(pair? d)
(let ([fml* (car d)] [body* (cdr d)])
(let-values ([(fml* s* m** g* lab*)
(process-fml* fml* ctx)])
(let ([body* (push-subst s* m** lab* body*)])
(let ([r (cons (cons lab* g*) r)])
(build-lambda fml*
(expand-body* body* ctx r))))))]
[else (syntax-error ctx)]))))
(extend-core 'if
(lambda (a d ctx r)
(let ([d (expose d)])
(unless (pair? d) (syntax-error ctx))
(let ([test (car d)] [d (expose (cdr d))])
(unless (pair? d) (syntax-error ctx))
(let ([conseq (car d)] [d (expose (cdr d))])
(let ([altern
(cond
[(null? d) (build-void)]
[(pair? d)
(let ([altern (car d)] [d (expose (cdr d))])
(cond
[(null? d) (E altern r)]
[else (syntax-error ctx)]))]
[else (syntax-error ctx)])])
(build-if (E test r) (E conseq r) altern)))))))
(extend-core 'begin
(lambda (a d ctx r)
(let ([d (expose-ls d)])
(when (null? d) (syntax-error ctx))
(build-begin (E* d r ctx)))))
(extend-core 'define
(lambda (a d ctx r) (syntax-error ctx)))
(extend-core 'foreign-call
(lambda (a d ctx r)
(let ([d (expose-ls d)])
(unless (fx>= (length d) 1) (syntax-error ctx))
(build-foreign-call
(E (car d) r)
(E* (cdr d) r ctx)))))
(extend-core 'let
(lambda (a d ctx r)
(let ([d (expose d)])
(unless (pair? d) (syntax-error ctx))
(let ([bind* (car d)] [body* (cdr d)])
(let-values ([(lhs* rhs*)
(extract-bindings bind* ctx)])
(let ([lambda^ (core-stx 'lambda)])
(E `((,lambda^ ,lhs* . ,body*) . ,rhs*) r)))))))
(extend-core 'let*
(lambda (a d ctx r)
(let ([d (expose d)])
(unless (pair? d) (syntax-error ctx))
(let ([bind* (car d)] [body* (cdr d)])
(let-values ([(lhs* rhs*)
(extract-bindings bind* ctx)])
(let ([lambda^ (core-stx 'lambda)])
(E (let f ([lhs* lhs*] [rhs* rhs*])
(cond
[(null? lhs*)
`((,lambda^ () . ,body*))]
[else
`((,lambda^ (,(car lhs*))
,(f (cdr lhs*) (cdr rhs*)))
,(car rhs*))]))
r)))))))
(set! expand core-expand)
)

BIN
src/libtokenizer.fasl
View File

Binary file not shown.

61
src/libtoplevel-6.9.ss Normal file
View File

@ -0,0 +1,61 @@
(for-each
(lambda (x)
($set-symbol-value! x (primitive-ref x)))
(public-primitives))
(let ()
(define add-prim
(lambda (x)
(let ([g (gensym (symbol->string x))])
(putprop x '|#system| g)
(putprop g '*sc-expander* (cons 'core-primitive x)))))
(for-each add-prim (public-primitives))
(for-each add-prim (system-primitives)))
(for-each
(lambda (x)
(cond
[(getprop x '*sc-expander*) =>
(lambda (p)
(let ([g (gensym (symbol->string x))])
(putprop x '|#system| g)
(putprop g '*sc-expander* p)))]
[(getprop x '|#system|) =>
(lambda (g)
(let ([p (getprop g '*sc-expander*)])
(putprop x '*sc-expander* p)))]
[else (error #f "~s is not a macro" x)]))
(macros))
(let ([gsys (gensym "#system")] [gsch (gensym "*scheme*")])
(define (make-stx x)
(vector 'syntax-object x
(list '(top)
(vector 'ribcage
(vector x)
(vector '(top))
(vector (getprop x '|#system|))))))
(define (make-module stx* name)
`($module . #(interface (top) ,(list->vector stx*) ,name)))
(putprop '|#system| '|#system| gsys)
(putprop 'scheme '|#system| gsch)
(putprop 'scheme '*scheme* gsch)
(let* ([schls (append '(scheme) (public-primitives) (macros))]
[sysls (append '(|#system|) (system-primitives) schls)])
(let ([sysmod (make-module (map make-stx sysls) '|#system|)]
[schmod (make-module (map make-stx schls) '*scheme*)])
(for-each
(lambda (x)
(putprop x '*scheme* (getprop x '|#system|)))
schls)
(putprop gsch '*sc-expander* schmod)
(putprop gsys '*sc-expander* sysmod)
(putprop '|#system| '*sc-expander* sysmod)
(putprop 'scheme '*sc-expander* schmod))))
(begin
(printf "Petite Ikarus Scheme (Build ~a)\n" (compile-time-date-string))
(display "Copyright (c) 2006 Abdulaziz Ghuloum\n\n")
(current-eval compile)
(new-cafe))

BIN
src/libtoplevel.fasl
View File

Binary file not shown.

89
src/libtrace-6.9.ss Normal file
View File

@ -0,0 +1,89 @@
(let ()
(define k* '())
(define display-prefix
(lambda (ls t)
(unless (null? ls)
(display (if t "|" " "))
(display-prefix (cdr ls) (not t)))))
(define display-trace
(lambda (k* v)
(display-prefix k* #t)
(write v)
(newline)))
(define make-traced-procedure
(lambda (name proc)
(lambda args
(call/cf
(lambda (f)
(cond
[(memq f k*) =>
(lambda (ls)
(display-trace ls (cons name args))
(apply proc args))]
[else
(display-trace (cons 1 k*) (cons name args))
(dynamic-wind
(lambda () (set! k* (cons f k*)))
(lambda ()
(let ([v
(call/cf
(lambda (nf)
(set! f nf)
(set-car! k* nf)
(apply proc args)))])
(display-trace k* v)
v))
(lambda () (set! k* (cdr k*))))]))))))
(define traced-symbols '())
(define trace-symbol!
(lambda (s)
(cond
[(assq s traced-symbols) =>
(lambda (pr)
(let ([a (cdr pr)] [v (top-level-value s)])
(unless (eq? (cdr a) v)
(unless (procedure? v)
(error 'trace
"the top-level value of ~s is ~s (not a procedure)"
s v))
(let ([p (make-traced-procedure s v)])
(set-car! a v)
(set-cdr! a p)
(set-top-level-value! s p)))))]
[else
(unless (top-level-bound? s)
(error 'trace "~s is unbound" s))
(let ([v (top-level-value s)])
(unless (procedure? v)
(error 'trace "the top-level value of ~s is ~s (not a procedure)"
s v))
(let ([p (make-traced-procedure s v)])
(set! traced-symbols
(cons (cons s (cons v p)) traced-symbols))
(set-top-level-value! s p)))])))
(define untrace-symbol!
(lambda (s)
(define loop
(lambda (ls)
(cond
[(null? ls) '()]
[(eq? s (caar ls))
(let ([a (cdar ls)])
(when (eq? (cdr a) (top-level-value s))
(set-top-level-value! s (car a)))
(cdr ls))]
[else (cons (car ls) (loop (cdr ls)))])))
(set! traced-symbols (loop traced-symbols))))
(primitive-set! 'make-traced-procedure make-traced-procedure)
(primitive-set! 'trace-symbol! trace-symbol!)
(primitive-set! 'untrace-symbol! untrace-symbol!))

9
src/libwriter-6.2.ss
View File

@ -308,13 +308,15 @@
(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)))
(formatter 'fprintf port fmt args)
(flush-output-port port)))
(define printf
(lambda (fmt . args)
(unless (string? fmt)
(error 'printf "~s is not a string" fmt))
(formatter 'printf (current-output-port) fmt args)))
(formatter 'printf (current-output-port) fmt args)
(flush-output-port (current-output-port))))
(define format
(lambda (fmt . args)
@ -369,5 +371,6 @@
(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)))
)

BIN
src/libwriter.fasl
View File

Binary file not shown.

24
src/message-case.ss Normal file
View File

@ -0,0 +1,24 @@
(define-syntax message-case
(syntax-rules (else)
[(_ msg args
[(msg-name msg-arg* ...) b b* ...] ...
[else else1 else2 ...])
(let ([tmsg msg] [targs args])
(define-syntax match-and-bind
(syntax-rules ()
[(__ y () body)
(if (null? y)
body
(error 'message-case "unmatched ~s" (cons tmsg targs)))]
[(__ y (a a* (... ...)) body)
(if (pair? y)
(let ([a (car y)] [d (cdr y)])
(match-and-bind d (a* (... ...)) body))
(error 'message-case "unmatched ~s" (cons tmsg targs)))]))
(case tmsg
[(msg-name)
(match-and-bind targs (msg-arg* ...) (begin b b* ...))] ...
[else else1 else2 ...]))]))

BIN
src/petite-ikarus.fasl
View File

Binary file not shown.

4613
src/psyntax-7.1-6.5.ss Normal file
View File

File diff suppressed because it is too large Load Diff

4616
src/psyntax-7.1-6.8.ss Normal file
View File

File diff suppressed because it is too large Load Diff

4711
src/psyntax-7.1-6.9.ss Normal file
View File

File diff suppressed because it is too large Load Diff

28
src/psyntax-7.1.pp
View File

@ -5,7 +5,7 @@
(let ()
(define + fx+)
(define - fx-)
;(define - fx-)
(define * fx*)
(define quotient fxquotient)
(define modulo fxmodulo)
@ -970,7 +970,7 @@
(cons
(car m12278)
(f2277
(- n12279 '1)
(fx- n12279 '1)
(cdr m12278)))
(if (equal?
m12278
@ -3084,7 +3084,7 @@
(if t1893
t1893
(lp1891
(- i1892
(fx- i1892
'1))))
((lambda (id1894)
(help-bound-id=?432
@ -3125,7 +3125,7 @@
i1892)))
'#f))))
lp1891)
(- (vector-length
(fx- (vector-length
v1890)
'1)))
(interface-exports449
@ -4080,7 +4080,7 @@
(if (< i1704 '0)
ls1703
(do1702
(- i1704 '1)
(fx- i1704 '1)
(cons
(fn1701
(vector-ref
@ -4088,7 +4088,7 @@
i1704))
ls1703))))))
do1702)
(- (vector-length v1700) '1)
(fx- (vector-length v1700) '1)
'())))
(vfor-each483 (lambda (fn1696 v1695)
((lambda (len1697)
@ -6559,7 +6559,7 @@
(gen-ref1032
src1082
var1081
(- level1080 '1)
(fx- level1080 '1)
(cdr maps1079)))
(lambda (outer-var1084
outer-maps1083)
@ -9693,7 +9693,7 @@
'#(syntax-object (quote unquote) ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(isquote? islist? iscons? quote-nil? quasilist* quasicons quasiappend quasivector vquasi quasi) #((top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))
(quasi2757
p2804
(- lev2796
(fx- lev2796
'1)))
(vquasi2758
q2800
@ -9715,7 +9715,7 @@
'#(syntax-object (quote unquote-splicing) ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(isquote? islist? iscons? quote-nil? quasilist* quasicons quasiappend quasivector vquasi quasi) #((top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))
(quasi2757
p2808
(- lev2796
(fx- lev2796
'1)))
(vquasi2758
q2800
@ -9766,7 +9766,7 @@
'#(syntax-object (quote unquote) ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(isquote? islist? iscons? quote-nil? quasilist* quasicons quasiappend quasivector vquasi quasi) #((top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))
(quasi2757
(list p2776)
(- lev2772 '1)))))
(fx- lev2772 '1)))))
tmp2775)
((lambda (tmp2777)
(if tmp2777
@ -9783,7 +9783,7 @@
'#(syntax-object (quote unquote) ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(isquote? islist? iscons? quote-nil? quasilist* quasicons quasiappend quasivector vquasi quasi) #((top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))
(quasi2757
p2779
(- lev2772 '1)))
(fx- lev2772 '1)))
(quasi2757
q2778
lev2772))))
@ -9803,7 +9803,7 @@
'#(syntax-object (quote unquote-splicing) ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(isquote? islist? iscons? quote-nil? quasilist* quasicons quasiappend quasivector vquasi quasi) #((top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))
(quasi2757
p2784
(- lev2772
(fx- lev2772
'1)))
(quasi2757
q2783
@ -9935,7 +9935,7 @@
(lambda (d2960)
(qs2899
d2960
(- n2949 '1)
(fx- n2949 '1)
b*2948
(lambda (b*2962 dnew2961)
(k2947
@ -9961,7 +9961,7 @@
(lambda (d2967)
(qs2899
d2967
(- n2949 '1)
(fx- n2949 '1)
b*2948
(lambda (b*2969
dnew2968)

200
src/psyntax-7.1.ss
View File

@ -569,6 +569,10 @@
;(define-syntax fx>= (identifier-syntax >=))
(define annotation? (lambda (x) #f))
(define annotation-expression
(lambda (x) (error 'annotation-expression "not yet")))
(define annotation-stripped
(lambda (x) (error 'annotation-stripped "not yet")))
; top-level-eval-hook is used to create "permanent" code (e.g., top-level
; transformers), so it might be a good idea to compile it
@ -651,7 +655,7 @@
; (lambda (name) ; name is #f or a symbol
; (set! n (+ n 1))
; (string->symbol (string-append session-key (fmt n))))))))
;;; AZIZ
(define generate-id
(lambda (name)
(if name (gensym (symbol->string name)) (gensym))))
@ -740,6 +744,10 @@
[(_ ae vars exp)
`(case-lambda [,vars ,exp])]))
(define build-case-lambda
(lambda (ae vars* exp*)
`(case-lambda . ,(map list vars* exp*))))
;;; AZIZ
;;; (define built-lambda?
;;; (lambda (x)
@ -758,6 +766,15 @@
[(_ ae name) `(|#primitive| ,name)]
[(_ ae level name) `(|#primitive| ,name)]))
;;; AZIZ
(define-syntax build-foreign-call
(syntax-rules ()
[(_ ae name arg*) `(foreign-call ,name . ,arg*)]))
(define-syntax build-$apply
(syntax-rules ()
[(_ ae proc arg*) `($apply ,proc . ,arg*)]))
(define-syntax build-data
(syntax-rules ()
((_ ae exp) `',exp)))
@ -929,15 +946,16 @@
((procedure? b) (make-binding 'macro b))
((binding? b)
(and (case (binding-type b)
((core macro macro! deferred) (and (procedure? (binding-value b))))
((core macro macro! deferred)
(and (procedure? (binding-value b))))
(($module) (interface? (binding-value b)))
((lexical) (lexical-var? (binding-value b)))
((global meta-variable) (symbol? (binding-value b)))
((global meta-variable) (symbol? (binding-value b)))
((syntax) (let ((x (binding-value b)))
(and (pair? x)
(lexical-var? (car x))
(let ((n (cdr x)))
(and (integer? n) (exact? n) (fx>= n 0))))))
(and (fixnum? n) (fx>= n 0))))))
((begin define define-syntax set! $module-key $import eval-when meta) (null? (binding-value b)))
((local-syntax) (boolean? (binding-value b)))
((displaced-lexical) (eq? (binding-value b) #f))
@ -949,6 +967,7 @@
(syntax-rules (quote)
((_ 'type #f) '(type . #f))
((_ type value) (cons type value))))
(define binding-type car)
(define binding-value cdr)
(define set-binding-type! set-car!)
@ -2408,6 +2427,7 @@
(unless t (set! t (thunk)))
(top-level-eval-hook t))
(lambda () (or t (thunk)))))))
(define ct-eval/residualize3
(lambda (ctem eval-thunk residualize-thunk)
(if (memq 'E ctem)
@ -2545,6 +2565,9 @@
e w ae))))))
(_ (syntax-error (source-wrap e w ae))))))
(define chi-macro
(lambda (p e r w ae rib)
(define rebuild-macro-output
@ -3203,7 +3226,7 @@
,@(map (let ((r (map cons formals actuals)))
(lambda (x) (cdr (assq (cadr x) r))))
(cdr e))))
(else `(map (lambda ,formals ,e) ,@actuals))))))
(else `(map (case-lambda [,formals ,e]) ,@actuals))))))
; 12/12/00: semantic change: we now return original syntax object (e)
; if no pattern variables were found within, to avoid dropping
@ -3240,7 +3263,13 @@
((ref) (build-lexical-reference 'value no-source (cadr x)))
((primitive) (build-primref no-source (cadr x)))
((quote) (build-data no-source (cadr x)))
((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
((lambda)
(build-lambda no-source (cadr x) (regen (caddr x))))
((case-lambda)
(let ([d (cdr x)])
(build-case-lambda no-source
(map car d)
(map (lambda (x) (regen (cadr x))) d))))
((map) (let ((ls (map regen (cdr x))))
(build-application no-source
(if (fx= (length ls) 2)
@ -3271,6 +3300,28 @@
(syntax c) r mr w m?)))
(build-lambda ae vars body))))))
;;; AZIZ
(global-extend 'core 'case-lambda
(lambda (e r mr w ae m?)
(syntax-case e ()
[(_ c* ...)
(let-values ([(vars* body*)
(let f ([c* #'(c* ...)])
(syntax-case c* ()
[() (values '() '())]
[(c . c*)
(let-values ([(vars body)
(chi-lambda-clause
(source-wrap e w ae)
#'c r mr w m?)])
(let-values ([(vars* body*) (f #'c*)])
(values
(cons vars vars*)
(cons body body*))))]))])
(build-case-lambda ae vars* body*))])))
(global-extend 'core 'letrec
(lambda (e r mr w ae m?)
@ -3306,6 +3357,47 @@
(chi (syntax else) r mr w m?)))
(_ (syntax-error (source-wrap e w ae))))))
;;; AZIZ
(global-extend 'core 'foreign-call
(lambda (e r mr w ae m?)
(syntax-case e ()
[(_ proc arg* ...)
(build-foreign-call ae
(chi #'proc r mr w m?)
(let f ([arg* #'(arg* ...)])
(syntax-case arg* ()
[() '()]
[(a . arg*)
(cons (chi #'a r mr w m?)
(f #'arg*))])))]
[_ (syntax-error (source-wrap e w ae))])))
(global-extend 'core '$apply
(lambda (e r mr w ae m?)
(syntax-case e ()
[(_ proc arg* ...)
(build-$apply ae
(chi #'proc r mr w m?)
(let f ([arg* #'(arg* ...)])
(syntax-case arg* ()
[() '()]
[(a . arg*)
(cons (chi #'a r mr w m?)
(f #'arg*))])))]
[_ (syntax-error (source-wrap e w ae))])))
;;; AZIZ
(global-extend 'core 'type-descriptor
(lambda (e r mr w ae m?)
(syntax-case e ()
((_ id)
(id? (syntax id))
(let ((n (id-var-name (syntax id) w)))
(let ((b (lookup n r)))
(case (binding-type b)
(($rtd)
(build-data ae (binding-value b)))
(else (syntax-error (source-wrap e w ae)))))))
(_ (syntax-error (source-wrap e w ae))))))
(global-extend 'set! 'set! '())
@ -3755,8 +3847,17 @@
ctem rtem #f
(env-top-ribcage env))))))))
(primitive-set! 'current-expand
(make-parameter
sc-expand
(lambda (x)
(unless (procedure? x)
(error 'current-expand "~s is not a procedure" x))
x)))
(primitive-set! 'expand
(lambda (x)
((current-expand) x)))
(primitive-set! '$make-environment
(lambda (token mutable?)
@ -3977,7 +4078,7 @@
r))
(else (match* (unannotate e) p w r)))))
(set! $syntax-dispatch
(primitive-set! '$syntax-dispatch
(lambda (e p)
(cond
((eq? p 'any) (list e))
@ -4418,7 +4519,90 @@
(lambda () b b* ...)
swap))))])))
(define-syntax when
(syntax-rules ()
[(_ test b b* ...)
(if test
(begin b b* ...)
(void))]))
(define-syntax unless
(syntax-rules ()
[(_ test b b* ...)
(if test
(void)
(begin b b* ...))]))
(define-syntax let-values
(lambda (x)
(define (bindem n** v**)
(syntax-case n** ()
[() #'()]
[((n* ...) . n**)
(syntax-case v** ()
[((v* ...) . v**)
(with-syntax ([rest (bindem #'n** #'v**)])
#'([n* v*] ... . rest))])]))
(syntax-case x ()
[(_ ([(name** ...) v*] ...) b b* ...)
(let ([n**
(let f ([n** #'((name** ...) ...)])
(syntax-case n** ()
[() #'()]
[(n* . n**)
(with-syntax ([n* (generate-temporaries #'n*)]
[n** (f #'n**)])
#'(n* . n**))]))])
(let f ([t** n**] [v* #'(v* ...)])
(syntax-case t** ()
[((t* ...) . t**)
(syntax-case v* ()
[(v . v*)
(with-syntax ([body (f #'t** #'v*)])
#'(call-with-values
(lambda () v)
(lambda (t* ...) body)))])]
[()
(with-syntax ([bind* (bindem #'((name** ...) ...) n**)])
#'(let bind* b b* ...))])))])))
(define-syntax define-record
(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 "?")))]
[(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 constr (record-constructor 'rtd))
(define pred (record-predicate 'rtd))
(define getters (record-field-accessor 'rtd 'field*)) ...
(define setters (record-field-mutator 'rtd 'field*)) ...
)))])))

26
src/record-case.chez.ss Normal file
View File

@ -0,0 +1,26 @@
(define-syntax record-case
(lambda (x)
(define (enumerate fld* i)
(syntax-case fld* ()
[() #'()]
[(x . x*)
(with-syntax ([i i] [i* (enumerate #'x* (fx+ i 1))])
#'(i . i*))]))
(define (generate-body ctxt cls*)
(syntax-case cls* (else)
[() (with-syntax ([x x]) #'(error #f "unmatched ~s in ~s" v #'x))]
[([else b b* ...]) #'(begin b b* ...)]
[([(rec-name rec-field* ...) b b* ...] . rest) (identifier? #'rec-name)
(with-syntax ([altern (generate-body ctxt #'rest)]
[(id* ...) (enumerate #'(rec-field* ...) 0)]
[rtd #'(type-descriptor rec-name)])
#'(if ((record-predicate rtd) v)
(let ([rec-field* ;($record-ref v id*)] ...)
((record-field-accessor rtd id*) v)] ...)
b b* ...)
altern))]))
(syntax-case x ()
[(_ expr cls* ...)
(with-syntax ([body (generate-body #'_ #'(cls* ...))])
#'(let ([v expr]) body))])))

10
src/record-case.ss
View File

@ -1,12 +1,11 @@
(define-syntax record-case
(lambda (x)
(import scheme)
(define (enumerate fld* i)
(syntax-case fld* ()
[() #'()]
[(x . x*)
(with-syntax ([i i] [i* (enumerate #'x* (add1 i))])
(with-syntax ([i i] [i* (enumerate #'x* (fx+ i 1))])
#'(i . i*))]))
(define (generate-body ctxt cls*)
(syntax-case cls* (else)
@ -16,9 +15,10 @@
(with-syntax ([altern (generate-body ctxt #'rest)]
[(id* ...) (enumerate #'(rec-field* ...) 0)]
[rtd #'(type-descriptor rec-name)])
#'(if ((record-predicate rtd) v)
(let ([rec-field*
((record-field-accessor rtd id*) v)] ...)
#'(if ($record/rtd? v rtd)
;((record-predicate rtd) v)
(let ([rec-field* ($record-ref v id*)] ...)
; ((record-field-accessor rtd id*) v)] ...)
b b* ...)
altern))]))
(syntax-case x ()

21
src/runtime/Makefile
View File

@ -1,40 +1,41 @@
#CFLAGS = -Wall -DNDEBUG -O3
CFLAGS = -Wall -g
LDFLAGS = -g -ldl -luuid -rdynamic
LDFLAGS = -g -ldl -rdynamic
CC = gcc
all: ikarus
ikarus: ikarus-collect.o ikarus-runtime.o ikarus-main.o ikarus-fasl.o \
ikarus-exec.o ikarus-print.o ikarus-enter.s ikarus-symbol-table.o \
ikarus-weak-pairs.o
gcc $(LDFLAGS) -o ikarus \
$(CC) $(LDFLAGS) -o ikarus \
ikarus-main.o ikarus-runtime.o \
ikarus-fasl.o ikarus-exec.o ikarus-print.o ikarus-enter.s \
ikarus-symbol-table.o ikarus-collect.o ikarus-weak-pairs.o
ikarus-main.o: ikarus-main.c ikarus.h
gcc $(CFLAGS) -c ikarus-main.c
$(CC) $(CFLAGS) -c ikarus-main.c
ikarus-runtime.o: ikarus-runtime.c ikarus.h
gcc $(CFLAGS) -c ikarus-runtime.c
$(CC) $(CFLAGS) -c ikarus-runtime.c
ikarus-fasl.o: ikarus-fasl.c ikarus.h
gcc $(CFLAGS) -c ikarus-fasl.c
$(CC) $(CFLAGS) -c ikarus-fasl.c
ikarus-exec.o: ikarus-exec.c ikarus.h
gcc $(CFLAGS) -c ikarus-exec.c
$(CC) $(CFLAGS) -c ikarus-exec.c
ikarus-print.o: ikarus-print.c ikarus.h
gcc $(CFLAGS) -c ikarus-print.c
$(CC) $(CFLAGS) -c ikarus-print.c
ikarus-collect.o: ikarus-collect.c ikarus.h
gcc $(CFLAGS) -c ikarus-collect.c
$(CC) $(CFLAGS) -c ikarus-collect.c
ikarus-weak-pairs.o: ikarus-weak-pairs.c ikarus.h
gcc $(CFLAGS) -c ikarus-weak-pairs.c
$(CC) $(CFLAGS) -c ikarus-weak-pairs.c
ikarus-symbol-table.o: ikarus-symbol-table.c ikarus.h
gcc $(CFLAGS) -c ikarus-symbol-table.c
$(CC) $(CFLAGS) -c ikarus-symbol-table.c
ikarus.h: ikarus-data.h
touch ikarus.h

BIN
src/runtime/ikarus
View File

Binary file not shown.

528
src/runtime/ikarus-collect.c
View File

@ -8,6 +8,7 @@
#include <sys/mman.h>
#include <sys/types.h>
#include <assert.h>
#include <errno.h>
#define forward_ptr ((ikp)-1)
#define DEBUG_STACK 0
@ -45,12 +46,14 @@ typedef struct{
#define meta_code 1
#define meta_data 2
#define meta_weak 3
#define meta_count 4
#define meta_pair 4
#define meta_count 5
static int extension_amount[meta_count] = {
4 * pagesize,
1 * pagesize,
4 * pagesize,
1 * pagesize,
1 * pagesize
};
@ -58,7 +61,8 @@ static unsigned int meta_mt[meta_count] = {
pointers_mt,
code_mt,
data_mt,
weak_pairs_mt
weak_pairs_mt,
pointers_mt
};
#define generation_count 5 /* generations 0 (nursery), 1, 2, 3, 4 */
@ -85,10 +89,6 @@ next_gen_tag[generation_count] = {
(0 << meta_dirty_shift) | 4 | new_gen_tag
};
static ikp
meta_alloc_extending(int size, int old_gen, gc_t* gc, int meta_id){
int mapsize = align_to_next_page(size);
@ -149,9 +149,33 @@ gc_alloc_new_ptr(int size, int old_gen, gc_t* gc){
}
static inline ikp
gc_alloc_new_weak_ptr(int size, int old_gen, gc_t* gc){
assert(size == align(size));
return meta_alloc(size, old_gen, gc, meta_weak);
gc_alloc_new_pair(int old_gen, gc_t* gc){
return meta_alloc(pair_size, old_gen, gc, meta_pair);
}
static inline ikp
gc_alloc_new_weak_pair(int old_gen, gc_t* gc){
meta_t* meta = &gc->meta[old_gen][meta_weak];
ikp ap = meta->ap;
ikp ep = meta->ep;
ikp nap = ap + pair_size;
if(nap > ep){
ikp mem = ik_mmap_typed(
pagesize,
meta_mt[meta_weak] | next_gen_tag[old_gen],
gc->pcb);
gc->segment_vector = gc->pcb->segment_vector;
meta->ap = mem + pair_size;
meta->aq = mem;
meta->ep = mem + pagesize;
meta->base = mem;
return mem;
} else {
meta->ap = nap;
return ap;
}
}
static inline ikp
@ -162,7 +186,19 @@ gc_alloc_new_data(int size, int old_gen, gc_t* gc){
static inline ikp
gc_alloc_new_code(int size, int old_gen, gc_t* gc){
return meta_alloc(size, old_gen, gc, meta_code);
if(size < pagesize){
return meta_alloc(size, old_gen, gc, meta_code);
} else {
int memreq = align_to_next_page(size);
ikp mem = ik_mmap_code(memreq, next_gen_tag[old_gen], gc->pcb);
gc->segment_vector = gc->pcb->segment_vector;
qupages_t* p = ik_malloc(sizeof(qupages_t));
p->p = mem;
p->q = mem+size;
p->next = gc->queues[meta_code];
gc->queues[meta_code] = p;
return mem;
}
}
static void
@ -197,7 +233,6 @@ gc_tconc_push(gc_t* gc, ikp tcbucket){
static ikp add_object(gc_t* gc, ikp x);
static void collect_stack(gc_t*, ikp top, ikp base);
static void collect_oblist(gc_t*, ikoblist*);
static void collect_loop(gc_t*);
static void fix_weak_pointers(gc_t*);
static void gc_add_tconcs(gc_t*);
@ -231,6 +266,8 @@ static int collection_id_to_gen(int id){
return 0;
}
static void scan_dirty_pages(gc_t*);
static void deallocate_unused_pages(gc_t*);
@ -240,6 +277,11 @@ static void fix_new_pages(gc_t* gc);
ikpcb*
ik_collect(int req, ikpcb* pcb){
struct rusage t0, t1;
getrusage(RUSAGE_SELF, &t0);
gc_t gc;
bzero(&gc, sizeof(gc_t));
gc.pcb = pcb;
@ -248,8 +290,11 @@ ik_collect(int req, ikpcb* pcb){
gc.collect_gen = collection_id_to_gen(pcb->collection_id);
pcb->collection_id++;
#ifndef NDEBUG
fprintf(stderr, "ik_collect entry %d (collect gen=%d/id=%d)\n",
req, gc.collect_gen, pcb->collection_id-1);
fprintf(stderr, "ik_collect entry %d free=%d (collect gen=%d/id=%d)\n",
req,
(unsigned int) pcb->allocation_redline
- (unsigned int) pcb->allocation_pointer,
gc.collect_gen, pcb->collection_id-1);
#endif
@ -262,7 +307,7 @@ ik_collect(int req, ikpcb* pcb){
scan_dirty_pages(&gc);
collect_stack(&gc, pcb->frame_pointer, pcb->frame_base - wordsize);
pcb->next_k = add_object(&gc, pcb->next_k);
collect_oblist(&gc, pcb->oblist);
pcb->oblist = add_object(&gc, pcb->oblist);
/* now we trace all live objects */
collect_loop(&gc);
@ -297,6 +342,33 @@ ik_collect(int req, ikpcb* pcb){
htable_count = 0;
}
//ik_dump_metatable(pcb);
#ifndef NDEBUG
fprintf(stderr, "collect done\n");
#endif
getrusage(RUSAGE_SELF, &t1);
pcb->collect_utime.tv_usec += t1.ru_utime.tv_usec - t0.ru_utime.tv_usec;
pcb->collect_utime.tv_sec += t1.ru_utime.tv_sec - t0.ru_utime.tv_sec;
if (pcb->collect_utime.tv_usec >= 1000000){
pcb->collect_utime.tv_usec -= 1000000;
pcb->collect_utime.tv_sec += 1;
}
else if (pcb->collect_utime.tv_usec < 0){
pcb->collect_utime.tv_usec += 1000000;
pcb->collect_utime.tv_sec -= 1;
}
pcb->collect_stime.tv_usec += t1.ru_stime.tv_usec - t0.ru_stime.tv_usec;
pcb->collect_stime.tv_sec += t1.ru_stime.tv_sec - t0.ru_stime.tv_sec;
if (pcb->collect_stime.tv_usec >= 1000000){
pcb->collect_stime.tv_usec -= 1000000;
pcb->collect_stime.tv_sec += 1;
}
else if (pcb->collect_stime.tv_usec < 0){
pcb->collect_stime.tv_usec += 1000000;
pcb->collect_stime.tv_sec -= 1;
}
return pcb;
}
@ -355,34 +427,38 @@ add_code_entry(gc_t* gc, ikp entry){
if(gen > gc->collect_gen){
return entry;
}
int code_size = (int)ref(x, disp_code_code_size);
int reloc_size = (int)ref(x, disp_code_reloc_size);
int closure_size = (int)ref(x, disp_code_closure_size);
int required_mem = align(disp_code_data + code_size + reloc_size);
ikp y = gc_alloc_new_code(required_mem, gen, gc);
ref(y, 0) = code_tag;
ref(y, disp_code_code_size) = (ikp)code_size;
ref(y, disp_code_reloc_size) = (ikp)reloc_size;
ref(y, disp_code_closure_size) = (ikp)closure_size;
ref(y, disp_code_data) = x;
ref(x, 0) = forward_ptr;
ref(x, wordsize) = y + vector_tag;
return y+disp_code_data;
}
static void collect_oblist(gc_t* gc, ikoblist* st){
ikbucket** p = st->buckets;
ikbucket** q = p + st->number_of_buckets;
while(p < q){
ikbucket* b = *p;
while(b){
b->val = add_object(gc, b->val);
b = b->next;
int code_size = unfix(ref(x, disp_code_code_size));
ikp reloc_vec = ref(x, disp_code_reloc_vector);
ikp freevars = ref(x, disp_code_freevars);
int required_mem = align(disp_code_data + code_size);
if(required_mem >= pagesize){
int new_tag = next_gen_tag[gen];
int idx = page_index(x);
gc->segment_vector[idx] = new_tag | code_mt;
int i;
for(i=pagesize, idx++; i<required_mem; i+=pagesize, idx++){
gc->segment_vector[idx] = new_tag | data_mt;
}
p++;
qupages_t* p = ik_malloc(sizeof(qupages_t));
p->p = x;
p->q = x+required_mem;
p->next = gc->queues[meta_code];
gc->queues[meta_code] = p;
return entry;
} else {
ikp y = gc_alloc_new_code(required_mem, gen, gc);
ref(y, 0) = code_tag;
ref(y, disp_code_code_size) = fix(code_size);
ref(y, disp_code_reloc_vector) = reloc_vec;
ref(y, disp_code_freevars) = freevars;
memcpy(y+disp_code_data, x+disp_code_data, code_size);
ref(x, 0) = forward_ptr;
ref(x, wordsize) = y + vector_tag;
return y+disp_code_data;
}
}
#define DEBUG_STACK 0
static void collect_stack(gc_t* gc, ikp top, ikp end){
@ -498,6 +574,60 @@ static void collect_stack(gc_t* gc, ikp top, ikp end){
}
}
static void
add_list(gc_t* gc, unsigned int t, int gen, ikp x, ikp* loc){
int collect_gen = gc->collect_gen;
while(1){
ikp fst = ref(x, off_car);
ikp snd = ref(x, off_cdr);
ikp y;
if((t & type_mask) != weak_pairs_type){
y = gc_alloc_new_pair(gen, gc) + pair_tag;
} else {
y = gc_alloc_new_weak_pair(gen, gc) + pair_tag;
}
*loc = y;
ref(x,off_car) = forward_ptr;
ref(x,off_cdr) = y;
ref(y,off_car) = fst;
int stag = tagof(snd);
if(stag == pair_tag){
if(ref(snd, -pair_tag) == forward_ptr){
ref(y, off_cdr) = ref(snd, wordsize-pair_tag);
return;
}
else {
t = gc->segment_vector[page_index(snd)];
gen = t & gen_mask;
if(gen > collect_gen){
ref(y, off_cdr) = snd;
return;
} else {
x = snd;
loc = (ikp*)(y + off_cdr);
/* don't return */
}
}
}
else if( (stag == immediate_tag)
|| (stag == 0)
|| (stag == (1<<fx_shift))) {
ref(y,off_cdr) = snd;
return;
}
else if (ref(snd, -stag) == forward_ptr){
ref(y, off_cdr) = ref(snd, wordsize-stag);
return;
}
else {
ref(y, off_cdr) = add_object(gc, snd);
return;
}
}
}
static ikp
add_object(gc_t* gc, ikp x){
if(is_fixnum(x)){
@ -522,20 +652,8 @@ add_object(gc_t* gc, ikp x){
return x;
}
if(tag == pair_tag){
ikp snd = ref(x, off_cdr);
ikp y;
if((t & type_mask) == weak_pairs_type){
y = gc_alloc_new_weak_ptr(pair_size, gen, gc) + pair_tag;
} else {
y = gc_alloc_new_ptr(pair_size, gen, gc) + pair_tag;
}
ref(y,off_car) = fst;
ref(y,off_cdr) = snd;
ref(x,off_car) = forward_ptr;
ref(x,off_cdr) = y;
if(accounting){
pair_count++;
}
add_list(gc, t, gen, x, &y);
return y;
}
else if(tag == symbol_tag){
@ -554,17 +672,14 @@ add_object(gc_t* gc, ikp x){
return y;
}
else if(tag == closure_tag){
int size = (int) ref(fst, disp_code_closure_size - disp_code_data);
if(size <= 0){
fprintf(stderr, "invalid closure size=%d\n", size);
exit(-1);
}
int size = disp_closure_data+
(int) ref(fst, disp_code_freevars - disp_code_data);
if(size > 1024){
fprintf(stderr, "large closure size=0x%08x\n", size);
}
int asize = align(size);
ikp y = gc_alloc_new_ptr(asize, gen, gc) + closure_tag;
bzero(y-closure_tag, asize);
ref(y, asize-closure_tag-wordsize) = 0;
memcpy(y-closure_tag, x-closure_tag, size);
ref(y,-closure_tag) = add_code_entry(gc, ref(y,-closure_tag));
ref(x,-closure_tag) = forward_ptr;
@ -578,13 +693,12 @@ add_object(gc_t* gc, ikp x){
if(is_fixnum(fst)){
/* real vector */
int size = (int)fst;
if(size > 4096){
fprintf(stderr, "large vec size=0x%08x\n", size);
}
assert(size >= 0);
int memreq = align(size + disp_vector_data);
ikp y = gc_alloc_new_ptr(memreq, gen, gc) + vector_tag;
bzero(y-vector_tag, memreq);
memcpy(y-vector_tag, x-vector_tag, size + disp_vector_data);
ref(y, disp_vector_length-vector_tag) = fst;
ref(y, memreq-vector_tag-wordsize) = 0;
memcpy(y+off_vector_data, x+off_vector_data, size);
ref(x,-vector_tag) = forward_ptr;
ref(x,wordsize-vector_tag) = y;
if(accounting){
@ -600,7 +714,7 @@ add_object(gc_t* gc, ikp x){
}
int memreq = align(size + disp_record_data);
ikp y = gc_alloc_new_ptr(memreq, gen, gc) + vector_tag;
bzero(y-vector_tag, memreq);
ref(y, memreq-vector_tag-wordsize) = 0;
memcpy(y-vector_tag, x-vector_tag, size+wordsize);
ref(x,-vector_tag) = forward_ptr;
ref(x,wordsize-vector_tag) = y;
@ -615,7 +729,6 @@ add_object(gc_t* gc, ikp x){
return new_entry - off_code_data;
}
else if(fst == continuation_tag){
// fprintf(stderr, "conitnuation!\n");
ikp top = ref(x, off_continuation_top);
int size = (int) ref(x, off_continuation_size);
if(size > 4096){
@ -664,9 +777,6 @@ add_object(gc_t* gc, ikp x){
else if(tag == string_tag){
if(is_fixnum(fst)){
int strlen = unfix(fst);
if(strlen > 4096){
fprintf(stderr, "large string size=0x%08x\n", strlen);
}
int memreq = align(strlen + disp_string_data + 1);
ikp new_str = gc_alloc_new_data(memreq, gen, gc) + string_tag;
ref(new_str, off_string_length) = fst;
@ -692,65 +802,49 @@ add_object(gc_t* gc, ikp x){
static void
relocate_new_code(ikp x, gc_t* gc){
int instrsize = (int)ref(x, disp_code_code_size);
int relocsize = (int)ref(x, disp_code_reloc_size);
ikp y = ref(x, disp_code_data);
assert(ref(y, 0) == forward_ptr);
assert(ref(y, wordsize) == (x+vector_tag));
memcpy(x+disp_code_data, y+disp_code_data, instrsize+relocsize);
ikp reloc = x + disp_code_data + instrsize;
int i = 0;
while(i < relocsize){
int r = (int) ref(reloc,i);
if(r == 0){
i = relocsize;
ikp relocvector = ref(x, disp_code_reloc_vector);
relocvector = add_object(gc, relocvector);
ref(x, disp_code_reloc_vector) = relocvector;
int relocsize = (int)ref(relocvector, off_vector_length);
ikp p = relocvector + off_vector_data;
ikp q = p + relocsize;
ikp code = x + disp_code_data;
while(p < q){
int r = unfix(ref(p, 0));
int tag = r & 3;
int code_off = r >> 2;
if(tag == 0){
/* undisplaced pointer */
ikp old_object = ref(p, wordsize);
ikp new_object = add_object(gc, old_object);
ref(code, code_off) = new_object;
p += (2*wordsize);
}
else if(tag == 2){
/* displaced pointer */
int obj_off = unfix(ref(p, wordsize));
ikp old_object = ref(p, 2*wordsize);
ikp new_object = add_object(gc, old_object);
ref(code, code_off) = new_object + obj_off;
p += (3 * wordsize);
}
else if(tag == 3){
/* displaced relative pointer */
int obj_off = unfix(ref(p, wordsize));
ikp obj = add_object(gc, ref(p, 2*wordsize));
ikp displaced_object = obj + obj_off;
ikp next_word = code + code_off + wordsize;
ikp relative_distance = displaced_object - (int)next_word;
ref(next_word, -wordsize) = relative_distance;
p += (3*wordsize);
}
else if(tag == 1){
/* do nothing */
p += (2 * wordsize);
}
else {
int rtag = r & 3;
if(rtag == 0){
/* undisplaced pointer */
int code_offset = r >> 2;
ikp old_object = ref(x, disp_code_data + code_offset);
ikp new_object = add_object(gc, old_object);
ref(x, disp_code_data + code_offset) = new_object;
i += wordsize;
}
else if(rtag == 1){
/* displaced pointer */
int code_offset = r >> 2;
int object_offset = (int) ref(reloc, i + wordsize);
ikp old_displaced_object = ref(x, disp_code_data + code_offset);
ikp old_object = old_displaced_object - object_offset;
ikp new_object = add_object(gc, old_object);
ikp new_displaced_object = new_object + object_offset;
ref(x, disp_code_data + code_offset) = new_displaced_object;
i += (2 * wordsize);
}
else if(rtag == 2){
/* displaced relative pointer */
int code_offset = r >> 2;
int object_offset = (int) ref(reloc, i+wordsize);
ikp old_relative_pointer = ref(x, disp_code_data + code_offset);
ikp old_next_word = y + disp_code_data + code_offset + wordsize;
ikp old_absolute_pointer = old_relative_pointer + (int)old_next_word;
ikp old_object = old_absolute_pointer - object_offset;
ikp new_object = add_object(gc, old_object);
ikp new_absolute_pointer = new_object + object_offset;
ikp new_next_word = x + disp_code_data + code_offset + wordsize;
ikp new_relative_pointer = new_absolute_pointer - (int) new_next_word;
ref(x, disp_code_data+code_offset) = new_relative_pointer;
i += (2*wordsize);
}
else if(rtag == 3){
/* foreign object */
/* just add the name */
ref(reloc, i+wordsize) = add_object(gc, ref(reloc, i+wordsize));
i += (2 * wordsize);
}
else {
fprintf(stderr, "invalid rtag %d in 0x%08x\n", rtag, r);
exit(-1);
}
fprintf(stderr, "invalid rtag %d in 0x%08x\n", tag, r);
exit(-1);
}
}
}
@ -763,6 +857,25 @@ collect_loop(gc_t* gc){
int scan_ptr_count = 0;
do{
done = 1;
{ /* scan the pending pairs pages */
qupages_t* qu = gc->queues[meta_pair];
if(qu){
done = 0;
gc->queues[meta_pair] = 0;
do{
ikp p = qu->p;
ikp q = qu->q;
while(p < q){
ref(p,0) = add_object(gc, ref(p,0));
p += (2*wordsize);
}
qupages_t* next = qu->next;
ik_free(qu, sizeof(qupages_t));
qu = next;
} while(qu);
}
}
{ /* scan the pending pointer pages */
qupages_t* qu = gc->queues[meta_ptrs];
if(qu){
@ -781,24 +894,6 @@ collect_loop(gc_t* gc){
} while(qu);
}
}
{ /* scan the pending weak-pointer pages */
qupages_t* qu = gc->queues[meta_weak];
if(qu){
done = 0;
gc->queues[meta_weak] = 0;
do{
ikp p = qu->p;
ikp q = qu->q;
while(p < q){
ref(p,wordsize) = add_object(gc, ref(p,wordsize));
p += (2*wordsize);
}
qupages_t* next = qu->next;
ik_free(qu, sizeof(qupages_t));
qu = next;
} while(qu);
}
}
{ /* scan the pending code objects */
qupages_t* codes = gc->queues[meta_code];
if(codes){
@ -810,9 +905,7 @@ collect_loop(gc_t* gc){
while(p < q){
relocate_new_code(p, gc);
alloc_code_count--;
p += align(disp_code_data +
(int)ref(p, disp_code_code_size) +
(int)ref(p, disp_code_reloc_size));
p += align(disp_code_data + unfix(ref(p, disp_code_code_size)));
}
qupages_t* next = codes->next;
ik_free(codes, sizeof(qupages_t));
@ -822,6 +915,23 @@ collect_loop(gc_t* gc){
}
{/* see if there are any remaining in the main ptr segment */
int i;
for(i=0; i<=gc->collect_gen; i++){
meta_t* meta = &gc->meta[i][meta_pair];
ikp p = meta->aq;
ikp q = meta->ap;
if(p < q){
done = 0;
do{
meta->aq = q;
while(p < q){
ref(p,0) = add_object(gc, ref(p,0));
p += (2*wordsize);
}
p = meta->aq;
q = meta->ap;
} while (p < q);
}
}
for(i=0; i<=gc->collect_gen; i++){
meta_t* meta = &gc->meta[i][meta_ptrs];
ikp p = meta->aq;
@ -839,24 +949,6 @@ collect_loop(gc_t* gc){
} while (p < q);
}
}
for(i=0; i<=gc->collect_gen; i++){
meta_t* meta = &gc->meta[i][meta_weak];
ikp p = meta->aq;
ikp q = meta->ap;
if(p < q){
done = 0;
do{
meta->aq = q;
while(p < q){
ref(p,wordsize) = add_object(gc, ref(p,wordsize));
scan_ptr_count += wordsize;
p += (2*wordsize);
}
p = meta->aq;
q = meta->ap;
} while (p < q);
}
}
for(i=0; i<=gc->collect_gen; i++){
meta_t* meta = &gc->meta[i][meta_code];
ikp p = meta->aq;
@ -868,9 +960,7 @@ collect_loop(gc_t* gc){
do{
alloc_code_count--;
relocate_new_code(p, gc);
p += align(disp_code_data +
(int)ref(p, disp_code_code_size) +
(int)ref(p, disp_code_reloc_size));
p += align(disp_code_data + unfix(ref(p, disp_code_code_size)));
} while (p < q);
p = meta->aq;
q = meta->ap;
@ -882,6 +972,15 @@ collect_loop(gc_t* gc){
} while (! done);
{
int i;
for(i=0; i<=gc->collect_gen; i++){
meta_t* meta = &gc->meta[i][meta_pair];
ikp p = meta->ap;
ikp q = meta->ep;
while(p < q){
ref(p, 0) = 0;
p += wordsize;
}
}
for(i=0; i<=gc->collect_gen; i++){
meta_t* meta = &gc->meta[i][meta_ptrs];
ikp p = meta->ap;
@ -1000,6 +1099,49 @@ scan_dirty_pointers_page(gc_t* gc, int page_idx, int mask){
dirty_vec[page_idx] = new_d;
}
static void
scan_dirty_code_page(gc_t* gc, int page_idx, unsigned int mask){
ikp p = (ikp)(page_idx << pageshift);
ikp start = p;
ikp q = p + pagesize;
unsigned int* segment_vec = gc->segment_vector;
unsigned int* dirty_vec = gc->pcb->dirty_vector;
//unsigned int d = dirty_vec[page_idx];
unsigned int t = segment_vec[page_idx];
//unsigned int masked_d = d & mask;
unsigned int new_d = 0;
while(p < q){
if(ref(p, 0) != code_tag){
p = q;
}
else {
int j = ((int)p - (int)start) / cardsize;
int code_size = unfix(ref(p, disp_code_code_size));
relocate_new_code(p, gc);
segment_vec = gc->segment_vector;
ikp rvec = ref(p, disp_code_reloc_vector);
int len = (int)ref(rvec, off_vector_length);
assert(len >= 0);
int i;
unsigned int code_d = segment_vec[page_index(rvec)];
for(i=0; i<len; i+=wordsize){
ikp r = ref(rvec, i+off_vector_data);
if(is_fixnum(r) || (tagof(r) == immediate_tag)){
/* do nothing */
} else {
r = add_object(gc, r);
segment_vec = gc->segment_vector;
code_d = code_d | segment_vec[page_index(r)];
}
}
new_d = new_d | (code_d<<(j*meta_dirty_shift));
p += align(code_size + disp_code_data);
}
}
dirty_vec = gc->pcb->dirty_vector;
new_d = new_d & cleanup_mask[t & gen_mask];
dirty_vec[page_idx] = new_d;
}
/* scanning dirty weak pointers should add the cdrs of the pairs
* but leave the cars unmodified. The dirty mask is also kept
@ -1057,13 +1199,21 @@ scan_dirty_pages(gc_t* gc){
scan_dirty_pointers_page(gc, i, mask);
dirty_vec = pcb->dirty_vector;
segment_vec = pcb->segment_vector;
} else if (type == weak_pairs_type){
}
else if (type == weak_pairs_type){
if((t & gen_mask) > collect_gen){
scan_dirty_weak_pointers_page(gc, i, mask);
dirty_vec = pcb->dirty_vector;
segment_vec = pcb->segment_vector;
}
}
else if (type == code_type){
if((t & gen_mask) > collect_gen){
scan_dirty_code_page(gc, i, mask);
dirty_vec = pcb->dirty_vector;
segment_vec = pcb->segment_vector;
}
}
else if (t & scannable_mask) {
fprintf(stderr, "BUG: unhandled scan of type 0x%08x\n", t);
exit(-1);
@ -1142,6 +1292,50 @@ fix_new_pages(gc_t* gc){
d = d | (card_d<<(j*meta_dirty_shift));
}
dirty_vec[i] = d & cleanup_mask[page_gen];
}
else if((t & type_mask) == code_type){
/* FIXME: scan codes */
ikp page_base = (ikp)(i << pageshift);
ikp p = page_base;
ikp q = p + pagesize;
int err = mprotect(page_base, pagesize, PROT_READ|PROT_WRITE|PROT_EXEC);
if(err){
fprintf(stderr, "cannot protect code page: %s\n", strerror(errno));
exit(-1);
}
unsigned int d = 0;
while(p < q){
if(ref(p, 0) != code_tag){
p = q;
}
else {
ikp rvec = ref(p, disp_code_reloc_vector);
int size = (int)ref(rvec, off_vector_length);
ikp vp = rvec + off_vector_data;
ikp vq = vp + size;
unsigned int code_d = segment_vec[page_index(rvec)];
while(vp < vq){
ikp x = ref(vp, 0);
if(is_fixnum(x) || (tagof(x) == immediate_tag)){
/* do nothing */
} else {
code_d = code_d || segment_vec[page_index(x)];
}
vp += wordsize;
}
code_d = (code_d & meta_dirty_mask) >> meta_dirty_shift;
int j = ((int)p - (int)page_base)/cardsize;
d = d | (code_d<<(j*meta_dirty_shift));
p += align(disp_code_data + unfix(ref(p, disp_code_code_size)));
}
}
dirty_vec[i] = d & cleanup_mask[page_gen];
}
else {
if(t & scannable_mask){
fprintf(stderr, "unscanned 0x%08x\n", t);
exit(-1);
}
}
}
i++;

16
src/runtime/ikarus-data.h
View File

@ -5,21 +5,15 @@
#define IK_FASL_HEADER_LEN (strlen(IK_FASL_HEADER))
#define IK_FASL_CODE_HEADER_SIZE 12
#define IK_CODE_PRI_TAG 5
#define code_pri_tag vector_tag
#define IK_CODE_SEC_TAG ((ikp)0x2F)
#define code_tag ((ikp)0x2F)
#define IK_DISP_CODE_CODE_SIZE 4
#define disp_code_code_size 4
#define IK_DISP_CODE_RELOC_SIZE 8
#define disp_code_reloc_size 8
#define IK_DISP_CODE_CLOSURE_SIZE 12
#define disp_code_closure_size 12
#define IK_DISP_CODE_DATA 16
#define disp_code_reloc_vector 8
#define disp_code_freevars 12
#define disp_code_data 16
#define off_code_data (disp_code_data - code_pri_tag)
#define off_code_reloc_vector (disp_code_reloc_vector - code_pri_tag)
#define IK_OFF_CODE_DATA (IK_DISP_CODE_DATA - IK_CODE_PRI_TAG)
#define IK_ALIGN_SHIFT 3
#define align_shift 3
@ -150,13 +144,15 @@
#define disp_rtd_length 8
#define disp_rtd_fields 12
#define disp_rtd_printer 16
#define rtd_size 20
#define disp_rtd_symbol 20
#define rtd_size 24
#define off_rtd_rtd (disp_rtd_rtd - rtd_tag)
#define off_rtd_name (disp_rtd_name - rtd_tag)
#define off_rtd_length (disp_rtd_length - rtd_tag)
#define off_rtd_fields (disp_rtd_fields - rtd_tag)
#define off_rtd_printer (disp_rtd_printer - rtd_tag)
#define off_rtd_symbol (disp_rtd_symbol - rtd_tag)
#define continuation_tag ((ikp)0x1F)
#define disp_continuation_top 4

2
src/runtime/ikarus-exec.c
View File

@ -13,7 +13,7 @@ typedef struct {
ikp ik_exec_code(ikpcb* pcb, ikp code_ptr){
ikp argc = ik_asm_enter(pcb, code_ptr+IK_DISP_CODE_DATA-IK_CODE_PRI_TAG,0);
ikp argc = ik_asm_enter(pcb, code_ptr+off_code_data,0);
ikp next_k = pcb->next_k;
while(next_k){
cont* k = (cont*)(next_k - vector_tag);

172
src/runtime/ikarus-fasl.c
View File

@ -15,6 +15,7 @@
typedef struct {
char* membase;
char* memp;
char* memq;
ikp* marks;
@ -56,6 +57,7 @@ void ik_fasl_load(ikpcb* pcb, char* fasl_file){
}
fasl_port p;
p.membase = mem;
p.memp = mem;
p.memq = mem + filesize;
p.marks = NULL;
@ -65,7 +67,7 @@ void ik_fasl_load(ikpcb* pcb, char* fasl_file){
while(p.memp < p.memq){
ikp v = ik_fasl_read(pcb, &p);
if(p.marks){
bzero(p.marks, p.marks_size);
bzero(p.marks, p.marks_size * sizeof(ikp*));
}
ikp val = ik_exec_code(pcb, v);
if(val != void_object){
@ -93,18 +95,74 @@ void ik_fasl_load(ikpcb* pcb, char* fasl_file){
static ikp
ik_make_code(int code_size, int reloc_size, ikp closure_size, ikpcb* pcb){
int required_memory =
align_to_next_page(code_size + reloc_size + disp_code_data);
alloc_code(int size, ikpcb* pcb){
int required_memory = align_to_next_page(size);
ikp mem = ik_mmap_code(required_memory, 0, pcb);
ref(mem, 0) = code_tag;
ref(mem, disp_code_code_size) = (ikp) code_size;
ref(mem, disp_code_reloc_size) = (ikp) reloc_size;
ref(mem, disp_code_closure_size) = closure_size;
ref(mem,disp_code_data+code_size+reloc_size) = 0;
return (ikp)(mem+vector_tag);
return (ikp)mem;
}
void
ik_relocate_code(ikp code){
ikp vec = ref(code, disp_code_reloc_vector);
ikp size = ref(vec, off_vector_length);
ikp data = code + disp_code_data;
ikp p = vec + off_vector_data;
ikp q = p + (int)size;
while(p < q){
int r = unfix(ref(p, 0));
if(r == 0){
fprintf(stderr, "unset reloc!\n");
exit(-1);
}
int tag = r & 3;
int code_off = r >> 2;
// fprintf(stderr, "data=0x%08x, off=0x%08x, data+off=0x%08x, r=0x%08x\n",
// (int)data, code_off, (int)data+code_off, r);
// fprintf(stderr, "setting 0x%08x from r=0x%08x\n", (int)(data+code_off), r);
if(tag == 0){
/* vanilla object */
ref(data, code_off) = ref(p, wordsize);
p += (2*wordsize);
}
else if(tag == 2){
/* displaced object */
int obj_off = unfix(ref(p, wordsize));
ikp obj = ref(p, 2*wordsize);
ref(data, code_off) = obj + obj_off;
p += (3*wordsize);
}
else if(tag == 3){
/* jump label */
int obj_off = unfix(ref(p, wordsize));
ikp obj = ref(p, 2*wordsize);
ikp displaced_object = obj + obj_off;
ikp next_word = data + code_off + wordsize;
ikp relative_distance = displaced_object - (int)next_word;
ref(next_word, -wordsize) = relative_distance;
p += (3*wordsize);
}
else if(tag == 1){
/* foreign object */
ikp str = ref(p, wordsize);
char* name = string_data(str);
void* sym = dlsym(NULL, name);
char* err = dlerror();
if(err){
fprintf(stderr, "failed to find foreign name %s: %s\n", name, err);
exit(-1);
}
ref(data,code_off) = sym;
p += (2*wordsize);
}
else {
fprintf(stderr, "invalid reloc 0x%08x (tag=%d)\n", r, tag);
exit(-1);
}
}
}
static char fasl_read_byte(fasl_port* p){
if(p->memp < p->memq){
char c = *(p->memp);
@ -151,7 +209,10 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){
}
if(idx < p->marks_size){
if(p->marks[idx] != 0){
fprintf(stderr, "mark %d already set\n", idx);
fprintf(stderr, "mark %d already set (fileoff=%d)\n",
idx,
(int)p->memp - (int)p->membase - 6);
ik_print(p->marks[idx]);
exit(-1);
}
}
@ -168,7 +229,26 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){
}
}
}
if(c == 'x'){
int code_size;
ikp freevars;
fasl_read_buf(p, &code_size, sizeof(int));
fasl_read_buf(p, &freevars, sizeof(ikp));
ikp code = alloc_code(align(code_size+disp_code_data), pcb);
ref(code, 0) = code_tag;
ref(code, disp_code_code_size) = fix(code_size);
ref(code, disp_code_freevars) = freevars;
fasl_read_buf(p, code+disp_code_data, code_size);
if(put_mark_index){
p->marks[put_mark_index] = code+vector_tag;
}
ref(code, disp_code_reloc_vector) = do_read(pcb, p);
ik_relocate_code(code);
return code+vector_tag;
}
if(c == 'X'){
assert(0);
#if 0
code_header ch;
fasl_read_buf(p, &ch, sizeof(ch));
ikp code = ik_make_code(ch.code_size, ch.reloc_size, ch.closure_size, pcb);
@ -185,8 +265,8 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){
int offset;
fasl_read_buf(p, &offset, sizeof(int));
ikp object = do_read(pcb, p);
REF(code_data,offset) = object;
REF(reloc_table, i) = (ikp)(offset << 2);
ref(code_data,offset) = object;
ref(reloc_table, i) = (ikp)(offset << 2);
i += wordsize;
}
else if(t == 'F'){ /* foreign call */
@ -211,9 +291,9 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){
fasl_read_buf(p, &code_offset, sizeof(int));
fasl_read_buf(p, &object_offset, sizeof(int));
ikp object = do_read(pcb, p);
REF(reloc_table, i) = (ikp)((code_offset << 2) | 1);
REF(reloc_table, i+wordsize) = (ikp)object_offset;
REF(code_data, code_offset) = object + object_offset;
ref(reloc_table, i) = (ikp)((code_offset << 2) | 1);
ref(reloc_table, i+wordsize) = (ikp)object_offset;
ref(code_data, code_offset) = object + object_offset;
i += (2*wordsize);
}
else if(t == 'J'){ /* jump reloc */
@ -222,11 +302,11 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){
fasl_read_buf(p, &code_offset, sizeof(int));
fasl_read_buf(p, &object_offset, sizeof(int));
ikp object = do_read(pcb, p);
REF(reloc_table, i) = (ikp)((code_offset << 2) | 2);
REF(reloc_table, i+wordsize) = (ikp)object_offset;
ref(reloc_table, i) = (ikp)((code_offset << 2) | 2);
ref(reloc_table, i+wordsize) = (ikp)object_offset;
ikp next_word = code_data + code_offset + wordsize;
ikp displaced_object = object + object_offset;
REF(next_word, -wordsize) = displaced_object - (int) next_word;
ref(next_word, -wordsize) = displaced_object - (int) next_word;
i += (2*wordsize);
}
else {
@ -236,6 +316,7 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){
}
assert(i==ch.reloc_size);
return code;
#endif
}
else if(c == 'P'){
ikp pair = ik_alloc(pcb, pair_size) + pair_tag;
@ -302,6 +383,54 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){
char x = fasl_read_byte(p);
return byte_to_scheme_char(x);
}
else if(c == 'G'){ /* G is for gensym */
ikp pretty = do_read(pcb, p);
ikp unique = do_read(pcb, p);
ikp sym = ik_alloc(pcb, align(symbol_size)) + symbol_tag;
ref(sym, off_symbol_string) = pretty;
ref(sym, off_symbol_ustring) = unique;
ref(sym, off_symbol_value) = unbound_object;
ref(sym, off_symbol_system_value) = unbound_object;
ref(sym, off_symbol_plist) = null_object;
ref(sym, off_symbol_system_plist) = null_object;
if(put_mark_index){
p->marks[put_mark_index] = sym;
}
return sym;
}
else if(c == 'R'){ /* R is for RTD */
ikp name = do_read(pcb, p);
ikp symb = do_read(pcb, p);
int i, n;
fasl_read_buf(p, &n, sizeof(int));
ikp fields;
if(n == 0){
fields = null_object;
} else {
fields = ik_alloc(pcb, n * align(pair_size)) + pair_tag;
ikp ptr = fields;
for(i=0; i<n; i++){
ref(ptr, off_car) = do_read(pcb, p);
ref(ptr, off_cdr) = ptr + align(pair_size);
ptr += align(pair_size);
}
ptr -= pair_size;
ref(ptr, off_cdr) = null_object;
}
ikp rtd = ik_alloc(pcb, align(rtd_size)) + vector_tag;
ikp base_sym = ik_cstring_to_symbol("$base-rtd", pcb);
ikp base_rtd = ref(base_sym, off_symbol_system_value);
ref(rtd, off_rtd_rtd) = base_rtd;
ref(rtd, off_rtd_name) = name;
ref(rtd, off_rtd_length) = fix(n);
ref(rtd, off_rtd_fields) = fields;
ref(rtd, off_rtd_printer) = false_object;
ref(rtd, off_rtd_symbol) = symb;
if(put_mark_index){
p->marks[put_mark_index] = rtd;
}
return rtd;
}
else if(c == '<'){
int idx;
fasl_read_buf(p, &idx, sizeof(int));
@ -322,7 +451,10 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){
}
}
else {
fprintf(stderr, "invalid type '%c' found in fasl file\n", c);
fprintf(stderr,
"invalid type '%c' (0x%02x) found in fasl file at byte 0x%08x\n",
c, c,
(int) p->memp - (int) p->membase - 1);
exit(-1);
}
}

71
src/runtime/ikarus-hash-tables.c
View File

@ -1,71 +0,0 @@
#include "ikarus.h"
#include <strings.h>
/* from http://www.concentric.net/~Ttwang/tech/inthash.htm */
ikp
ik_get_hash_table(ikp ht, ikp k, ikp def, ikpcb* pcb){
ikp size = ref(ht, off_htable_size);
if(size == 0){
return def;
}
ikbucket** table = (ikbucket**) ref(ht, off_htable_mem);
int idx = inthash((int)k) & (unfix(size)-1);
ikbucket* p = table[idx];
while(p){
if(p->key == k){
return p->val;
} else {
p = p->next;
}
}
return def;
}
int hash_table_count = 0;
static void
initialize_hash_table(ikp ht, ikpcb* pcb){
hash_table_count++;
ikp mem = ik_mmap(pagesize);
bzero(mem, pagesize);
ref(ht, off_htable_size) = (ikp) pagesize;
ref(ht, off_htable_count) = 0;
ref(ht, off_htable_mem) = mem;
ikhashtables* p = ik_malloc(sizeof(ikhashtables));
p->ht = ht;
p->next = pcb->hash_tables;
pcb->hash_tables = p;
}
ikp
ik_put_hash_table(ikp ht, ikp k, ikp v, ikpcb* pcb){
ikp size = ref(ht, off_htable_size);
if(size == 0){
initialize_hash_table(ht, pcb);
size = ref(ht, off_htable_size);
}
ikbucket** table = (ikbucket**) ref(ht, off_htable_mem);
int idx = inthash((int)k) & (unfix(size)-1);
ikbucket* bucket = table[idx];
ikbucket* p = bucket;
while(p){
if(p->key == k){
p->val = v;
return void_object;
} else {
p = p->next;
}
}
p = ik_malloc(sizeof(ikbucket));
p->key = k;
p->val = v;
p->next = bucket;
table[idx] = p;
ref(ht, off_htable_count) =
fix(unfix(ref(ht, off_htable_count)) + 1);
return void_object;
}

6
src/runtime/ikarus-main.c
View File

@ -21,6 +21,12 @@ int main(int argc, char** argv){
char* fasl_file = argv[i];
ik_fasl_load(pcb, fasl_file);
}
fprintf(stderr, "collect time: %d.%03d utime, %d.%03d stime (%d collections)\n",
pcb->collect_utime.tv_sec,
pcb->collect_utime.tv_usec/1000,
pcb->collect_stime.tv_sec,
pcb->collect_stime.tv_usec/1000,
pcb->collection_id );
ik_delete_pcb(pcb);
return 0;
}

222
src/runtime/ikarus-runtime.c
View File

@ -1,4 +1,5 @@
#include "ikarus.h"
#include <time.h>
#include <stdio.h>
#include <stdlib.h>
#include <sys/types.h>
@ -106,7 +107,16 @@ ik_mmap_data(int size, int gen, ikpcb* pcb){
void*
ik_mmap_code(int size, int gen, ikpcb* pcb){
return ik_mmap_typed(size, code_mt | gen, pcb);
ikp p = ik_mmap_typed(size, code_mt | gen, pcb);
if(size > pagesize){
set_segment_type(p+pagesize, size-pagesize, data_mt|gen, pcb);
}
int err = mprotect(p, size, PROT_READ | PROT_WRITE | PROT_EXEC);
if(err){
fprintf(stderr, "cannot mprotect code: %s\n", strerror(errno));
exit(-1);
}
return p;
}
@ -200,27 +210,21 @@ ikp ik_mmap_protected(int size){
ikpcb* ik_make_pcb(){
ikpcb* pcb = malloc(sizeof(ikpcb));
if(pcb == NULL){
fprintf(stderr, "Failed to allocate pcb\n");
exit(-1);
}
ikpcb* pcb = ik_malloc(sizeof(ikpcb));
bzero(pcb, sizeof(ikpcb));
#define HEAPSIZE (1024 * 4096)
#define STAKSIZE (1024 * 4096)
//#define STAKSIZE (256 * 4096)
pcb->heap_base = ik_mmap_protected(HEAPSIZE);
pcb->heap_size = HEAPSIZE;
pcb->allocation_pointer = pcb->heap_base;
pcb->allocation_redline = pcb->heap_base + HEAPSIZE - 2 * 4096;
pcb->stack_base = ik_mmap_protected(STAKSIZE);
pcb->stack_base = ik_mmap(STAKSIZE);
pcb->stack_size = STAKSIZE;
pcb->frame_pointer = pcb->stack_base + pcb->stack_size;
pcb->frame_base = pcb->frame_pointer;
pcb->frame_redline = pcb->stack_base + 2 * 4096;
ikdl* codes = &(pcb->codes);
codes->next = codes;
codes->prev = codes;
{
/* compute extent of heap and stack */
@ -251,8 +255,8 @@ ikpcb* ik_make_pcb(){
pcb->heap_size+2*pagesize,
mainheap_mt,
pcb);
set_segment_type(pcb->stack_base-pagesize,
pcb->stack_size+2*pagesize,
set_segment_type(pcb->stack_base,
pcb->stack_size,
mainstack_mt,
pcb);
}
@ -265,6 +269,7 @@ ikpcb* ik_make_pcb(){
ref(r, off_rtd_name) = 0;
ref(r, off_rtd_fields) = 0;
ref(r, off_rtd_printer) = 0;
ref(r, off_rtd_symbol) = 0;
ref(s, off_symbol_system_value) = r;
ref(s, off_symbol_value) = r;
}
@ -272,8 +277,22 @@ ikpcb* ik_make_pcb(){
}
void ik_delete_pcb(ikpcb* pcb){
assert(0);
free(pcb);
unsigned char* base = pcb->memory_base;
unsigned char* end = pcb->memory_end;
unsigned int* segment_vec = pcb->segment_vector;
int i = page_index(base);
int j = page_index(end);
while(i < j){
unsigned int t = segment_vec[i];
if(t != hole_mt){
ik_munmap((ikp)(i<<pageshift), pagesize);
}
i++;
}
int vecsize = (segment_index(end) - segment_index(base)) * pagesize;
ik_munmap(pcb->dirty_vector_base, vecsize);
ik_munmap(pcb->segment_vector_base, vecsize);
ik_free(pcb, sizeof(ikpcb));
}
@ -289,6 +308,8 @@ ik_alloc(ikpcb* pcb, int size){
}
else {
fprintf(stderr, "EXT\n");
assert(0);
#if 0
if(ap){
ikpages* p = ik_malloc(sizeof(ikpages));
p->base = pcb->heap_base;
@ -306,6 +327,7 @@ ik_alloc(ikpcb* pcb, int size){
nap = ap + size;
pcb->allocation_pointer = nap;
return ap;
#endif
}
}
@ -319,11 +341,33 @@ void ik_error(ikp args){
}
void ik_stack_overflow(){
fprintf(stderr, "entered ik_stack_overflow\n");
exit(-1);
void ik_stack_overflow(ikpcb* pcb){
fprintf(stderr, "entered ik_stack_overflow pcb=0x%08x\n", (int)pcb);
set_segment_type(pcb->stack_base, pcb->stack_size, data_mt, pcb);
ikp frame_base = pcb->frame_base;
ikp underflow_handler = ref(frame_base, -wordsize);
fprintf(stderr, "underflow_handler = 0x%08x\n", (int)underflow_handler);
/* capture continuation and set it as next_k */
ikp k = ik_alloc(pcb, align(continuation_size)) + vector_tag;
ref(k, -vector_tag) = continuation_tag;
ref(k, off_continuation_top) = pcb->frame_pointer;
ref(k, off_continuation_size) =
pcb->frame_base - (int)pcb->frame_pointer - wordsize;
ref(k, off_continuation_next) = pcb->next_k;
pcb->next_k = k;
pcb->stack_base = ik_mmap_typed(STAKSIZE, mainstack_mt, pcb);
pcb->stack_size = STAKSIZE;
pcb->frame_base = pcb->stack_base + pcb->stack_size;
pcb->frame_pointer = pcb->frame_base - wordsize;
pcb->frame_redline = pcb->stack_base + 2 * 4096;
ref(pcb->frame_pointer, 0) = underflow_handler;
return;
}
/*
char* ik_uuid(char* str){
assert((36 << fx_shift) == (int) ref(str, disp_string_length - string_tag));
uuid_t u;
@ -332,6 +376,33 @@ char* ik_uuid(char* str){
uuid_unparse_upper(u, str + disp_string_data - string_tag);
return str;
}
*/
static const char* uuid_chars =
"!$%&/0123456789<=>?ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz";
static int uuid_strlen = 1;
ikp ik_uuid(ikp str){
static int fd = -1;
if(fd == -1){
fd = open("/dev/urandom", O_RDONLY);
if(fd == -1){
return false_object;
}
uuid_strlen = strlen(uuid_chars);
}
int n = unfix(ref(str, off_string_length));
unsigned char* data = str+off_string_data;
read(fd, data, n);
unsigned char* p = data;
unsigned char* q = data + n;
while(p < q){
*p = uuid_chars[*p % uuid_strlen];
p++;
}
return str;
}
ikp ik_read(ikp fdptr, ikp bufptr, ikp lenptr){
@ -376,7 +447,7 @@ ikp ik_open_file(ikp str, ikp flagptr){
int f = unfix(flagptr);
char* path = (char*)(str + disp_string_data - string_tag);
if(f == 0){
flags = O_WRONLY;
flags = O_WRONLY | O_CREAT;
} else if(f == 1){
flags = O_WRONLY | O_APPEND;
} else if(f == 2){
@ -473,3 +544,118 @@ ik_dump_dirty_vector(ikpcb* pcb){
return void_object;
}
ikp
ikrt_make_code(ikp codesizeptr, ikp freevars, ikp rvec, ikpcb* pcb){
int code_size = unfix(codesizeptr);
int memreq = align_to_next_page(code_size + disp_code_data);
ikp mem = ik_mmap_code(memreq, 0, pcb);
ref(mem, 0) = code_tag;
ref(mem, disp_code_code_size) = codesizeptr;
ref(mem, disp_code_freevars) = freevars;
ref(mem, disp_code_reloc_vector) = rvec;
ik_relocate_code(mem);
return mem+vector_tag;
}
ikp
ikrt_set_code_reloc_vector(ikp code, ikp vec, ikpcb* pcb){
ref(code, off_code_reloc_vector) = vec;
ik_relocate_code(code-vector_tag);
pcb->dirty_vector[page_index(code)] = -1;
return void_object;
}
ikp
ikrt_strftime(ikp outstr, ikp fmtstr){
time_t t;
struct tm* tmp;
t = time(NULL);
tmp = localtime(&t);
if(tmp == NULL){
fprintf(stderr, "Error in time: %s\n", strerror(errno));
}
int rv =
strftime((char*)outstr+off_string_data,
unfix(ref(outstr, off_string_length)) + 1,
(char*)fmtstr+off_string_data,
tmp);
if(rv == 0){
fprintf(stderr, "Error in strftime: %s\n", strerror(errno));
}
return fix(rv);
}
ikp
ikrt_close_file(ikp fd, ikpcb* pcb){
int err = close(unfix(fd));
if(err == -1){
return false_object;
} else {
return true_object;
}
}
ikp
ikrt_read(ikp fd, ikp buff, ikpcb* pcb){
int bytes = read(unfix(fd), string_data(buff), unfix(ref(buff, off_string_length)));
if(bytes == -1){
return false_object;
} else {
return fix(bytes);
}
}
ikp
ikrt_open_input_file(ikp fname, ikpcb* pcb){
int fd = open(string_data(fname), O_RDONLY);
if(fd == -1){
return false_object;
} else {
return fix(fd);
}
}
ikp
ikrt_open_output_file(ikp fname, ikp flagptr, ikpcb* pcb){
/* [(error) 0] */
/* [(replace) 1] */
/* [(truncate) 2] */
/* [(append) 3] */
int flags;
int f = unfix(flagptr);
if(f == 0){
flags = O_WRONLY;
} else if(f == 1){
unlink(string_data(fname));
flags = O_WRONLY | O_CREAT;
} else if(f == 2){
flags = O_WRONLY | O_TRUNC;
} else if(f == 3){
flags = O_WRONLY | O_APPEND;
} else {
fprintf(stderr, "Error in S_open_file: invalid mode 0x%08x\n",
(int)flagptr);
exit(-10);
}
int fd = open(string_data(fname), flags,
S_IRUSR | S_IWUSR | S_IRGRP | S_IROTH);
if(fd == -1){
fprintf(stderr, "openfile failed!\n");
return false_object;
} else {
return fix(fd);
}
}
ikp
ikrt_write_file(ikp fd, ikp buff, ikp idx, ikpcb* pcb){
int bytes = write(unfix(fd), string_data(buff), unfix(idx));
return fix(bytes);
}
ikp
ikrt_write_char(){
fprintf(stderr, "ikrt_write_char\n");
return void_object;
}

65
src/runtime/ikarus-symbol-table.c
View File

@ -2,20 +2,19 @@
#include "ikarus.h"
#include <strings.h>
#include <string.h>
#include <stdlib.h>
static ikoblist*
static ikp
initialize_symbol_table(ikpcb* pcb){
#define NUM_OF_BUCKETS 4096 /* power of 2 */
ikoblist* st = ik_malloc(sizeof(ikoblist));
st->number_of_buckets = NUM_OF_BUCKETS;
int size = NUM_OF_BUCKETS * sizeof(ikbucket*);
st->buckets = ik_mmap(size);
bzero(st->buckets, size);
int size = align_to_next_page(disp_vector_data + NUM_OF_BUCKETS * wordsize);
ikp st = ik_mmap_ptr(size, 0, pcb) + vector_tag;
bzero(st-vector_tag, size);
ref(st, off_vector_length) = fix(NUM_OF_BUCKETS);
pcb->oblist = st;
return st;
}
static int
compute_hash(ikp str){
int len = unfix(ref(str, off_string_length));
@ -56,51 +55,33 @@ static ikp ik_make_symbol(ikp str, ikpcb* pcb){
}
ikp ik_oblist(ikpcb* pcb){
ikoblist* st = pcb->oblist;
int n = st->number_of_buckets;
ikbucket** bs = st->buckets;
ikp ac = null_object;
int i;
for(i=0; i<n; i++){
ikbucket* b = bs[i];
while(b){
ikp p = ik_alloc(pcb, pair_size) + pair_tag;
ref(p, off_car) = b->val;
ref(p, off_cdr) = ac;
ac = p;
b = b->next;
}
}
return ac;
fprintf(stderr, "oblist dead!\n");
exit(-1);
}
ikp ik_intern_string(ikp str, ikpcb* pcb){
//fprintf(stderr, "0x%08x: intern %s => ", (int)pcb, string_data(str));
ikoblist* st = pcb->oblist;
ikp st = pcb->oblist;
if(st == 0){
st = initialize_symbol_table(pcb);
}
int h = compute_hash(str);
int idx = h & (st->number_of_buckets - 1);
ikbucket* b = st->buckets[idx];
int idx = h & (unfix(ref(st, off_vector_length)) - 1);
ikp bckt = ref(st, off_vector_data + idx*wordsize);
ikp b = bckt;
while(b){
// if(b->key == (ikp) h){
ikp sym = b->val;
ikp sym_str = ref(sym, off_symbol_string);
if(strings_eqp(sym_str, str)){
//fprintf(stderr, "SAME %s\n", string_data(str));
return sym;
}
// }
b = b->next;
ikp sym = ref(b, off_car);
ikp sym_str = ref(sym, off_symbol_string);
if(strings_eqp(sym_str, str)){
return sym;
}
b = ref(b, off_cdr);
}
ikp sym = ik_make_symbol(str, pcb);
b = ik_malloc(sizeof(ikbucket));
b->key = (ikp)h;
b->val = sym;
b->next = st->buckets[idx];
st->buckets[idx] = b;
//fprintf(stderr, "NEW\n");
b = ik_alloc(pcb, pair_size) + pair_tag;
ref(b, off_car) = sym;
ref(b, off_cdr) = bckt;
ref(st, off_vector_data + idx*wordsize) = b;
pcb->dirty_vector[page_index(st+off_vector_data+idx*wordsize)] = -1;
return sym;
}

26
src/runtime/ikarus.h
View File

@ -3,6 +3,7 @@
#define IKARUS_H
#include <stdio.h>
#include <sys/resource.h>
extern int total_allocated_pages;
extern int total_malloced;
@ -72,21 +73,6 @@ typedef struct ikdl{ /* double-link */
struct ikdl* next;
} ikdl;
typedef struct ikhashtables{
ikp ht;
struct ikhashtables* next;
} ikhashtables;
typedef struct ikbucket{
ikp key;
ikp val;
struct ikbucket* next;
} ikbucket;
typedef struct{
int number_of_buckets;
ikbucket** buckets;
} ikoblist;
typedef struct {
/* the first locations may be accessed by some */
@ -109,15 +95,15 @@ typedef struct {
int heap_size;
ikp stack_base;
int stack_size;
ikpages* heap_pages;
ikdl codes;
ikhashtables* hash_tables;
ikoblist* oblist;
ikp oblist;
unsigned int* dirty_vector_base;
unsigned int* segment_vector_base;
unsigned char* memory_base;
unsigned char* memory_end;
int collection_id;
struct timeval collect_utime;
struct timeval collect_stime;
} ikpcb;
@ -135,8 +121,10 @@ void ik_munmap(void*, int);
void ik_munmap_from_segment(unsigned char*, int, ikpcb*);
ikpcb* ik_make_pcb();
void ik_delete_pcb(ikpcb*);
void ik_free_symbol_table(ikpcb* pcb);
void ik_fasl_load(ikpcb* pcb, char* filename);
void ik_relocate_code(ikp);
ikp ik_exec_code(ikpcb* pcb, ikp code_ptr);
void ik_print(ikp x);

14
src/set-operations.ss
View File

@ -1,11 +1,11 @@
(define list*
(lambda (fst . rest)
(let f ([fst fst] [rest rest])
(cond
[(null? rest) fst]
[else
(cons fst (f (car rest) (cdr rest)))]))))
;; (define list*
;; (lambda (fst . rest)
;; (let f ([fst fst] [rest rest])
;; (cond
;; [(null? rest) fst]
;; [else
;; (cons fst (f (car rest) (cdr rest)))]))))
(define (remq x ls)
(cond

43
src/time-read.ss Normal file
View File

@ -0,0 +1,43 @@
(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"]
))
(define (read-file x)
(with-input-from-file x
(lambda ()
(let f ()
(unless (eof-object? (read-char)) (f))))))
(define (read-all)
(for-each
(lambda (x)
(read-file (car x)))
scheme-library-files))
(define (do-times n f)
(unless (fxzero? n)
(f)
(do-times (fx- n 1) f)))
(do-times 10 read-all)

51
src/unsafe-record.ss Normal file
View File

@ -0,0 +1,51 @@
(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)])) ...
)))])))

55957
src/xpsyntax.pp
View File

File diff suppressed because it is too large Load Diff