You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
94 lines
3.3 KiB
Scheme
94 lines
3.3 KiB
Scheme
(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))
|
|
))
|