From b09b9283cd5adbfa5e88a10f1473bdf1474a5df0 Mon Sep 17 00:00:00 2001 From: Thomas Hintz Date: Tue, 21 Aug 2018 21:42:50 -0700 Subject: [PATCH] Initial commit. --- Makefile | 49 +++ ev-environment.scm | 17 ++ ev-runtime.scm | 114 +++++++ ev.scm | 740 +++++++++++++++++++++++++++++++++++++++++++++ heap-writer.scm | 93 ++++++ packages.scm | 18 ++ ps-macros.scm | 4 + terminal.scm | 120 ++++++++ 8 files changed, 1155 insertions(+) create mode 100644 Makefile create mode 100644 ev-environment.scm create mode 100644 ev-runtime.scm create mode 100644 ev.scm create mode 100644 heap-writer.scm create mode 100644 packages.scm create mode 100644 ps-macros.scm create mode 100644 terminal.scm diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..99c48aa --- /dev/null +++ b/Makefile @@ -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 + diff --git a/ev-environment.scm b/ev-environment.scm new file mode 100644 index 0000000..5e03943 --- /dev/null +++ b/ev-environment.scm @@ -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)) diff --git a/ev-runtime.scm b/ev-runtime.scm new file mode 100644 index 0000000..7752549 --- /dev/null +++ b/ev-runtime.scm @@ -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)) + +) diff --git a/ev.scm b/ev.scm new file mode 100644 index 0000000..e31ed16 --- /dev/null +++ b/ev.scm @@ -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 "#"))) + +(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? diff --git a/heap-writer.scm b/heap-writer.scm new file mode 100644 index 0000000..7904501 --- /dev/null +++ b/heap-writer.scm @@ -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)) + )) diff --git a/packages.scm b/packages.scm new file mode 100644 index 0000000..69a008a --- /dev/null +++ b/packages.scm @@ -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)) + + diff --git a/ps-macros.scm b/ps-macros.scm new file mode 100644 index 0000000..8b0c6dc --- /dev/null +++ b/ps-macros.scm @@ -0,0 +1,4 @@ +(define-syntax cond-expand + (syntax-rules (prescheme) + ((_ (prescheme body ...) rest ...) + (begin body ...)))) diff --git a/terminal.scm b/terminal.scm new file mode 100644 index 0000000..1e62171 --- /dev/null +++ b/terminal.scm @@ -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))))))) + +