304 lines
8.5 KiB
Scheme
304 lines
8.5 KiB
Scheme
;;; Static heaps for the Scheme Shell
|
|
;;; Copyright (c) 1994 by Brian D. Carlstrom. See file COPYING.
|
|
|
|
;;; based on Scheme48 implementation.
|
|
;;; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees.
|
|
|
|
;;; TODO
|
|
;;; get it working
|
|
|
|
#!
|
|
,config ,load vm/ps-interface.scm
|
|
,config ,load vm/interfaces.scm
|
|
,config ,load vm/package-defs.scm
|
|
;; Undefined: (pre-scheme vm-utilities system-spec external)
|
|
,config ,load vm/s48-package-defs.scm
|
|
|
|
,load-package bigbit
|
|
,load-package destructuring
|
|
|
|
,load-package heap
|
|
,in heap
|
|
(define (newspace-begin) *newspace-begin*)
|
|
(define (heap-pointer) *hp*)
|
|
,structure heap-extra (export newspace-begin
|
|
heap-pointer
|
|
header-a-units
|
|
d-vector?
|
|
stob-type)
|
|
|
|
,config
|
|
(define-structure static (export do-it
|
|
make-static-heap
|
|
test)
|
|
(open scheme heap memory data stob struct
|
|
heap-extra
|
|
vm-architecture
|
|
formats
|
|
enumerated
|
|
signals
|
|
scsh)
|
|
(files (scsh static)))
|
|
|
|
,user
|
|
,load-package static
|
|
,open static
|
|
(test)
|
|
!#
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define *scsh-image* "scsh/scsh.image") ; input file
|
|
(define *scsh-image* "debug/tiny.image") ; input file
|
|
(define *image-lib* "scsh.a") ; output file
|
|
(define *temp-dir* (string-append
|
|
"/tmp/"
|
|
"scsh"
|
|
(number->string
|
|
(pid)))) ;; prefix for temp files - in their own dir
|
|
(define *prefix* (string-append *temp-dir* "/"))
|
|
|
|
(define (make-static-heap image archive)
|
|
(if (file-exists? *temp-dir*)
|
|
(if (equal? 'directory (file-info:type (file-attributes *temp-dir*)))
|
|
(with-cwd *temp-dir*
|
|
(map delete-file (directory-files *temp-dir* #t)))
|
|
(delete-file *temp-dir*)))
|
|
(create-directory *temp-dir* #o755 #t)
|
|
(let ((size (file-info:size (file-attributes image))))
|
|
(do-it size image *prefix*)))
|
|
|
|
(define (test)
|
|
(make-static-heap *scsh-image* *image-lib*))
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
|
|
; For example:
|
|
; (do-it 100000 "~/s48/debug/little.image" "little-heap.c")
|
|
;
|
|
; The first argument to do-it should be somewhat larger than the size,
|
|
; in bytes, of the image file to be converted (which you can obtain with
|
|
; "ls -l").
|
|
;
|
|
; If the image contains 0-length stored objects, then the .c file will
|
|
; have to be compiled by gcc, since 0-length arrays aren't allowed in
|
|
; ANSI C. This wouldn't be difficult to work around.
|
|
|
|
(define *comments?* #f)
|
|
|
|
; 800,000 bytes => 200,000 words => at least 100,000 objects
|
|
; 50 chunks => 16,000 bytes per chunk => 2,000 objects per chunk
|
|
(define *chunk-size* 10000)
|
|
|
|
(define (do-it bytes infile prefix)
|
|
(let ((start (init bytes infile)))
|
|
(emit-area-declarations "p" immutable? "const " prefix)
|
|
(emit-area-declarations "i" mutable? "" prefix)
|
|
(emit-area-initializers "p" immutable? "const " prefix)
|
|
(emit-area-initializers "i" mutable? "" prefix)
|
|
(call-with-output-file (string-append prefix "entry.c")
|
|
(lambda (port)
|
|
(display "#include \"" port)
|
|
(display prefix port)
|
|
(display (descriptor-include start) port)
|
|
(display ".h\"" port)
|
|
(newline port)
|
|
(display "const long entry = " port)
|
|
(emit-descriptor start port)
|
|
(write-char #\; port)
|
|
(newline port)))))
|
|
|
|
(define (init bytes infile)
|
|
(create-memory (quotient bytes 2) quiescent) ;Output of ls -l
|
|
(initialize-heap (memory-begin) (memory-size))
|
|
(let ((start (read-image infile 0)))
|
|
(let ((n (nchunks)))
|
|
(message n (if (= n 1) " chunk" " chunks")))
|
|
start))
|
|
|
|
(define (nchunks) (+ (chunk-number (heap-pointer)) 1))
|
|
|
|
; emit struct declarations for areas
|
|
|
|
(define (emit-area-declarations name in-area? const prefix)
|
|
(for-each-stored-object
|
|
(string-append prefix name) ".h"
|
|
(lambda (chunk port)
|
|
(message name chunk " declaration")
|
|
(format port "#define D(x) (long)(&x)+7~%")
|
|
(format port "#define H unsigned long~%")
|
|
(display "struct " port) (display name port) (display chunk port)
|
|
(display " {" port) (newline port))
|
|
(lambda (x port)
|
|
(if (in-area? x)
|
|
(emit-declaration x port)))
|
|
(lambda (chunk port)
|
|
(display "};" port)
|
|
(newline port)
|
|
(display const port)
|
|
(display "extern struct " port)
|
|
(display name port)
|
|
(display chunk port)
|
|
(write-char #\space port) (display name port) (display chunk port)
|
|
(write-char #\; port) (newline port)
|
|
chunk)))
|
|
|
|
(define (emit-declaration x port)
|
|
(display " H x" port)
|
|
(writex x port)
|
|
(cond ((d-vector? x)
|
|
(display "; long d" port)
|
|
(writex x port)
|
|
(write-char #\[ port)
|
|
(write (d-vector-length x) port))
|
|
((vm-string? x)
|
|
(display "; char d" port)
|
|
(writex x port)
|
|
(write-char #\[ port)
|
|
;; Ensure alignment (thanks Ian)
|
|
(write (cells->bytes (bytes->cells (b-vector-length x)))
|
|
port))
|
|
(else
|
|
(display "; unsigned char d" port)
|
|
(writex x port)
|
|
(write-char #\[ port)
|
|
;; Ensure alignment
|
|
(write (cells->bytes (bytes->cells (b-vector-length x)))
|
|
port)))
|
|
(display "];" port)
|
|
(if *comments?*
|
|
(begin (display " /* " port)
|
|
(display (enumerand->name (stob-type x) stob) port)
|
|
(display " */" port)))
|
|
(newline port))
|
|
|
|
; Emit initializers for areas
|
|
|
|
(define (emit-area-initializers name in-area? const prefix)
|
|
(for-each-stored-object
|
|
(string-append prefix name) ".c"
|
|
(lambda (chunk port)
|
|
(message name chunk " initializer")
|
|
(display const port)
|
|
(display "struct " port) (display name port) (write chunk port)
|
|
(write-char #\space port) (display name port) (write chunk port)
|
|
(display " =" port) (newline port)
|
|
|
|
(write-char #\{ port) (newline port))
|
|
(lambda (x port)
|
|
(if (in-area? x)
|
|
(emit-initializer x port)))
|
|
(lambda (chunk port)
|
|
(display "};" port) (newline port)))
|
|
|
|
(call-with-output-file
|
|
(string-append prefix ".c")
|
|
(lambda (port)
|
|
(let ((n (nchunks)))
|
|
(format port "const long ~a_count = ~s;~%" name n)
|
|
(format port "~a long * const ~a_areas[~s] = {" const name n)
|
|
(do ((i 0 (+ i 1)))
|
|
((= i n))
|
|
(format port "(~a long *)&~a~s, " const name i))
|
|
(format port "};~%const long ~a_sizes[~s] = {" name n)
|
|
(do ((i 0 (+ i 1)))
|
|
((= i n))
|
|
(format port "sizeof(~a~s), " name i))
|
|
(format port "};~%")))))
|
|
|
|
|
|
(define (message . stuff)
|
|
(for-each display stuff) (newline))
|
|
|
|
(define (emit-initializer x port)
|
|
(display " " port)
|
|
(write (stob-header x) port)
|
|
(write-char #\, port)
|
|
(cond ((d-vector? x)
|
|
(emit-d-vector-initializer x port))
|
|
((vm-string? x)
|
|
(write-char #\" port)
|
|
(let ((len (vm-string-length x)))
|
|
(do ((i 0 (+ i 1)))
|
|
((= i len) (write-char #\" port))
|
|
(let ((c (vm-string-ref x i)))
|
|
(cond ((or (char=? c #\") (char=? c #\\))
|
|
(write-char #\\ port))
|
|
((char=? c #\newline)
|
|
(display "\\n\\" port)))
|
|
(write-char c port)))))
|
|
(else
|
|
(write-char #\{ port)
|
|
(let ((len (b-vector-length x)))
|
|
(do ((i 0 (+ i 1)))
|
|
((= i len) (write-char #\} port))
|
|
(write (b-vector-ref x i) port)
|
|
(write-char #\, port)))))
|
|
(write-char #\, port)
|
|
(if *comments?*
|
|
(begin (display " /* " port)
|
|
(writex x port)
|
|
(display " */" port)))
|
|
(newline port))
|
|
|
|
(define (emit-d-vector-initializer x port)
|
|
(write-char #\{ port)
|
|
(let ((len (d-vector-length x)))
|
|
(do ((i 0 (+ i 1)))
|
|
((= i len) (write-char #\} port))
|
|
(emit-descriptor (d-vector-ref x i) port)
|
|
(write-char #\, port))))
|
|
|
|
(define (emit-descriptor x port)
|
|
(if (stob? x)
|
|
(begin (if (immutable? x)
|
|
(display "D(p" port)
|
|
(display "D(i" port))
|
|
(display (chunk-number x) port)
|
|
(display ".x" port)
|
|
(writex x port)
|
|
(write-char #\) port))
|
|
(write x port)))
|
|
|
|
; hacked emit-descriptor returns chunk or #f
|
|
(define (descriptor-include x)
|
|
(if (stob? x)
|
|
(string-append
|
|
(if (immutable? x) "p" "i")
|
|
(number->string (chunk-number x)))
|
|
#f))
|
|
|
|
; Foo
|
|
|
|
(define (writex x port)
|
|
(write (quotient (- (- x (memory-begin)) 7) 4) port))
|
|
|
|
(define (chunk-number x)
|
|
(quotient (- (- x (memory-begin)) 7) *chunk-size*))
|
|
|
|
|
|
; Image traversal utility
|
|
|
|
(define (for-each-stored-object suffix chunk-start proc chunk-end)
|
|
(let ((limit (heap-pointer)))
|
|
(let chunk-loop ((addr (newspace-begin))
|
|
(i 0)
|
|
(chunk (+ (newspace-begin) *chunk-size*)))
|
|
(if (addr< addr limit)
|
|
(begin
|
|
(chunk-start i)
|
|
(let loop ((addr addr))
|
|
(if (and (addr< addr limit)
|
|
(addr< addr chunk))
|
|
(let ((d (fetch addr)))
|
|
(if (not (header? d))
|
|
(warn "heap is in an inconsistent state" d))
|
|
(proc (address->stob-descriptor (addr1+ addr)))
|
|
(loop (addr1+ (addr+ addr (header-a-units d)))))
|
|
(begin (chunk-end i)
|
|
(chunk-loop addr
|
|
(+ i 1)
|
|
(+ chunk *chunk-size*))))))))))
|
|
|
|
(define (mutable? x) (not (immutable? x)))
|