From 12874c0edd667ef57b642ff675cfa62caeeb2e92 Mon Sep 17 00:00:00 2001 From: bdc Date: Tue, 31 Oct 1995 23:16:31 +0000 Subject: [PATCH] even more 0.4.0 hacks --- Makefile.in | 2 +- configure | 49 ++-- configure.in | 9 +- scsh/network.c | 22 +- scsh/static.scm | 15 + scsh/static.scm.in | 675 +++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 748 insertions(+), 24 deletions(-) create mode 100644 scsh/static.scm.in diff --git a/Makefile.in b/Makefile.in index ba7e48e..24f841f 100644 --- a/Makefile.in +++ b/Makefile.in @@ -20,7 +20,7 @@ LDFLAGS_AIX= @LDFLAGS_AIX@ RM = rm -f -AR = ar cq +AR = @AR@ RANLIB = ranlib SHELL = /bin/sh diff --git a/configure b/configure index b9cfbfc..58debda 100755 --- a/configure +++ b/configure @@ -779,6 +779,9 @@ else ENDIAN=big fi +AR=${AR-"ar cq"} +TMPDIR=${TMPDIR-"/usr/tmp"} + case "$host" in ## CX/UX @@ -936,7 +939,7 @@ else ac_save_LIBS="$LIBS" LIBS="-lm $LIBS" cat > conftest.$ac_ext < conftest.$ac_ext < conftest.$ac_ext < conftest.$ac_ext < conftest.$ac_ext < conftest.$ac_ext < conftest.$ac_ext <&6 else cat > conftest.$ac_ext < #include @@ -1255,7 +1258,7 @@ else # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. cat > conftest.$ac_ext < Syntax Error @@ -1269,7 +1272,7 @@ else rm -rf conftest* CPP="${CC-cc} -E -traditional-cpp" cat > conftest.$ac_ext < Syntax Error @@ -1302,7 +1305,7 @@ if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF @@ -1337,7 +1340,7 @@ if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&6 else cat > conftest.$ac_ext < conftest.$ac_ext < int main() { return 0; } @@ -1545,7 +1548,7 @@ EOF else cat > conftest.$ac_ext < int main() { return 0; } @@ -1580,7 +1583,7 @@ EOF else cat > conftest.$ac_ext < int main() { return 0; } @@ -1614,7 +1617,7 @@ EOF else cat > conftest.$ac_ext < int main() { return 0; } @@ -1649,7 +1652,7 @@ EOF else cat > conftest.$ac_ext < #include @@ -1687,6 +1690,9 @@ CFLAGS1=${CFLAGS} + + + trap '' 1 2 15 cat > confcache <<\EOF # This file is a shell script that caches the results of configure @@ -1774,7 +1780,7 @@ done ac_given_srcdir=$srcdir ac_given_INSTALL="$INSTALL" -trap 'rm -fr `echo "Makefile scsh/regexp/Makefile scsh/network.scm sysdep.h" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 +trap 'rm -fr `echo "Makefile scsh/regexp/Makefile scsh/endian.scm scsh/static.scm sysdep.h" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 # Protect against being on the right side of a sed subst in config.status. sed 's/%@/@@/; s/@%/@@/; s/%g$/@g/; /@g$/s/[\\\\&%]/\\\\&/g; @@ -1800,15 +1806,17 @@ s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g s%@INSTALL_DATA@%$INSTALL_DATA%g s%@CPP@%$CPP%g s%@AIX_P@%$AIX_P%g +s%@AR@%$AR%g s%@CFLAGS1@%$CFLAGS1%g s%@ENDIAN@%$ENDIAN%g s%@LDFLAGS_AIX@%$LDFLAGS_AIX%g +s%@TMPDIR@%$TMPDIR%g CEOF EOF cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then @@ -1968,3 +1976,4 @@ chmod +x $CONFIG_STATUS rm -fr confdefs* $ac_clean_files test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1 +chmod +x scsh/static.scm diff --git a/configure.in b/configure.in index 7eb61aa..41468b9 100644 --- a/configure.in +++ b/configure.in @@ -199,6 +199,9 @@ else ENDIAN=big fi +AR=${AR-"ar cq"} +TMPDIR=${TMPDIR-"/usr/tmp"} + case "$host" in ## CX/UX @@ -319,10 +322,14 @@ SCSH_CONST_SYS_ERRLIST CFLAGS1=${CFLAGS} AC_SUBST(AIX_P) +AC_SUBST(AR) +AC_SUBST(CC) AC_SUBST(CFLAGS) AC_SUBST(CFLAGS1) AC_SUBST(ENDIAN) AC_SUBST(LDFLAGS) AC_SUBST(LDFLAGS_AIX) +AC_SUBST(TMPDIR) -AC_OUTPUT(Makefile scsh/regexp/Makefile scsh/endian.scm) +AC_OUTPUT(Makefile scsh/regexp/Makefile scsh/endian.scm scsh/static.scm) +chmod +x scsh/static.scm diff --git a/scsh/network.c b/scsh/network.c index 6915b08..1046381 100644 --- a/scsh/network.c +++ b/scsh/network.c @@ -381,6 +381,24 @@ scheme_value df_scheme_proto_name2proto_info(long nargs, scheme_value *args) return ret1; } +scheme_value df_veclen(long nargs, scheme_value *args) +{ + extern scheme_value veclen(const long * ); + scheme_value ret1; + scheme_value r1; + + cig_check_nargs(1, nargs, "veclen"); + r1 = veclen((const long * )AlienVal(args[0])); + ret1 = r1; + return ret1; + } + +scheme_value df_set_longvec_carriers(long nargs, scheme_value *args) +{ + extern void set_longvec_carriers(scheme_value , long const * const * ); + + cig_check_nargs(2, nargs, "set_longvec_carriers"); + set_longvec_carriers(args[1], (long const * const * )AlienVal(args[0])); + return SCHFALSE; + } -Error: end of file inside list -- unbalanced parentheses - #{Input-port} diff --git a/scsh/static.scm b/scsh/static.scm index de296f9..d367eba 100755 --- a/scsh/static.scm +++ b/scsh/static.scm @@ -25,6 +25,21 @@ defrec-package scsh) (begin + + (define (scsh-static-linker argl) + (if (not (= (length argl) 3)) + (error "usage: ~a input-image-file output-archive-file" (car argl)) + (let ((tempdir (or (getenv "TMPDIR") + "/usr/tmp")) + (cc-command (or (getenv "CC") + "gcc -g -O")) + (ar-command (or (getenv "AR") + "ar cq")) + (infile (cadr argl)) + (outfile (caddr argl))) + (scsh-do-it infile tempdir outfile cc-command ar-command) + (exit 0)))) + ;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- (define-record heap (length 0) diff --git a/scsh/static.scm.in b/scsh/static.scm.in new file mode 100644 index 0000000..496978a --- /dev/null +++ b/scsh/static.scm.in @@ -0,0 +1,675 @@ +#!/usr/local/bin/scsh \ +-lm /usr/local/lib/scsh/vm/ps-interface.scm -lm /usr/local/lib/scsh/vm/interfaces.scm -lm /usr/local/lib/scsh/vm/package-defs.scm -lm /usr/local/lib/scsh/vm/s48-package-defs.scm -m heap -l /usr/local/lib/scsh/scsh/static-heap.scm -dm -m scsh-static-heap -e scsh-static-linker -s +!# +;;; Package for Static heaps for the Scheme Shell +;;; Copyright (c) 1995 by Brian D. Carlstrom. + +;;; based on Scheme48 implementation. +;;; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. + +(define-structure heap-extra (export newspace-begin + heap-pointer + header-a-units + d-vector? + stob-type) + (open scheme heap)) + +(define-structure scsh-static-heap (export scsh-static-linker) + (open scheme heap memory data stob struct + heap-extra + vm-architecture + formats + enumerated + signals + tables + defrec-package + scsh) + (begin + + (define (scsh-static-linker argl) + (if (not (= (length argl) 3)) + (error "usage: ~a input-image-file output-archive-file" (car argl)) + (let ((tempdir (or (getenv "TMPDIR") + "@TMPDIR@")) + (cc-command (or (getenv "CC") + "@CC@ @CFLAGS@")) + (ar-command (or (getenv "AR") + "@AR@")) + (infile (cadr argl)) + (outfile (caddr argl))) + (scsh-do-it infile tempdir outfile cc-command ar-command) + (exit 0)))) + + ;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- + (define-record heap + (length 0) + (objects '()) + ) + ;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- + (define (scsh-do-it infile tempdir outfile cc-command ar-command) + (let* ((temp-dir (format #f "~a/scsh~s" tempdir (pid))) + (prefix (string-append temp-dir "/static")) + (start (read-heap-image infile))) + (receive (pure impure reloc externs) + (create-heaps-and-tables) + (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) + (with-cwd temp-dir + (write-c-header-file pure impure externs infile outfile prefix) + (write-c-image pure impure reloc externs prefix) + (write-main-c-file start reloc prefix) + (compile-c-files cc-command prefix)) + (archive-files ar-command outfile prefix) + ))) + + + (define debug #f) + + (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")))) + + (define (read-heap-image infile) + (let ((bytes (file-info:size (file-info infile)))) + (init (inexact->exact (floor (* 1.1 bytes))) infile))) + ; XXX need little extra space for find-all-xs + + (define (create-heaps-and-tables) + (let* ((n (nchunks)) + ( pure (make-vector n)) + (impure (make-vector n)) + (reloc (make-vector n)) + (externs (make-table ))) + ;; initialize to blanks + (let loop ((i 0)) + (cond ((not (= i n)) + (vector-set! pure i (make-heap )) + (vector-set! impure i (make-heap )) + (vector-set! reloc i (make-table)) + (loop (+ i 1))))) + (scsh-for-each-stored-object + (lambda (chunk) + (format #t "Reading chunk number ~s" chunk)) + (lambda (chunk x len) + (if debug + (write x)) + (let* ((mutable (mutable? x)) + (heap (vector-ref (if mutable impure pure) chunk))) + (table-set! (vector-ref reloc chunk) x (heap:length heap)) + (set-heap:objects heap (cons x (heap:objects heap))) + (set-heap:length heap (+ len (heap:length heap))) + (cond (debug + (display (if mutable " mutable " " immutable ")) + (cond ((d-vector? x) (display " d-vector")) + ((vm-string? x) (display "vm-string")) + (else (display " b-vector"))) + (let ((m (heap:length (vector-ref impure chunk))) + (i (heap:length (vector-ref pure chunk)))) + (message " m" m "+i" i "=" (+ m i)))))) + (if (= (header-type (stob-header x)) (enum stob external)) + (table-set! externs + (external-value x) + (vm-string->string (external-name x)))) + ) + (lambda (chunk) + (newline))) + (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))) + + (define (write-c-header-file pure impure externs infile outfile prefix) + (message "Writing header file") + (call-with-output-file (string-append prefix ".h") + (lambda (port) + (format port "/* Static Heap File Automatically Generated~%") + (format port " * by scsh/static.scm~%") + (format port " * from ~a~%" infile) + (format port " * to ~a~%" outfile) + (format port " */~%") + (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)))) + (table-walk + (lambda (address name) + (format port "const extern ~a();~%" name)) + externs) + ))) + + (define (d-vector-for-each proc d-vector) + (do ((i 0 (+ i 1))) + ((>= i (d-vector-length d-vector))) + (proc (d-vector-ref d-vector i)))) + + (define (write-c-image pure impure reloc externs prefix) + (message "Writing pure c files") + (scsh-write-c-image pure "p" "const " reloc externs prefix) + (message "Writing impure c files") + (scsh-write-c-image impure "i" "" reloc externs prefix)) + + (define (scsh-write-c-image heap name const reloc externs prefix) + (let ((n (nchunks))) + (let chunk-loop ((c 0)) + (cond ((not (= c n)) + (format #t "Writing ~a-~a~s.c~%" prefix name c) + (call-with-output-file + (format #f "~a-~a~s.c" prefix name c) + (lambda (port) + (format port "#include \"~a.h\"~%" prefix) + (format port "~a long ~a~s[]={~%" const name c) + (let ((heap (vector-ref heap c))) + (let heap-loop ((l (heap:objects heap))) + (cond ((not (null? l)) + (scsh-emit-initializer (car l) reloc externs port) + (heap-loop (cdr l)))))) + (display "};" port) + (newline port))) + (chunk-loop (+ 1 c))))))) + + (define (write-main-c-file start reloc prefix) + (let ((n (nchunks))) + (call-with-output-file (string-append prefix ".c") + (lambda (port) + (format port "#include \"~a.h\"~%" prefix) + (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))))) + + (define (compile-c-files cc-command prefix) + (let ((n (nchunks)) + (cc (line->list cc-command))) + (message "Compiling main C file") + (run (,@(append cc (list (format #f "~a.c" prefix))))) + (do ((i 0 (+ i 1))) + ((= i n)) + (message "Compiling C file for pure chunk " i) + (run (,@(append cc + (list (format #f "~a-p~s.c" prefix i))))) + (message "Compiling C file for impure chunk " i) + (run (,@(append cc + (list (format #f "~a-i~s.c" prefix i)))))))) + + (define (archive-files ar-command outfile prefix) + (let ((n (nchunks)) + (ar (line->list ar-command))) + (message "Archiving object files") + (run (,@(append + ar + (cons + outfile + (let loop ((i 0) + (l '())) + (cond ((not (= i n)) + (loop (+ i 1) + (cons + (format #f "~a-i~s.o" prefix i) + (cons + (format #f "~a-p~s.o" prefix i) + l)))) + (else + (reverse + (cons + (string-append prefix ".o") + l))))))))))) + + (define (scsh-emit-initializer x reloc externs port) + (write-hex port (stob-header x)) + (cond ((d-vector? x) + (scsh-emit-d-vector-initializer x reloc port)) + ((vm-string? x) + (scsh-emit-vm-string-initializer x port)) + (else + (scsh-emit-b-vector-initializer x reloc externs port))) + (if *comments?* + (begin (display " /* " port) + (writex x port) + (display " */" port))) + (newline port)) + + + (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)))) + + (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 + (char->ascii (vm-string-ref x i)) 24) + (arithmetic-shift + (char->ascii (vm-string-ref x (+ i 1))) 16)) + (bitwise-ior + (arithmetic-shift + (char->ascii (vm-string-ref x (+ i 2))) 8) + (char->ascii (vm-string-ref x (+ i 3)))))) + )))) + + (define (scsh-emit-b-vector-initializer x reloc externs port) + (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 + (net-to-host-32 (arithmetic-shift (b-vector-ref x i) 24)))) + ((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 + (arithmetic-shift (b-vector-ref x i) 24) + (arithmetic-shift (b-vector-ref x (+ i 1)) 16)) + (bitwise-ior + (arithmetic-shift (b-vector-ref x (+ i 2)) 8) + (b-vector-ref x (+ i 3)))))))) + ))) + + (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)))) + + (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)) + (proc i (address->stob-descriptor (addr1+ addr)) len) + (loop (addr+ addr len))) + (begin (chunk-end i) + (chunk-loop addr + (+ i 1) + (+ chunk *chunk-size*)))))))))) + + (define (write-hex port x) + (format port + (if (negative? x) "-0x~a," "0x~a,") + (number->string (abs x) 16))) + + ;; takes a string and break it into a list at whitespace + ;; rewrite using scsh stuff? + (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")))))) + +;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- +;;; Debugging +;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- + + (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)) + +;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- + + ; 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 + ))