tjhintz
/
3l
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Initial commit.

Browse Source
master
Thomas Hintz 6 years ago
commit b09b9283cd
8 changed files with 1155 additions and 0 deletions
Show Stats Download Patch File Download Diff File

49
Makefile
Unescape Escape View File

@ -0,0 +1,49 @@
.PHONY: all rebuild clean spotless newimage
all: tos.sys
rebuild: clean all
run:
qemu-system-x86_64 -vga std -smp 8 -m 256 -drive id=disk,file=bmfs.image,format=raw,if=none -device ahci,id=ahci -device ide-drive,drive=disk,bus=ahci.0 -name "LLL"
tos.sys: vm.bin pure64.sys
dd if=/dev/zero of=kernel.bin bs=1M count=1
dd if=vm.bin of=kernel.bin bs=512 conv=notrunc
dd if=heap.bin of=kernel.bin seek=256 bs=512 conv=notrunc
./bmfs bmfs.image write kernel.bin
cat pure64.sys kernel64.sys > tos.sys
dd if=tos.sys of=bmfs.image bs=512 seek=16 conv=notrunc
vm.bin: vm.o vm-loader.o heap.bin
gcc -T vm.ld -o vm.bin -ffreestanding -O3 -nostdlib vm-loader.o vm.o -lgcc -mno-red-zone
vm.o: vm.c prescheme.h
gcc -O3 -o vm.o -c vm.c -nostdlib -nostartfiles -nodefaultlibs -mno-red-zone -std=gnu99 -ffreestanding
vm.c: ev.scm ps-macros.scm packages.scm terminal.scm
scheme48 -i ps-vm-compiler.image < compile-vm.scm
vm-loader.o: vm-loader.asm
nasm -f elf64 vm-loader.asm -o vm-loader.o
heap.bin: heap-writer.scm ev.scm ev-runtime.scm ev-environment.scm
csi -s heap-writer.scm
heap-debug.bin: heap-writer.scm ev.scm ev-runtime.scm ev-environment.scm
csi -D debug -s heap-writer.scm
newimage:
dd if=/dev/zero of=bmfs.image bs=1M count=8
./bmfs bmfs.image format /force
dd if=bmfs_mbr.sys of=bmfs.image bs=512 conv=notrunc
./bmfs bmfs.image create kernel.bin 1
make clean
clean:
rm -f *.o *.so *.bin tos.sys heap-writer vm.c
spotless:
rm -f bmfs.image
make clean

17
ev-environment.scm
Unescape Escape View File

@ -0,0 +1,17 @@
`(((quote set! type value eq?
nil env
+ -
cons car cdr
eval record vau wrap
byte-set!
type-eq?
xyz)
,(make-quote) ,(make-assign) ,(make-type) ,(make-value) ,(make-eq?)
,(make-nil) ,(make-env)
,(make-add) ,(make-sub)
,(make-cons) ,(make-car) ,(make-cdr)
,(make-eval) ,(make-record) ,(make-vau) ,(make-wrap)
,(make-byte-set!)
,(make-type-eq?)
10))

114
ev-runtime.scm
Unescape Escape View File

@ -0,0 +1,114 @@
(
(set! quote (vau ((x)) x))
(set! list (wrap (vau (elements) elements)))
(set! lambda
(vau ((formals body) env)
(wrap (eval (list (quote vau) (list formals) body) env))))
(set! *vga-mem* 753664)
(set! $eq?
(vau ((a b conseq alt) env)
(eval (eq? (eval a env) (eval b env)
conseq
alt)
env)))
(set! $type-eq?
(vau ((a b conseq alt) env)
(eval (type-eq? (eval a env) (eval b env)
conseq
alt)
env)))
(set! *nil-record* (nil))
(set! $null?
(vau ((x conseq alt) env)
(eval
($eq? (eval x env) *nil-record* conseq alt)
env)))
;; BUG not finding the variable bindings in a VAU
(lambda () 1)
;; (set! map
;; (lambda (proc lis)
;; ($null? lis
;; lis
;; (cons (proc (car lis)) (map proc (cdr lis))))))
;; ;; ((vau ((x y))
;; ;; body)
;; ;; (1 2))
;; (set! let
;; (vau ((vars body) env)
;; ((eval (list (quote vau) (list (map car vars))
;; body)
;; env))))
;; (set! cseq
;; (lambda (n op)
;; ($eq? n 5
;; 0
;; (cseq (+ n 1) (write-char (+ n 80))))))
;; (set! *a-pair* (cons 98 99))
;; (set! $pair?
;; (vau ((obj conseq alt) env)
;; (eval ($type-eq? (eval obj env) *a-pair* conseq alt) env)))
;; (set! char-rec-num 100)
;; (set! char-rec (record char-rec-num))
;; (set! char (lambda (n) (cons char-rec n)))
;; (set! char-val (lambda (c) (cdr c)))
;; (set! $char?
;; (vau ((obj conseq alt) env)
;; ((lambda (res)
;; (eval ($pair? res
;; (type-eq? (car res) char-rec conseq alt)
;; alt)
;; env))
;; obj)))
;; (set! write-char
;; ((lambda (pos)
;; (lambda (c)
;; (list (byte-set! pos (char-val c)) (set! pos (+ pos 2)))))
;; (+ *vga-mem* 8)))
;; (set! write-val
;; ((lambda (pos)
;; (lambda (v)
;; (list (byte-set! pos v) (set! pos (+ pos 2)))))
;; (+ *vga-mem* 8)))
;; ;; (map write-char
;; ;; (map char
;; ;; (list 72 101 108 108 111 44 32 119 111 114 108 100 33)))
;; (set! print
;; (lambda (obj)
;; ($char? obj
;; (map write-char (list (char 35) (char 92) obj))
;; ($pair? obj
;; (map print (list (char 40) (map print obj) (char 41)))
;; (write-char (char 33))
;; ))))
;; (set! print2
;; (lambda (obj)
;; ($char? obj
;; (write-char (char 72))
;; (write-char (char 73)))))
;; ;; BUG? type-eq? is evaluating its arguments? Isn't it supposed to
;; ;; though since it's a primitive? Yes, it is.
;; (write-val (type-eq? (car (char 80)) (car (char 100)) 89 78))
)

740
ev.scm
Unescape Escape View File

@ -0,0 +1,740 @@
;; Expands to variables prepended with enum name and a period (.). See
;; enum 'err' for an example.
(define-syntax enum
(lambda (x r c)
(let ((name (symbol->string (cadr x))))
`(,(r 'begin)
,@(map (lambda (var/val)
`(,(r 'define) ,(string->symbol
(string-append name
"."
(symbol->string (car var/val))))
,(cadr var/val)))
(caddr x))))))
(define-syntax define*
(syntax-rules ()
((_ x)
(syntax-error "invalid define* form " x))
((_ var val)
(define var val))
((_ var val rest ...)
(begin (define var val)
(define* rest ...)))))
;; nan: not a number
;; nap: not a pair
;; nar: not a record
;; example: err.nan-add
(enum err
((nan-add 0)
(nan-sub 1)
(nan-mult 2)
(nan-quotient 3)
(nan-remainder 4)
(nap-car 5)
(nap-cdr 6)
(nap-set-car! 7)
(nap-set-cdr! 8)
(unknown-inst 9)
(bad-arg-count-apply 10)
(ran-out-of-fuel 11)
(nar-record-type 12)
(nar-record-value 13)
(nan-untag-number 14)
(primitive-not-found 15)
(operation-not-found 16)
(variable-not-found 17)
(type-not-found 18)
(oom 19)
(nap-record-type 20) ; for record objs
))
(define* pair-mask #b1111
pair-spec #b0000
number-mask #b1
number-spec #b1 ; also in tag-number define-records macro
record-mask #b10
record-spec #b10)
;; NOTE! if word-size is not half of block-size update the algorithm
;; in (cons).
(define* *word-size* 8 ; bytes
*block-size* 16) ; bytes
;;;;;;; PreScheme ;;;;;;;
(cond-expand
(prescheme
(define* halt (external "PS_HALT" (=> () null))
vm-init (external "vm_init" (=> () null)))
; also in tag-number define-records macro
(define (twos-complement obj)
(if (>= obj 0)
(shift-left obj 1)
(shift-left (+ (bitwise-not (abs obj)) 1) 1)))
; also in tag-number define-records macro
(define* (tag-number obj) (bitwise-xor (twos-complement obj) number-spec)
(tag-record obj) (bitwise-xor (shift-left obj 2) record-spec)
(tag-nil) (tag-record (tag-number 0)) ; TODO check if prescheme inlines this
(nil) (tag-nil))
(define (matches-spec? obj mask spec) (= (bitwise-and obj mask) spec))
(define* (pair? obj) (matches-spec? obj pair-mask pair-spec)
(number? obj) (matches-spec? obj number-mask number-spec)
(record? obj) (matches-spec? obj record-mask record-spec)
(nil? obj) (= obj (tag-nil))) ; TODO make sure prescheme inlines
(define (untag-number obj)
(if (>= obj 0)
(arithmetic-shift-right obj 1)
(- 0 (+ (arithmetic-shift-right (bitwise-not obj) 1) 1))))
(define (untag-record obj) (arithmetic-shift-right obj 2))
(define *error* 0)
(define *error-obj* 999)
(define-syntax assert
(syntax-rules ()
((_ test good err-num print-obj err-val)
(if test good (begin (set! *error* err-num) (set! *error-obj* print-obj) err-val)))))
(define (untag-number/chk n)
(assert (number? n) (untag-number n) err.nan-untag-number n 0))
;; TODO check for overflows
;; TODO this doesn't work for negative numbers!
(define (twos-complement-add n n2)
(assert (and (number? n) (number? n2)) (+ n n2 -1) err.nan-add (list n n2) 0))
(define (twos-complement-sub n n2)
(assert (and (number? n) (number? n2)) (+ (- n n2) 1) err.nan-sub (list n n2) 0))
(define (mult n1 n2)
(assert (and (number? n1) (number? n2))
(tag-number (* (untag-number n1) (untag-number n1)))
err.nan-mult
(list n1 n2)
0))
(define (quotient/chk n1 n2)
(assert (and (number? n1) (number? n2))
(tag-number (quotient (untag-number n1) (untag-number n2)))
err.nan-quotient
(list n1 n2)
0))
(define (remainder/chk n1 n2)
(assert (and (number? n1) (number? n2))
(tag-number (remainder (untag-number n1) (untag-number n2)))
err.nan-remainder
(list n1 n2)
0))
;; (define (display-error n)
;; (unsigned-byte-set! (integer->address 753664) 69)
;; (unsigned-byte-set! (integer->address (+ 753664 2)) (+ n 48)))
(define (display-error n obj)
(terminal:put-char #\E)
(terminal:put-number n)
(terminal:put-char #\<)
(print* obj)
(terminal:put-char #\>)
(terminal:put-char #\space))
(define *alloc-address* null-address)
(define *end-of-memory* 0)
(define *oom-pair* 1) ; ??? 0 test as a "tagged" pair, so we aren't going with that
;; cons overshoots *end-of-memory* by block size
(define (cons a b)
(let ((start (address->integer *alloc-address*)))
(assert (< start *end-of-memory*)
(begin
(word-set! *alloc-address* a)
(word-set! (address+ *alloc-address* *word-size*) b)
(set! *alloc-address* (address+ *alloc-address* *block-size*))
start)
err.oom (tag-number -1) *oom-pair*)))
(define (car pair)
(assert (pair? pair) (word-ref (integer->address pair)) err.nap-car pair (tag-nil)))
(define (cdr pair)
(assert (pair? pair) (word-ref (address+ (integer->address pair) *word-size*))
err.nap-cdr pair (tag-nil)))
(define (car/chk pair)
(assert (pair? pair) (word-ref (integer->address pair)) err.nap-car pair (tag-nil)))
(define (cdr/chk pair)
(assert (pair? pair) (word-ref (address+ (integer->address pair) *word-size*))
err.nap-cdr pair (tag-nil)))
(define (set-car! pair val)
(assert (pair? pair) (word-set! (integer->address pair) val)
;; TODO find a better way to get prescheme to have the
;; correct return value for the error condition.
err.nap-set-car! (list pair val) (word-set! (integer->address #xffff00) 0)))
(define (set-cdr! pair val)
(assert (pair? pair) (word-set! (address+ (integer->address pair) *word-size*) val)
err.nap-set-cdr! (list pair val) (word-set! (integer->address #xffff00) 0)))
(define (alloc bytes)
(let ((beginning-of-block (address->integer *alloc-address*)))
(set! *alloc-address*
(address+ *alloc-address*
(if (<= bytes *block-size*)
*block-size*
(+ bytes (- *block-size* (remainder bytes *block-size*))))))
beginning-of-block))
(define (record-obj type val)
(cons (tag-record type) val))
(define (record-obj? obj)
(and (pair? obj) (record? (car obj))))
;; If OBJ is a pair that points to a record return its type.
(define (record-obj-type obj)
(assert (pair? obj)
(let ((rec (car obj)))
(assert (record? rec) rec
err.nar-record-type rec 0))
err.nap-record-type obj 0))
;; If OBJ is a pair that points to a record return its value.
(define (record-obj-value obj)
(assert (pair? obj)
(assert (record? (car obj)) (cdr obj)
err.nar-record-value obj 0)
err.nap-record-type obj 0))
(define null? nil?)
(define-syntax list
(syntax-rules ()
((_) (tag-nil))
((_ element)
(cons element (tag-nil)))
((_ element r)
(cons element (list r)))
((_ element r ...)
(cons element (list r ...)))))
(define (list-tail x k)
(if (= k 0)
x
(list-tail (cdr x) (- k 1))))
(define (list-ref lis k)
(car (list-tail lis k)))
(define (reverse lis)
(if (null? lis)
lis
(let loop ((remaining lis) (new-head (tag-nil)))
(if (pair? (cdr remaining))
(loop (cdr remaining)
(cons (car remaining) new-head))
(cons (car remaining) new-head)))))
(define (cadr x) (car (cdr x))) (define (caddr x) (car (cdr (cdr x))))
(define (cadddr x) (car (cdr (cdr (cdr x)))))
(define (cddr x) (cdr (cdr x))) (define (cdddr x) (cdr (cdr (cdr x))))
) ; end cond-expand prescheme
(else ; cond-expand else
(define (twos-complement obj)
(if (>= obj 0)
obj
(+ (bitwise-not (abs obj)) 1)))
(define (tag-number obj)
(bitwise-xor (arithmetic-shift (twos-complement obj) 1) number-spec))
(define (untag-number obj)
(if (>= obj 0)
(arithmetic-shift obj -1)
(- 0 (+ (arithmetic-shift (bitwise-not obj) -1) 1))))
(define untag-number/chk untag-number)
(define (twos-complement-add n n2)
(+ n n2 -1))
(define (twos-complement-sub n n2)
(+ (- n n2) 1))
(define quotient/chk quotient)
(define remainder/chk remainder)
;;; If you want easier debugging.
;; (define (twos-complement-add n n2) (+ n n2))
;; (define (twos-complement-sub n n2) (- n n2))
;; (define (tag-number n) n)
;; (define (untag-number n) n)
(define (tag-nil) '())
(define (nil) (tag-nil))
(define nil? null?)
(define-record-type record (tag-record value) record?
(value untag-record))
(define-record-printer record
(lambda (obj port)
(print "#<record " (untag-record obj) ">")))
(define (record-obj type val)
(cons (tag-record type) val))
(define (record-obj? obj)
(and (pair? obj) (record? (car obj))))
;; If OBJ is a pair that points to a record return its type.
(define (record-obj-type obj)
(if (record-obj? obj)
(car obj)
(error "not a record obj")))
;; If OBJ is a pair that points to a record return its value.
(define (record-obj-value obj)
(if (record-obj? obj)
(cdr obj)
(error "not a record obj")))
(define (word-set! addr val) (void))
(define (unsigned-byte-set! addr val)
(display val) (void))
(define (integer->address n) n)
(define *error* 0)
(define *error-obj* 999)
(define (put-number n) (display n))
(define (put-char c) (display c))
(define (halt) '())
(define (initialize) '())
(define-syntax goto
(syntax-rules ()
((_ body ...)
(begin (body ...)))))
(define (display-error n obj)
(error (conc "VM error: " n "<" obj ">")))
(define (mult n1 n2) (tag-number (* (untag-number n1) (untag-number n2))))
)) ; end cond-expand
(define-syntax define-records
(lambda (x r c)
;; TODO move iota and conc in to another pre-scheme module and
;; import for syntax
(define (iota k . start)
(define (iota* k i)
(if (< i k)
(cons i (iota* k (+ i 1)))
'()))
(let ((start (if (null? start) 0 (car start))))
(iota* (+ k start) start)))
(define (conc . r)
(apply string-append (map (lambda (x) (if (symbol? x) (symbol->string x) x)) r)))
(define (tag-number n)
(bitwise-xor (twos-complement n) #b1))
(define (twos-complement obj)
(if (>= obj 0)
(arithmetic-shift obj 1)
(arithmetic-shift (+ (bitwise-not (abs obj)) 1) 1)))
`(begin
,@(map
(lambda (inst n)
(let* ((has-args (list? inst))
(name (if has-args (car inst) inst))
(args (if has-args (cdr inst) '())))
`(begin (,(r 'define) (,(string->symbol (conc 'make- name)) ,@args)
,(if has-args
`(record-obj ,n (list ,@args))
`(tag-record ,n)))
,(if has-args
`(,(r 'define) (,(string->symbol (string-append (symbol->string name) "-type?")) ,(r 'obj))
(,(r 'and) (record-obj? ,(r 'obj))
(,(r '=) (untag-record (record-obj-type ,(r 'obj))) ,n)))
`(,(r 'define) (,(string->symbol (string-append (symbol->string name) "-type?")) ,(r 'obj))
(,(r 'and) (record? ,(r 'obj))
(,(r '=) (untag-record ,(r 'obj)) ,n))))
,@(if has-args
(map (lambda (arg slot)
`(,(r 'define) (,(string->symbol
(conc name '- arg))
,(r 'obj))
(list-ref (record-obj-value ,(r 'obj)) ,slot)))
args (iota (length args)))
'()))))
(cdr x) (map tag-number (iota (length (cdr x)) 1)))))) ; start at 1, 0 is nil
(define-records
variable ;; TODO not used?
quote
assign
call/cc
(symbol char-list)
type
value
tag
untag
eq?
nil
env
word-set!
word-ref
byte-set!
byte-ref
alloc
add
sub
mult
quotient
remainder
abs
cons
car
cdr
eval
;; (macro proc)
(operative vars dyn-var has-dyn-var? proc static-env)
(applicative obj)
wrap
unwrap
set-car!
set-cdr!
primitive
apply
record
vau
type-eq?
)
(cond-expand (prescheme 0) (else (define symbol-type? symbol?)))
(define (list-of-values exps env)
(if (null? exps)
(nil)
(cons (ev (car exps) env)
(list-of-values (cdr exps) env))))
(define (apply-primitive-proc proc args env)
;; TODO check num args
;; In process of converting from all primitives having all args
;; being evaled to just some of them.
(cond ((add-type? proc) (twos-complement-add (ev (car args) env)
(ev (car (cdr args)) env)))
((sub-type? proc) (twos-complement-sub (ev (car args) env)
(ev (car (cdr args)) env)))
((car-type? proc) (car/chk (ev (car args) env)))
((cdr-type? proc) (cdr/chk (ev (car args) env)))
((env-type? proc) env)
((eval-type? proc) (ev (car args) (ev (car (cdr args)) env)))
;; ((list-of-values-type? proc))
((cons-type? proc) (cons (ev (car args) env) (ev (car (cdr args)) env)))
((nil-type? proc) (nil))
((wrap-type? proc) (make-applicative (ev (car args) env)))
;; TODO this doesn't even make sense. Someone could
;; (tag-record -1) and then this would say it is a number!
;; ((type-type? proc) (cond ((number? (car args)) (tag-number -1))
;; ((record? (car args))
;; (untag-record (car args)))
;; ((nil? (car args)) (tag-number -2))
;; ((pair? (car args)) (tag-number -3)) ; TODO possible?
;; (else
;; (assert #f -3 err.type-not-found (tag-number -99)))))
((value-type? proc)
(let ((args (list-of-values args env)))
(cond ((record? (car args)) (untag-record (car args)))
((or (number? (car args)) (pair? args))
(car args))
(else
(assert #f -3 err.type-not-found (car args) (tag-number -98))))))
((record-type? proc) (tag-record (ev (car args) env)))
;; ((tag-type? proc) (record (car args) (car (cdr args))))
;; ((untag-type? proc) (cond ((number? (car args)) (car args))
;; ((record? (car args)) (record-value (car args)))))
;; ((set-car!-type? proc) (set-car! (car args) (car (cdr args))))
((byte-set!-type? proc)
(unsigned-byte-set!
(integer->address (untag-number/chk (ev (car args) env)))
(untag-number/chk (ev (car (cdr args)) env)))
(tag-number 0))
((eq?-type? proc)
(if (= (ev (car args) env) (ev (car (cdr args)) env))
(car (cdr (cdr args)))
(car (cdr (cdr (cdr args))))))
((type-eq?-type? proc)
(let ((a (ev (car args) env))
(b (ev (cadr args) env)))
(cond ((and (pair? a) (pair? b))
(car (cdr (cdr args))))
((and (record? a) (record? b)
(= (untag-record a) (untag-record b)))
(car (cdr (cdr args))))
((= a b)
(car (cdr (cdr args))))
(else (car (cdr (cdr (cdr args))))))))
(else
args
;; (assert #f #f err.primitive-not-found (tag-number 0))
))
)
(define (ev-sequence exps env)
(if (null? (cdr exps))
(ev (car exps) env)
(begin (ev (car exps) env)
(ev-sequence (cdr exps) env))))
;; (define (ev-apply proc args env)
;; (if (pair? proc)
;; (ev-sequence (cdr (cdr proc)) (extend-environment (car (cdr proc)) args (car proc)))
;; (apply-primitive-proc proc args env)))
(define (ev-args args env)
(let loop ((args args) (res (nil)))
(if (null? args)
(reverse res) ;; TODO store applicative and/or operative args
;; in reverse so we don't have to do a reverse here
(loop (cdr args) (cons (ev (car args) env) res)))))
(define (empty-list seed)
(let loop ((acc (nil)) (seed seed))
(if (null? seed) acc (loop (cons (nil) acc) (cdr seed)))))
(define (make-frame variables values)
(cons variables values))
(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))
(define (add-binding-to-frame! var val frame)
(set-car! frame (cons var (car frame)))
(set-cdr! frame (cons val (cdr frame))))
(define (assignment? op) (assign-type? op))
(define (assignment-variable exp) (car (cdr exp)))
(define (assignment-value exp) (car (cdr (cdr exp))))
(define (self-evaluating? exp)
(or (number? exp) (nil? exp) (operative-type? exp) (applicative-type? exp)
(and (not (symbol-type? exp)) (record? exp))))
(define (extend-environment vars vals base-env)
(cons (make-frame vars vals) base-env))
(define (find-variable var env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (cdr env)))
((eq? var (car vars))
(values vals #t))
(else (scan (cdr vars) (cdr vals)))))
(if (null? env)
(values var #f)
(let ((frame (car env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
(define (lookup-variable-value var env)
(receive (vals found) (find-variable var env)
(if found
(car vals)
(begin
;; (display-error var)
(display-error err.variable-not-found var)
err.variable-not-found))))
(define (set-variable-value! var val env)
(receive (vals found) (find-variable var env)
(if found
(set-car! vals val)
(add-binding-to-frame! var val (car env)))
(nil)))
(define-syntax guard
(syntax-rules (*error*)
((_ body ...)
(if (= *error* 0)
(begin body ...)
(begin
(display-error *error* *error-obj*)
(tag-number 999))))))
(define (extend-operative-environment op x e)
(let* ((not-list-arg (pair? (car (operative-vars op))))
(operative-var-list
(if not-list-arg
(operative-vars op)
(list (operative-vars op))))
(vals (if not-list-arg (cdr x) (list (cdr x)))))
(if (= (operative-has-dyn-var? op) 1)
(extend-environment (cons (operative-dyn-var op)
operative-var-list)
(cons e vals)
(operative-static-env op))
(extend-environment operative-var-list
vals
(operative-static-env op)))))
(define (construct-operative x e)
(if (nil? (cdr (car x)))
(make-operative (car (car x)) (nil) 0 (cdr x) e)
;; Include dynamic environment.
(make-operative (car (car x)) (car (cdr (car x))) 1 (cdr x) e)))
(define (ev x e)
(guard
(cond ((self-evaluating? x) x)
((symbol-type? x) (lookup-variable-value x e))
(else
(let ((op (ev (car x) e)))
(guard
(cond ((assignment? op)
(set-variable-value! (car (cdr x)) (ev (car (cdr (cdr x))) e) e))
((operative-type? op)
(ev-sequence
(operative-proc op)
(extend-operative-environment op x e)))
((applicative-type? op)
(ev (cons (applicative-obj op) (ev-args (cdr x) e)) e))
((vau-type? op)
(construct-operative (cdr x) e))
(else (apply-primitive-proc op (cdr x) e)))))))))
;; (define *prim-env*
;; (extend-environment
;; '(+ ev vau eval wrap set! nil cons env)
;; `(,(make-add)
;; ,(make-eval)
;; ,(make-vau)
;; ,(make-eval)
;; ,(make-wrap)
;; ,(make-assign)
;; ,(make-nil)
;; ,(make-cons)
;; ,(make-env))
;; (nil)))
;; (ev '((vau (elements) elements) 1 2 3)
;; *prim-env*)
;; ;; (ev '(set! quote* (vau ((x)) x))
;; ;; *prim-env*)
;; ;; (ev '(quote* xyz)
;; ;; *prim-env*)
(cond-expand (prescheme 0)
(else
(define (precompile-sexp x)
(cond ((number? x) (tag-number x))
((symbol? x)
(make-symbol
(map (compose tag-number char->integer)
(string->list (symbol->string x)))))))
(precompile-sexp 'set!)))
(define *env* #x220000)
;; (define *oblist* #x220010)
(define *exps* #x220008)
(define s-add 0)
(define s-set! 0)
(define s-x 0)
(define (print-debug-table start words)
(let loop ((i 0))
(if (< i words)
(begin (terminal:put-number (+ start (* i 8)))
(terminal:put-char #\:)
(terminal:put-char #\space)
(terminal:put-number
(word-ref (integer->address (+ start (* i 8)))))
(terminal:put-char #\newline)
(loop (+ i 1))))))
(define (print* obj)
(cond ((number? obj)
(terminal:put-number (untag-number obj)))
((symbol-type? obj)
(let loop ((o (symbol-char-list obj)))
(terminal:put-char (ascii->char (untag-number (car/chk o))))
(if (not (nil? (cdr o)))
(loop (cdr/chk o)))))
((record? obj)
(terminal:put-char #\#)
(terminal:put-char #\<)
(terminal:put-number (untag-number (untag-record obj)))
(terminal:put-char #\>))
((pair? obj)
;; must not be in a function or prescheme could make it in to
;; a dependency loop
(terminal:put-char #\()
(let loop ((o obj))
(print* (car o))
(if (not (nil? (cdr o)))
(begin (terminal:put-char #\space)
(if (pair? (cdr o))
(loop (cdr o))
(begin (terminal:put-char #\.)
(terminal:put-char #\space)
(print* (cdr o)))))))
(terminal:put-char #\)))
((nil? obj)
(terminal:put-char #\()
(terminal:put-char #\)))
(else (terminal:put-char #\E))))
(define (run-ev)
(set! *alloc-address* (integer->address #x300000))
;; a single pair will be consed after this location
(set! *end-of-memory* #x1000000) ; 32 MiB
(set! *oom-pair* (cons (make-nil) (make-nil)))
(set! *env* (word-ref (integer->address *env*)))
(set! *exps* (word-ref (integer->address *exps*)))
(let loop ((exps (car *exps*)))
(if (null? (cdr exps))
(ev (car exps) *env*)
(begin (ev (car exps) *env*)
(loop (cdr exps)))))
)
(define (keyboard-handler key)
(+ key 0))
(define (kmain)
;; see note in prescheme.h
(vm-init)
;; (init)
(terminal:initialize)
(run-ev)
(let loop ()
(halt)
(loop))
)
;; NOTE!
;; dynamic variable binding can be accomplished by looking up a
;; variable in the dynamic environment instead of the lexical
;; environment that was stored when the procedure was created.
;; if one wants a variable to be dynamic scoped for calls later on it
;; can bind a variable in the static environment to the one in the
;; dynamic environment.
;; (define bar `(,(env) (x) (baz x)))
;; (bar (lookup-variable x (current-env))) ; x is dynamic for the
;; ; duration of the execution of
;; ; bar's body
;; NOTE! is it possible to do tail-recursion with the current
;; evaluator if the code in the tail position is always evaluated in
;; its own loop?

93
heap-writer.scm
Unescape Escape View File

@ -0,0 +1,93 @@
(import chicken scheme ports data-structures)
(use srfi-1 extras posix)
(include "ev.scm")
(define (symbol->num-list sym)
(map char->integer (string->list (symbol->string sym))))
(define (write-val v)
(let loop ((v v) (acc '()))
(if (= v 0)
(for-each write-byte
(reverse
;; NOTE assumes little endian
(append (make-list (- *word-size* (length acc)) 0) acc)))
(loop (quotient v 256) (cons (remainder v 256) acc)))))
(define a (if (feature? 'debug)
0
#x220000))
(if (= a 0)
(begin (newline) (print "!!!!!! heap-writer DEBUG MODE !!!!!") (newline)))
(define (write-cons obj1 obj2)
(let ((start a))
(write-val obj1)
(write-val obj2)
(set! a (+ a 16))
start))
(define *oblist* '())
(define (make-heap obj)
(define (tag-record obj) (bitwise-xor (arithmetic-shift obj 2) record-spec))
(define symbol-tag (tag-record (untag-record (record-obj-type (make-symbol '())))))
(define (tag-nil) (tag-record (tag-number 0)))
(define (has-symbol? sym)
(alist-ref sym *oblist*))
(define (push-oblist-symbol sym loc)
(set! *oblist* (cons (cons sym loc) *oblist*)))
(define (oblist-symbol-record sym)
(alist-ref sym *oblist*))
;; (define (tag-number n) n)
(define (loop obj)
(cond ((number? obj)
(tag-number obj))
((nil? obj)
(tag-nil))
((record? obj)
(tag-record (untag-record obj)))
((record-obj? obj)
(write-cons (tag-record (untag-record (record-obj-type obj)))
(loop (record-obj-value obj))))
((symbol? obj)
(if (has-symbol? obj)
(oblist-symbol-record obj)
(let ((rec (write-cons symbol-tag
(write-cons (loop (symbol->num-list obj))
(tag-nil)))))
(push-oblist-symbol obj rec)
rec)))
((pair? obj)
(write-cons (loop (car obj)) (loop (cdr obj))))
(else (error "unknown"))))
(loop obj))
(with-output-to-file (if (feature? 'debug) "heap-debug.bin" "heap.bin")
(lambda ()
;; (set! a 0)
;; (set! *oblist* '())
;; lets call the stuff at the beginning "the header"
;; could also include the tip of the oblist (and make the oblist
;; an actual list of its own) Also, make the header real big for
;; future binary compatibility so more things can be added to it
;; without causing old images to become invalid
;; also make the values in the headers offsets and have ev.scm
;; calculate the actual location that way the heap can be moved to
;; places in memory without having to recompile
;; ALSO add to header the end of the heap so that *alloc-address*
;; can be set to it when run-ev starts
(write-val 0) ; written over for env start address
(write-val 0) ; written over for exps start address
(set! a (+ a 16))
(make-heap (eval (car (read-file "ev-environment.scm"))))
(let ((fp (file-position (current-output-port))))
(set-file-position! (current-output-port) 0)
(write-val (- a 16))
(set-file-position! (current-output-port) fp))
(make-heap (read-file "ev-runtime.scm"))
(set-file-position! (current-output-port) 8)
(write-val (- a 16))
))

18
packages.scm
Unescape Escape View File

@ -0,0 +1,18 @@
(define-structure vm
(export kmain keyboard-handler
)
(open prescheme ps-memory ps-receive ps-macros (modify terminal (prefix terminal:)))
(for-syntax (open scheme bitwise))
(files ev))
(define-structure ps-macros
(export cond-expand)
(open prescheme)
(files ps-macros))
(define-structure terminal
(export initialize put-number put-char)
(open prescheme ps-memory)
(files terminal))

4
ps-macros.scm
Unescape Escape View File

@ -0,0 +1,4 @@
(define-syntax cond-expand
(syntax-rules (prescheme)
((_ (prescheme body ...) rest ...)
(begin body ...))))

120
terminal.scm
Unescape Escape View File

@ -0,0 +1,120 @@
(define-syntax enum
(lambda (x r c)
(let ((name (symbol->string (cadr x))))
`(,(r 'begin)
,@(map (lambda (var/val)
`(,(r 'define) ,(string->symbol
(string-append name
"."
(symbol->string (car var/val))))
,(cadr var/val)))
(caddr x))))))
(define (word-set-at! addr index val)
(word-set! (address+ addr index) val))
(define-syntax set++!
(syntax-rules ()
((_ v)
(begin (set! v (+ v 1)) v))))
(define-syntax set--!
(syntax-rules ()
((_ v)
(begin (set! v (- v 1)) v))))
(define (ipow base exp)
(let loop ((r 1) (exp exp) (base base))
(if (> exp 0)
(let ((nr
(if (> (bitwise-and exp 1) 0)
(* r base)
r)))
(loop nr (arithmetic-shift-right exp 1) (* base base)))
r)))
(enum vga-color
((black 0)
(blue 1)
(green 2)
(cyan 2)
(red 4)
(magenta 5)
(brown 6)
(light-grey 7)
(dark-grey 8)
(light-blue 9)
(light-green 10)
(light-cyan 11)
(light-red 12)
(light-magenta 13)
(light-brown 14)
(white 15)))
(define (make-color fg bg)
(bitwise-ior fg (shift-left bg 4)))
(define (make-vga-entry c color)
(bitwise-ior c (shift-left color 8)))
(define *terminal-index*)
(define *terminal-color*)
(define *terminal-buffer*)
(define (initialize)
(set! *terminal-index* 0)
(set! *terminal-color* (make-color vga-color.green vga-color.black))
(set! *terminal-buffer* (integer->address #xB8000))
(let loop ((y 0))
(if (< y 4000)
(begin
(word-set! (address+ *terminal-buffer* y)
(make-vga-entry (char->ascii #\space)
*terminal-color*))
(loop (+ y 2)))))
)
(define (set-color color)
(set! *terminal-color* color))
(define (put-entry-at c color index)
(word-set-at! *terminal-buffer* index
(make-vga-entry (char->ascii c) color)))
(define (put-char c)
(if (char=? c #\newline)
(begin
(set! *terminal-index*
(+ *terminal-index* (- 160 (remainder *terminal-index* 160)))))
(begin
(put-entry-at c *terminal-color* *terminal-index*)
(set! *terminal-index* (+ *terminal-index* 2)))))
(define *ascii-numeric-start* 48)
(define (put-number num)
;; Can handle up to a uint32
(define (num-digits num n)
(cond ((>= num 100000000)
(num-digits (quotient num 100000000) (+ n 8)))
((>= num 10000)
(num-digits (quotient num 10000) (+ n 4)))
((>= num 100)
(num-digits (quotient num 100) (+ n 2)))
((>= num 10)
(+ n 1))
(else n)))
(if (< num 0)
(put-char #\-))
(let ((ndigits (num-digits (abs num) 1)))
(let loop ((digits-remaining (- ndigits 1))
(mult (ipow 10 (- ndigits 1)))
(num (abs num)))
(put-char
(ascii->char (+ *ascii-numeric-start* (quotient num mult))))
(if (> digits-remaining 0)
(let ((remains (- digits-remaining 1)))
(loop remains (ipow 10 remains) (remainder num mult)))))))
Write Preview
Loading…
Cancel
Save