scsh-0.5/scsh/static.scm.in

814 lines
26 KiB
Scheme
Raw Normal View History

#!@prefix@/lib/scsh/scshvm \
1996-08-24 05:27:47 -04:00
-o @prefix@/lib/scsh/scshvm -h 8000000 -i @prefix@/lib/scsh/scsh.image -lm @prefix@/lib/scsh/vm/ps-interface.scm -lm @prefix@/lib/scsh/vm/interfaces.scm -lm @prefix@/lib/scsh/vm/package-defs.scm -lm @prefix@/lib/scsh/vm/s48-package-defs.scm -dm -m static-heaps -e static-heap-linker -s
1995-10-31 18:16:31 -05:00
!#
1996-08-24 05:27:47 -04:00
#!
For testing load this at a scsh prompt
,config ,load ../vm/ps-interface.scm
,config ,load ../vm/interfaces.scm
,config ,load ../vm/package-defs.scm
,config ,load ../vm/s48-package-defs.scm
,config ,load static.scm
,load-package static-heaps
,in static-heaps
!#
;;; Static heap package for the Scheme Shell
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Copyright (c) 1995-1996 by Brian D. Carlstrom.
;;;
1995-10-31 18:16:31 -05:00
;;; based on Scheme48 implementation.
;;; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees.
1996-08-24 05:27:47 -04:00
;;;
;;; The business of this package is converting a Scheme 48 bytecode
;;; image as embodied in a .image file to a C representation. This C
;;; code is then compiled and linked in with a virtual machine. One
;;; pleasant side effect of this is reduced startup times. Another
;;; good thing is that immutable parts of the image can be shared
;;; between processes.
(define-structure static-heaps
(export static-heap-linker)
1995-10-31 18:16:31 -05:00
(open scheme heap memory data stob struct
heap-extra
vm-architecture
formats
enumerated
signals
tables
defrec-package
scsh)
(begin
1996-08-24 05:27:47 -04:00
;;; static-heap-linker
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; the external entry point
;;; real work in static-heap-linker1
;;; argl is a list of the command line arguments
(define (static-heap-linker argl)
(cond ((not (= (length argl) 3))
(format #t
"usage: ~a input-image-file output-executible-file"
(car argl))
(exit 1)))
(let ((temp-dir ; place for intermediate .c .o files
(or (getenv "TMPDIR")
"@TMPDIR@"))
(cc-command ; command to compile a .c file
(or (getenv "CC")
"@CC@ @CFLAGS@"))
(ld-flags ; flags needed to link executible
(or (getenv "LDFLAGS")
"@LDFLAGS@"))
(libraries ; linbraries need to link executible
(or (getenv "LIBS")
"@LIBS@"))
(input-image ; the input scheme image file
(cadr argl))
(output-executible ; the output executible file
(caddr argl)))
(static-heap-linker1 input-image temp-dir output-executible
cc-command ld-flags libraries)
(exit 0)))
;;; heap structure
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1995-10-31 18:16:31 -05:00
(define-record heap
(length 0)
(objects '())
)
1996-08-24 05:27:47 -04:00
;;; static-heap-linker1
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (static-heap-linker1 input-image tempdir output-executible
cc-command ld-flags libraries)
(let* ((temp-dir ; make a unique directory with pid
(format #f "~a/scsh~s" tempdir (pid)))
(output-file ; executible relateive to cwd
(string-append (cwd) "/" output-executible))
(start ; entry point of image
(read-heap-image input-image))) ; *** READ ***
1995-10-31 18:16:31 -05:00
(receive (pure impure reloc externs)
1996-08-24 05:27:47 -04:00
(create-heaps-and-tables) ; *** EVAL ***
;;; if directory exists blow it away
;;; useful for repeated runs from within same scsh process
1995-10-31 18:16:31 -05:00
(if (file-exists? temp-dir)
(if (file-directory? temp-dir)
(with-cwd temp-dir
(map delete-file (directory-files temp-dir #t)))
(delete-file temp-dir)))
(create-directory temp-dir #o755 #t)
1996-08-24 05:27:47 -04:00
(with-cwd temp-dir ; *** PRINT ***
(write-c-header-file pure impure externs)
(write-c-image pure impure reloc externs)
(write-main-c-file start reloc)
(compile-c-files cc-command)
(link-files cc-command ld-flags libraries
output-file)
(map delete-file (directory-files temp-dir #t)))
(delete-directory temp-dir))))
;;; read-heap-image
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; reads the scheme48 bytecode image into memory.
;;; returns entry point.
1995-10-31 18:16:31 -05:00
(define (read-heap-image infile)
(let ((bytes (file-info:size (file-info infile))))
(init (inexact->exact (floor (* 1.1 bytes))) infile)))
1996-08-24 05:27:47 -04:00
; XXX need little extra space for find-all-xs
;;; create-heaps-and-tables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Walks over the in memory scheme 48 heap image.
;;; Returns
;;; 1.) vector of heaps describing pure heap objects
;;; 2.) vector of heaps describing impure heap objects
;;; 3.) vector of tables descibing relocations
;;; 4.) table of external references
1995-10-31 18:16:31 -05:00
(define (create-heaps-and-tables)
1996-08-24 05:27:47 -04:00
(let* ((n (nchunks)) ; number of chunks we have in image
( pure (make-vector n)) ; immutable bits of each chunk
(impure (make-vector n)) ; mutable bits of each chunk
(reloc (make-vector n)) ; relocation information
(externs (make-table))) ; external references
;; create empty heaps for each chunk
1995-10-31 18:16:31 -05:00
(let loop ((i 0))
(cond ((not (= i n))
1996-08-24 05:27:47 -04:00
(vector-set! pure i (make-heap))
(vector-set! impure i (make-heap))
1995-10-31 18:16:31 -05:00
(vector-set! reloc i (make-table))
(loop (+ i 1)))))
1996-08-24 05:27:47 -04:00
;; here is where we iterate through all the bits
;; we construct our own data structures describing the layout
1995-10-31 18:16:31 -05:00
(scsh-for-each-stored-object
(lambda (chunk)
(format #t "Reading chunk number ~s" chunk))
(lambda (chunk x len)
1996-08-24 05:27:47 -04:00
(let* ((heap ; choose the appropriate heap
(vector-ref (if (mutable? x) impure pure) chunk)))
;; add the relocation information
1995-10-31 18:16:31 -05:00
(table-set! (vector-ref reloc chunk) x (heap:length heap))
1996-08-24 05:27:47 -04:00
;; add object reference to heap chunk
1995-10-31 18:16:31 -05:00
(set-heap:objects heap (cons x (heap:objects heap)))
1996-08-24 05:27:47 -04:00
;; update current heap chunk length
1995-10-31 18:16:31 -05:00
(set-heap:length heap (+ len (heap:length heap)))
1996-08-24 05:27:47 -04:00
;; if we have an external reference handle add it to the list
(if (= (header-type (stob-header x)) (enum stob external))
(table-set! externs
(external-value x)
(vm-string->string (external-name x))))))
1995-10-31 18:16:31 -05:00
(lambda (chunk)
(newline)))
1996-08-24 05:27:47 -04:00
;; put all the heaps in the correct order
1995-10-31 18:16:31 -05:00
(let loop ((i 0))
(cond ((not (= i n))
(let ((p (vector-ref pure i))
(i (vector-ref impure i)))
(set-heap:objects p (reverse (heap:objects p)))
(set-heap:objects i (reverse (heap:objects i))))
(loop (+ i 1)))))
(values pure impure reloc externs)))
1996-08-24 05:27:47 -04:00
;;; vm-string->string
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; converts a vm-string to a scheme one that we can handle
(define (vm-string->string x)
(cond ((vm-string? x)
(let ((len (vm-string-length x)))
(let loop ((i 0)
(l '()))
(cond ((= i len)
(list->string (reverse l)))
(else
(loop (+ i 1) (cons (vm-string-ref x i) l)))))))
(else
(message x " is not a vm-string"))))
;;; write-c-header-file
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; declares the c long arrays for each heap chunk
;;; declares the extern references to other c functions
(define (write-c-header-file pure impure externs)
1995-10-31 18:16:31 -05:00
(message "Writing header file")
1996-08-24 05:27:47 -04:00
(call-with-output-file "static.h"
1995-10-31 18:16:31 -05:00
(lambda (port)
(format port "/* Static Heap File Automatically Generated~%")
1996-08-24 05:27:47 -04:00
(format port " * by scsh/static.scm */~%")
;; declare the long arrays for each heap chunk
1995-10-31 18:16:31 -05:00
(let ((n (nchunks)))
(do ((i 0 (+ i 1)))
((= i n))
(format port "extern const long p~s[~s];~%" i
(quotient (heap:length (vector-ref pure i)) 4)))
(do ((i 0 (+ i 1)))
((= i n))
(format port "extern long i~s[~s];~%" i
(quotient (heap:length (vector-ref impure i)) 4))))
1996-08-24 05:27:47 -04:00
;; declare the external references
1995-10-31 18:16:31 -05:00
(table-walk
(lambda (address name)
(format port "const extern ~a();~%" name))
externs)
)))
1996-08-24 05:27:47 -04:00
;;; write-c-image
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; responsible for writing the pure and impure heaps
(define (write-c-image pure impure reloc externs)
1995-10-31 18:16:31 -05:00
(message "Writing pure c files")
1996-08-24 05:27:47 -04:00
(write-c-image1 pure "p" "const " reloc externs)
1995-10-31 18:16:31 -05:00
(message "Writing impure c files")
1996-08-24 05:27:47 -04:00
(write-c-image1 impure "i" "" reloc externs))
1995-10-31 18:16:31 -05:00
1996-08-24 05:27:47 -04:00
;;; write-c-image1
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; writes the c long array
(define (write-c-image1 heap name const reloc externs)
1995-10-31 18:16:31 -05:00
(let ((n (nchunks)))
1996-08-24 05:27:47 -04:00
;; iterate over all the chunks for this part of heap
1995-10-31 18:16:31 -05:00
(let chunk-loop ((c 0))
(cond ((not (= c n))
1996-08-24 05:27:47 -04:00
(format #t "Writing static-~a~s.c~%" name c)
1995-10-31 18:16:31 -05:00
(call-with-output-file
1996-08-24 05:27:47 -04:00
(format #f "static-~a~s.c" name c)
1995-10-31 18:16:31 -05:00
(lambda (port)
1996-08-24 05:27:47 -04:00
(format port "#include \"static.h\"~%")
1995-10-31 18:16:31 -05:00
(format port "~a long ~a~s[]={~%" const name c)
(let ((heap (vector-ref heap c)))
1996-08-24 05:27:47 -04:00
;; iterate over each object
1995-10-31 18:16:31 -05:00
(let heap-loop ((l (heap:objects heap)))
(cond ((not (null? l))
1996-08-24 05:27:47 -04:00
(scsh-emit-initializer
(car l) reloc externs port)
1995-10-31 18:16:31 -05:00
(heap-loop (cdr l))))))
(display "};" port)
(newline port)))
(chunk-loop (+ 1 c)))))))
1996-08-24 05:27:47 -04:00
;;; write-main-c-file
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; creates the top level interfaces that scheme48 wants to see
;;; p_count i_count
;;; number of chunks
;;; p_areas i_areas
;;; pointers to each chunk
;;; p_sizes i_sizes
;;; sizes of each chunk
;;; entry
;;; the starting entry point
(define (write-main-c-file start reloc)
1995-10-31 18:16:31 -05:00
(let ((n (nchunks)))
1996-08-24 05:27:47 -04:00
(call-with-output-file "static.c"
1995-10-31 18:16:31 -05:00
(lambda (port)
1996-08-24 05:27:47 -04:00
(format port "#include \"static.h\"~%")
1995-10-31 18:16:31 -05:00
(format port "const long p_count = ~s;~%" n)
(format port "const long i_count = ~s;~%" n)
(format port "const long * const p_areas[~s] = {" n)
(do ((i 0 (+ i 1)))
((= i n))
(format port "(const long *) &p~s, " i))
(format port "};~%")
(format port "long * const i_areas[~s] = {" n)
(do ((i 0 (+ i 1)))
((= i n))
(format port "(long *) &i~s, " i))
(format port "};~%")
(format port "const long p_sizes[~s] = {" n)
(do ((i 0 (+ i 1)))
((= i n))
(format port "sizeof(p~s), " i))
(format port "};~%")
(format port "const long i_sizes[~s] = {" n)
(do ((i 0 (+ i 1)))
((= i n))
(format port "sizeof(i~s), " i))
(format port "};~%")
(display "const long entry = " port)
(scsh-emit-descriptor start reloc port)
(write-char #\; port)
(newline port)))))
1996-08-24 05:27:47 -04:00
;;; compile-c-files
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; compiles the chunk .c files as well as the main .c file
(define (compile-c-files cc-command)
1995-10-31 18:16:31 -05:00
(let ((n (nchunks))
(cc (append (line->list cc-command) '(-c))))
1995-10-31 18:16:31 -05:00
(message "Compiling main C file")
1996-08-24 05:27:47 -04:00
(message (append cc '("static.c")))
(run (,@(append cc '("static.c"))))
1995-10-31 18:16:31 -05:00
(do ((i 0 (+ i 1)))
((= i n))
(message "Compiling C file for pure chunk " i)
1996-08-24 05:27:47 -04:00
(message (append cc (list (format #f "static-p~s.c" i))))
1995-10-31 18:16:31 -05:00
(run (,@(append cc
1996-08-24 05:27:47 -04:00
(list (format #f "static-p~s.c" i)))))
1995-10-31 18:16:31 -05:00
(message "Compiling C file for impure chunk " i)
1996-08-24 05:27:47 -04:00
(message (append cc (list (format #f "static-i~s.c" i))))
1995-10-31 18:16:31 -05:00
(run (,@(append cc
1996-08-24 05:27:47 -04:00
(list (format #f "static-i~s.c" i))))))))
;;; link-files
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; links the .o's from compile-c-files
;;; uses the provided flags and libraries
;;; produces outfile as executible
(define (link-files cc-command linker-flags libraries outfile)
1995-10-31 18:16:31 -05:00
(let ((n (nchunks))
(ld (append (line->list cc-command)
(line->list linker-flags)
`(-o ,outfile)))
(libs (line->list libraries)))
(message "Linking executible")
(message (append ld
(let loop ((i 0)
(l '()))
(cond ((not (= i n))
(loop (+ i 1)
(cons
1996-08-24 05:27:47 -04:00
(format #f "static-i~s.o" i)
(cons
1996-08-24 05:27:47 -04:00
(format #f "static-p~s.o" i)
l))))
(else
(reverse
1996-08-24 05:27:47 -04:00
(cons "static.o"
l)))))
'("@prefix@/lib/scsh/libscshvm.a")
libs))
1995-10-31 18:16:31 -05:00
(run (,@(append
ld
(let loop ((i 0)
(l '()))
(cond ((not (= i n))
(loop (+ i 1)
1995-10-31 18:16:31 -05:00
(cons
1996-08-24 05:27:47 -04:00
(format #f "static-i~s.o" i)
1995-10-31 18:16:31 -05:00
(cons
1996-08-24 05:27:47 -04:00
(format #f "static-p~s.o" i)
1995-10-31 18:16:31 -05:00
l))))
(else
(reverse
1996-08-24 05:27:47 -04:00
(cons "static.o"
l)))))
'("@prefix@/lib/scsh/libscshvm.a")
libs)))))
1995-10-31 18:16:31 -05:00
1996-08-24 05:27:47 -04:00
;;; scsh-emit-initializer
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; see scheme48 emit-initialize below
1995-10-31 18:16:31 -05:00
(define (scsh-emit-initializer x reloc externs port)
1996-08-24 05:27:47 -04:00
;; emit the header
1995-10-31 18:16:31 -05:00
(write-hex port (stob-header x))
1996-08-24 05:27:47 -04:00
;; handle descriptor vectors and vm-strings.
;; everything else is a byte vector
1995-10-31 18:16:31 -05:00
(cond ((d-vector? x)
(scsh-emit-d-vector-initializer x reloc port))
((vm-string? x)
(scsh-emit-vm-string-initializer x port))
(else
1996-08-24 05:27:47 -04:00
(scsh-emit-b-vector-initializer x externs port)))
1995-10-31 18:16:31 -05:00
(if *comments?*
(begin (display " /* " port)
(writex x port)
(display " */" port)))
(newline port))
1996-08-24 05:27:47 -04:00
;;; scsh-emit-d-vector
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; descriptor vectors are pretty easy given scsh-emit-descriptor
1995-10-31 18:16:31 -05:00
(define (scsh-emit-d-vector-initializer x reloc port)
(let ((len (d-vector-length x)))
(do ((i 0 (+ i 1)))
((= i len))
(scsh-emit-descriptor (d-vector-ref x i) reloc port)
(write-char #\, port))))
1996-08-24 05:27:47 -04:00
;;; scsh-emit-descriptor
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; for descrriptors we consult the relocation table
(define (scsh-emit-descriptor x reloc port)
(if (stob? x)
(let ((n (chunk-number x)))
(display "(long)(&" port)
(if (immutable? x)
(display "p" port)
(display "i" port))
(display n port)
(display "[" port)
(display (quotient (table-ref (vector-ref reloc n) x) 4) port)
(display "])+7" port))
(format port
(if (negative? x) "-0x~a" "0x~a")
(number->string (abs x) 16))))
;;; scsh-emit-vm-string-initializer
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; vm-strings are converted to numbers and byte order adjusted
1995-10-31 18:16:31 -05:00
(define (scsh-emit-vm-string-initializer x port)
(let* ((len (vm-string-length x)) ; end is jawilson style hack
(end (- (cells->bytes (bytes->cells (+ len 1))) 4)))
(do ((i 0 (+ i 4)))
((= i end)
(case (- len end)
((0)
(write-hex port 0))
((1)
(write-hex
port
(net-to-host-32 (arithmetic-shift
(char->ascii (vm-string-ref x i)) 24))))
((2)
(write-hex
port
(net-to-host-32
(bitwise-ior
(arithmetic-shift
(char->ascii (vm-string-ref x i)) 24)
(arithmetic-shift
(char->ascii (vm-string-ref x (+ i 1))) 16)))))
((3)
(write-hex
port
(net-to-host-32
(bitwise-ior
(bitwise-ior
(arithmetic-shift
(char->ascii (vm-string-ref x i)) 24)
(arithmetic-shift
(char->ascii (vm-string-ref x (+ i 1))) 16))
(arithmetic-shift
(char->ascii (vm-string-ref x (+ i 2))) 8)))))))
(write-hex port
(net-to-host-32 (bitwise-ior
(bitwise-ior
(arithmetic-shift
1996-08-24 05:27:47 -04:00
(char->ascii
(vm-string-ref x i)) 24)
1995-10-31 18:16:31 -05:00
(arithmetic-shift
1996-08-24 05:27:47 -04:00
(char->ascii
(vm-string-ref x (+ i 1))) 16))
1995-10-31 18:16:31 -05:00
(bitwise-ior
(arithmetic-shift
1996-08-24 05:27:47 -04:00
(char->ascii
(vm-string-ref x (+ i 2))) 8)
(char->ascii
(vm-string-ref x (+ i 3))))))
1995-10-31 18:16:31 -05:00
))))
1996-08-24 05:27:47 -04:00
;;; scsh-emit-b-vector-initializer
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; byte vectors are byte order adjusted too
(define (scsh-emit-b-vector-initializer x externs port)
1995-10-31 18:16:31 -05:00
(cond ((and (code-vector? x)
(table-ref externs x)) =>
(lambda (name)
(format port "(long) *~a," name)))
(else
(let* ((len (b-vector-length x)) ;end is jawilson style hack
(end (- (cells->bytes (bytes->cells (+ len 1))) 4)))
(do ((i 0 (+ i 4)))
((= i end)
(case (- len end)
((1)
(write-hex
port
1996-08-24 05:27:47 -04:00
(net-to-host-32
(arithmetic-shift (b-vector-ref x i) 24))))
1995-10-31 18:16:31 -05:00
((2)
(write-hex
port
(net-to-host-32
(bitwise-ior
(arithmetic-shift (b-vector-ref x i) 24)
(arithmetic-shift (b-vector-ref x (+ i 1)) 16)))))
((3)
(write-hex
port
(net-to-host-32
(bitwise-ior
(bitwise-ior
(arithmetic-shift (b-vector-ref x i) 24)
(arithmetic-shift (b-vector-ref x (+ i 1)) 16))
(arithmetic-shift (b-vector-ref x (+ i 2)) 8)))
))))
(write-hex
port
(net-to-host-32 (bitwise-ior
(bitwise-ior
1996-08-24 05:27:47 -04:00
(arithmetic-shift
(b-vector-ref x i) 24)
(arithmetic-shift
(b-vector-ref x (+ i 1)) 16))
1995-10-31 18:16:31 -05:00
(bitwise-ior
1996-08-24 05:27:47 -04:00
(arithmetic-shift
(b-vector-ref x (+ i 2)) 8)
1995-10-31 18:16:31 -05:00
(b-vector-ref x (+ i 3))))))))
)))
1996-08-24 05:27:47 -04:00
;;; scsh-for-each-stored-object
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; see scheme48 for-each-stored-object
;;; Image traversal utility
1995-10-31 18:16:31 -05:00
(define (scsh-for-each-stored-object 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))
(len (addr1+ (header-a-units d))))
(if (not (header? d))
(warn "heap is in an inconsistent state" d))
1996-08-24 05:27:47 -04:00
(proc i
(address->stob-descriptor (addr1+ addr))
len)
1995-10-31 18:16:31 -05:00
(loop (addr+ addr len)))
(begin (chunk-end i)
(chunk-loop addr
(+ i 1)
(+ chunk *chunk-size*))))))))))
1996-08-24 05:27:47 -04:00
;;; write-hex
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; utility routine to print a scheme number as a c hex number
1995-10-31 18:16:31 -05:00
(define (write-hex port x)
(format port
(if (negative? x) "-0x~a," "0x~a,")
(number->string (abs x) 16)))
1996-08-24 05:27:47 -04:00
;;; line->list
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; utility that takes a string and break it into a list at whitespace
;;; rewrite using scsh stuff?
1995-10-31 18:16:31 -05:00
(define (line->list line)
(let ((len (string-length line)))
(let loop ((start 0)
(end 0)
(l '()))
(cond ((>= end len)
(if (= start end)
l
(append l (list (substring line start end)))))
((and (= start end)
(or (char=? (string-ref line start) (ascii->char 32))
(char=? (string-ref line start) (ascii->char 9))))
(loop (+ 1 start)
(+ 1 end)
l))
((or (char=? (string-ref line end) (ascii->char 32))
(char=? (string-ref line end) (ascii->char 9)))
(loop (+ 1 end)
(+ 1 end)
(append l (list (substring line start end)))))
((< end len)
(loop start
(+ 1 end)
l))
(else (error "unexpected case in line->list"))))))
1996-08-24 05:27:47 -04:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1995-10-31 18:16:31 -05:00
;;; Debugging
1996-08-24 05:27:47 -04:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1995-10-31 18:16:31 -05:00
(define (bin n)
(number->string n 2))
(define (oct n)
(number->string n 8))
(define (dec n)
(number->string n 10))
(define (hex n)
(number->string n 16))
1996-08-24 05:27:47 -04:00
;;; Static Heap Code From Scheme48
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The Scheme 48 version produced monolithic C files that even
;;; the GNU C Compiler couldn't handle, let alone standard vendor
;;; compilers...
;;; It also relied upon the C compiler to fill in some pointer
;;; information. Because I needed to break up the files, I had to
;;; calculate this information myself.
1995-10-31 18:16:31 -05:00
; 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 outfile)
(let ((start (init bytes infile)))
(call-with-output-file outfile
(lambda (port)
(format port "#define D(x) (long)(&x)+7~%")
(format port "#define H unsigned long~%")
(emit-area-declarations "p" immutable? "const " port)
(emit-area-declarations "i" mutable? "" port)
(emit-area-initializers "p" immutable? "const " port)
(emit-area-initializers "i" mutable? "" 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)))
(message (nchunks)
" chunks")
start))
(define (nchunks) (+ (chunk-number (heap-pointer)) 1))
; emit struct declarations for areas
(define (emit-area-declarations name in-area? const port)
(for-each-stored-object
(lambda (chunk)
(message name chunk " declaration")
(display "struct " port) (display name port) (display chunk port)
(display " {" port) (newline port))
(lambda (x)
(if (in-area? x)
(emit-declaration x port)))
(lambda (chunk)
(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 port)
(for-each-stored-object
(lambda (chunk)
(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)
(if (in-area? x)
(emit-initializer x port)))
(lambda (chunk)
(display "};" port) (newline 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)))
; 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 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)))
;; End begin
))