scsh-conservatory
/
scsh-0.5
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

cleaned up static linker code

This commit is contained in:
bdc 1996-08-24 09:27:47 +00:00
parent d472115b34
commit b5a653f1f3
2 changed files with 283 additions and 223 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
Makefile.in
View File

@ -655,53 +655,6 @@ scsh/scsh.image: $(VM) $(SCHEME) $(CIG).image
scsh/regexp/libregexp.a: scsh/regexp/libregexp.a:
cd scsh/regexp; $(MAKE) cd scsh/regexp; $(MAKE)
# SCSH static heaps
.SUFFIXES: .scm .image .a .vm
.image.a:
$(RM) $@
(echo ",batch on"; \
echo ",config ,load vm/ps-interface.scm"; \
echo ",config ,load vm/interfaces.scm"; \
echo ",config ,load vm/package-defs.scm"; \
echo ",config ,load vm/s48-package-defs.scm"; \
echo ",load-package bigbit"; \
echo ",load-package destructuring"; \
echo ",load-package heap"; \
echo ",in heap"; \
echo "(define (newspace-begin) *newspace-begin*)"; \
echo "(define (heap-pointer) *hp*)"; \
echo ",structure heap-extra (export newspace-begin"; \
echo " heap-pointer"; \
echo " header-a-units"; \
echo " d-vector? "; \
echo " stob-type)"; \
echo ",config"; \
echo "(define-structure static (export scsh-do-it"; \
echo " test"; \
echo " do-it)"; \
echo " (open scheme heap memory data stob struct"; \
echo " heap-extra"; \
echo " vm-architecture"; \
echo " formats"; \
echo " enumerated"; \
echo " signals"; \
echo " tables"; \
echo " defrec-package"; \
echo " externals"; \
echo " scsh)"; \
echo " (files (scsh static)))"; \
echo ",user"; \
echo ",load-package static"; \
echo ",open static"; \
echo \(scsh-do-it \"$<\" \"/homes/bdc/tmp\" \"$@\" \
\"$(CC) -c\" \"$(AR)\" \)) \
| ./$(VM) -o ./$(VM) -h 4000000 -i scsh/scsh.image
$(RANLIB) $@
.a.vm:
$(CC) $(LDFLAGS) -o $@ smain.o $< $(OBJS) $(LIBS)
install-scsh: scsh install-scsh: scsh
$(RM) $(bindir)/$(RUNNABLE) $(RM) $(bindir)/$(RUNNABLE)
$(INSTALL_PROGRAM) $(srcdir)/scsh/scsh $(bindir)/$(RUNNABLE) $(INSTALL_PROGRAM) $(srcdir)/scsh/scsh $(bindir)/$(RUNNABLE)

459
scsh/static.scm.in
View File

@ -1,23 +1,34 @@
#!@prefix@/lib/scsh/scshvm \ #!@prefix@/lib/scsh/scshvm \
-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 scsh-static-heap -e scsh-static-linker -s -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
!# !#
;;; Package for Static heaps for the Scheme Shell
;;; Copyright (c) 1995 by Brian D. Carlstrom.
#!
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.
;;;
;;; based on Scheme48 implementation. ;;; based on Scheme48 implementation.
;;; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. ;;; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees.
;;;
;;; 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 heap-extra (export newspace-begin (define-structure static-heaps
;; heap-pointer (export static-heap-linker)
;; header-a-units
;; d-vector?
;; stob-type)
;; (open scheme heap)
;; (begin
;; (define (newspace-begin) *newspace-begin*)
;; (define (heap-pointer) *hp*)))
(define-structure scsh-static-heap (export scsh-static-linker)
(open scheme heap memory data stob struct (open scheme heap memory data stob struct
heap-extra heap-extra
vm-architecture vm-architecture
@ -28,55 +39,140 @@
defrec-package defrec-package
scsh) scsh)
(begin (begin
;;; 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)))
(define (scsh-static-linker argl) ;;; heap structure
(if (not (= (length argl) 3)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(error "usage: ~a input-image-file output-executible-file"
(car argl))
(let ((tempdir (or (getenv "TMPDIR")
"@TMPDIR@"))
(cc-command (or (getenv "CC")
"@CC@ @CFLAGS@"))
(linker-flags (or (getenv "LDFLAGS")
"@LDFLAGS@"))
(libraries (or (getenv "LIBS")
"@LIBS@"))
(infile (cadr argl))
(outfile (caddr argl)))
(scsh-do-it infile tempdir outfile
cc-command linker-flags libraries)
(exit 0))))
;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
(define-record heap (define-record heap
(length 0) (length 0)
(objects '()) (objects '())
) )
;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
(define (scsh-do-it infile tempdir outfile ;;; static-heap-linker1
cc-command linker-flags libraries) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let* ((temp-dir (format #f "~a/scsh~s" tempdir (pid))) (define (static-heap-linker1 input-image tempdir output-executible
(prefix (string-append temp-dir "/static")) cc-command ld-flags libraries)
(start (read-heap-image infile))) (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 ***
(receive (pure impure reloc externs) (receive (pure impure reloc externs)
(create-heaps-and-tables) (create-heaps-and-tables) ; *** EVAL ***
;;; if directory exists blow it away
;;; useful for repeated runs from within same scsh process
(if (file-exists? temp-dir) (if (file-exists? temp-dir)
(if (file-directory? temp-dir) (if (file-directory? temp-dir)
(with-cwd temp-dir (with-cwd temp-dir
(map delete-file (directory-files temp-dir #t))) (map delete-file (directory-files temp-dir #t)))
(delete-file temp-dir))) (delete-file temp-dir)))
(create-directory temp-dir #o755 #t) (create-directory temp-dir #o755 #t)
(with-cwd temp-dir (with-cwd temp-dir ; *** PRINT ***
(write-c-header-file pure impure externs infile outfile prefix) (write-c-header-file pure impure externs)
(write-c-image pure impure reloc externs prefix) (write-c-image pure impure reloc externs)
(write-main-c-file start reloc prefix) (write-main-c-file start reloc)
(compile-c-files cc-command prefix)) (compile-c-files cc-command)
(link-files cc-command linker-flags libraries outfile prefix) (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.
(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 debug #f) ;;; 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
(define (create-heaps-and-tables)
(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
(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)))))
;; here is where we iterate through all the bits
;; we construct our own data structures describing the layout
(scsh-for-each-stored-object
(lambda (chunk)
(format #t "Reading chunk number ~s" chunk))
(lambda (chunk x len)
(let* ((heap ; choose the appropriate heap
(vector-ref (if (mutable? x) impure pure) chunk)))
;; add the relocation information
(table-set! (vector-ref reloc chunk) x (heap:length heap))
;; add object reference to heap chunk
(set-heap:objects heap (cons x (heap:objects heap)))
;; update current heap chunk length
(set-heap:length heap (+ len (heap:length heap)))
;; 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))))))
(lambda (chunk)
(newline)))
;; put all the heaps in the correct order
(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)))
;;; vm-string->string
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; converts a vm-string to a scheme one that we can handle
(define (vm-string->string x) (define (vm-string->string x)
(cond ((vm-string? x) (cond ((vm-string? x)
(let ((len (vm-string-length x))) (let ((len (vm-string-length x)))
@ -89,68 +185,17 @@
(else (else
(message x " is not a vm-string")))) (message x " is not a vm-string"))))
(define (read-heap-image infile) ;;; write-c-header-file
(let ((bytes (file-info:size (file-info infile)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(init (inexact->exact (floor (* 1.1 bytes))) infile))) ;;; declares the c long arrays for each heap chunk
; XXX need little extra space for find-all-xs ;;; declares the extern references to other c functions
(define (write-c-header-file pure impure externs)
(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") (message "Writing header file")
(call-with-output-file (string-append prefix ".h") (call-with-output-file "static.h"
(lambda (port) (lambda (port)
(format port "/* Static Heap File Automatically Generated~%") (format port "/* Static Heap File Automatically Generated~%")
(format port " * by scsh/static.scm~%") (format port " * by scsh/static.scm */~%")
(format port " * from ~a~%" infile) ;; declare the long arrays for each heap chunk
(format port " * to ~a~%" outfile)
(format port " */~%")
(let ((n (nchunks))) (let ((n (nchunks)))
(do ((i 0 (+ i 1))) (do ((i 0 (+ i 1)))
((= i n)) ((= i n))
@ -160,47 +205,63 @@
((= i n)) ((= i n))
(format port "extern long i~s[~s];~%" i (format port "extern long i~s[~s];~%" i
(quotient (heap:length (vector-ref impure i)) 4)))) (quotient (heap:length (vector-ref impure i)) 4))))
;; declare the external references
(table-walk (table-walk
(lambda (address name) (lambda (address name)
(format port "const extern ~a();~%" name)) (format port "const extern ~a();~%" name))
externs) externs)
))) )))
(define (d-vector-for-each proc d-vector) ;;; write-c-image
(do ((i 0 (+ i 1))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
((>= i (d-vector-length d-vector))) ;;; responsible for writing the pure and impure heaps
(proc (d-vector-ref d-vector i)))) (define (write-c-image pure impure reloc externs)
(define (write-c-image pure impure reloc externs prefix)
(message "Writing pure c files") (message "Writing pure c files")
(scsh-write-c-image pure "p" "const " reloc externs prefix) (write-c-image1 pure "p" "const " reloc externs)
(message "Writing impure c files") (message "Writing impure c files")
(scsh-write-c-image impure "i" "" reloc externs prefix)) (write-c-image1 impure "i" "" reloc externs))
(define (scsh-write-c-image heap name const reloc externs prefix) ;;; write-c-image1
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; writes the c long array
(define (write-c-image1 heap name const reloc externs)
(let ((n (nchunks))) (let ((n (nchunks)))
;; iterate over all the chunks for this part of heap
(let chunk-loop ((c 0)) (let chunk-loop ((c 0))
(cond ((not (= c n)) (cond ((not (= c n))
(format #t "Writing ~a-~a~s.c~%" prefix name c) (format #t "Writing static-~a~s.c~%" name c)
(call-with-output-file (call-with-output-file
(format #f "~a-~a~s.c" prefix name c) (format #f "static-~a~s.c" name c)
(lambda (port) (lambda (port)
(format port "#include \"~a.h\"~%" prefix) (format port "#include \"static.h\"~%")
(format port "~a long ~a~s[]={~%" const name c) (format port "~a long ~a~s[]={~%" const name c)
(let ((heap (vector-ref heap c))) (let ((heap (vector-ref heap c)))
;; iterate over each object
(let heap-loop ((l (heap:objects heap))) (let heap-loop ((l (heap:objects heap)))
(cond ((not (null? l)) (cond ((not (null? l))
(scsh-emit-initializer (car l) reloc externs port) (scsh-emit-initializer
(car l) reloc externs port)
(heap-loop (cdr l)))))) (heap-loop (cdr l))))))
(display "};" port) (display "};" port)
(newline port))) (newline port)))
(chunk-loop (+ 1 c))))))) (chunk-loop (+ 1 c)))))))
(define (write-main-c-file start reloc prefix) ;;; 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)
(let ((n (nchunks))) (let ((n (nchunks)))
(call-with-output-file (string-append prefix ".c") (call-with-output-file "static.c"
(lambda (port) (lambda (port)
(format port "#include \"~a.h\"~%" prefix) (format port "#include \"static.h\"~%")
(format port "const long p_count = ~s;~%" n) (format port "const long p_count = ~s;~%" n)
(format port "const long i_count = ~s;~%" n) (format port "const long i_count = ~s;~%" n)
@ -209,7 +270,6 @@
((= i n)) ((= i n))
(format port "(const long *) &p~s, " i)) (format port "(const long *) &p~s, " i))
(format port "};~%") (format port "};~%")
(format port "long * const i_areas[~s] = {" n) (format port "long * const i_areas[~s] = {" n)
(do ((i 0 (+ i 1))) (do ((i 0 (+ i 1)))
((= i n)) ((= i n))
@ -221,7 +281,6 @@
((= i n)) ((= i n))
(format port "sizeof(p~s), " i)) (format port "sizeof(p~s), " i))
(format port "};~%") (format port "};~%")
(format port "const long i_sizes[~s] = {" n) (format port "const long i_sizes[~s] = {" n)
(do ((i 0 (+ i 1))) (do ((i 0 (+ i 1)))
((= i n)) ((= i n))
@ -233,24 +292,31 @@
(write-char #\; port) (write-char #\; port)
(newline port))))) (newline port)))))
(define (compile-c-files cc-command prefix) ;;; compile-c-files
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; compiles the chunk .c files as well as the main .c file
(define (compile-c-files cc-command)
(let ((n (nchunks)) (let ((n (nchunks))
(cc (append (line->list cc-command) '(-c)))) (cc (append (line->list cc-command) '(-c))))
(message "Compiling main C file") (message "Compiling main C file")
(message (append cc (list (format #f "~a.c" prefix)))) (message (append cc '("static.c")))
(run (,@(append cc (list (format #f "~a.c" prefix))))) (run (,@(append cc '("static.c"))))
(do ((i 0 (+ i 1))) (do ((i 0 (+ i 1)))
((= i n)) ((= i n))
(message "Compiling C file for pure chunk " i) (message "Compiling C file for pure chunk " i)
(message (append cc (list (format #f "~a-p~s.c" prefix i)))) (message (append cc (list (format #f "static-p~s.c" i))))
(run (,@(append cc (run (,@(append cc
(list (format #f "~a-p~s.c" prefix i))))) (list (format #f "static-p~s.c" i)))))
(message "Compiling C file for impure chunk " i) (message "Compiling C file for impure chunk " i)
(message (append cc (list (format #f "~a-i~s.c" prefix i)))) (message (append cc (list (format #f "static-i~s.c" i))))
(run (,@(append cc (run (,@(append cc
(list (format #f "~a-i~s.c" prefix i)))))))) (list (format #f "static-i~s.c" i))))))))
;;; link-files
(define (link-files cc-command linker-flags libraries outfile prefix) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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)
(let ((n (nchunks)) (let ((n (nchunks))
(ld (append (line->list cc-command) (ld (append (line->list cc-command)
(line->list linker-flags) (line->list linker-flags)
@ -263,15 +329,14 @@
(cond ((not (= i n)) (cond ((not (= i n))
(loop (+ i 1) (loop (+ i 1)
(cons (cons
(format #f "~a-i~s.o" prefix i) (format #f "static-i~s.o" i)
(cons (cons
(format #f "~a-p~s.o" prefix i) (format #f "static-p~s.o" i)
l)))) l))))
(else (else
(reverse (reverse
(cons (cons "static.o"
(string-append prefix ".o") l)))))
l)))))
'("@prefix@/lib/scsh/libscshvm.a") '("@prefix@/lib/scsh/libscshvm.a")
libs)) libs))
(run (,@(append (run (,@(append
@ -281,33 +346,40 @@
(cond ((not (= i n)) (cond ((not (= i n))
(loop (+ i 1) (loop (+ i 1)
(cons (cons
(format #f "~a-i~s.o" prefix i) (format #f "static-i~s.o" i)
(cons (cons
(format #f "~a-p~s.o" prefix i) (format #f "static-p~s.o" i)
l)))) l))))
(else (else
(reverse (reverse
(cons (cons "static.o"
(string-append prefix ".o") l)))))
l)))))
'("@prefix@/lib/scsh/libscshvm.a") '("@prefix@/lib/scsh/libscshvm.a")
libs))))) libs)))))
;;; scsh-emit-initializer
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; see scheme48 emit-initialize below
(define (scsh-emit-initializer x reloc externs port) (define (scsh-emit-initializer x reloc externs port)
;; emit the header
(write-hex port (stob-header x)) (write-hex port (stob-header x))
;; handle descriptor vectors and vm-strings.
;; everything else is a byte vector
(cond ((d-vector? x) (cond ((d-vector? x)
(scsh-emit-d-vector-initializer x reloc port)) (scsh-emit-d-vector-initializer x reloc port))
((vm-string? x) ((vm-string? x)
(scsh-emit-vm-string-initializer x port)) (scsh-emit-vm-string-initializer x port))
(else (else
(scsh-emit-b-vector-initializer x reloc externs port))) (scsh-emit-b-vector-initializer x externs port)))
(if *comments?* (if *comments?*
(begin (display " /* " port) (begin (display " /* " port)
(writex x port) (writex x port)
(display " */" port))) (display " */" port)))
(newline port)) (newline port))
;;; scsh-emit-d-vector
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; descriptor vectors are pretty easy given scsh-emit-descriptor
(define (scsh-emit-d-vector-initializer x reloc port) (define (scsh-emit-d-vector-initializer x reloc port)
(let ((len (d-vector-length x))) (let ((len (d-vector-length x)))
(do ((i 0 (+ i 1))) (do ((i 0 (+ i 1)))
@ -315,6 +387,27 @@
(scsh-emit-descriptor (d-vector-ref x i) reloc port) (scsh-emit-descriptor (d-vector-ref x i) reloc port)
(write-char #\, port)))) (write-char #\, port))))
;;; 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
(define (scsh-emit-vm-string-initializer x port) (define (scsh-emit-vm-string-initializer x port)
(let* ((len (vm-string-length x)) ; end is jawilson style hack (let* ((len (vm-string-length x)) ; end is jawilson style hack
(end (- (cells->bytes (bytes->cells (+ len 1))) 4))) (end (- (cells->bytes (bytes->cells (+ len 1))) 4)))
@ -353,16 +446,23 @@
(net-to-host-32 (bitwise-ior (net-to-host-32 (bitwise-ior
(bitwise-ior (bitwise-ior
(arithmetic-shift (arithmetic-shift
(char->ascii (vm-string-ref x i)) 24) (char->ascii
(vm-string-ref x i)) 24)
(arithmetic-shift (arithmetic-shift
(char->ascii (vm-string-ref x (+ i 1))) 16)) (char->ascii
(vm-string-ref x (+ i 1))) 16))
(bitwise-ior (bitwise-ior
(arithmetic-shift (arithmetic-shift
(char->ascii (vm-string-ref x (+ i 2))) 8) (char->ascii
(char->ascii (vm-string-ref x (+ i 3)))))) (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) ;;; scsh-emit-b-vector-initializer
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; byte vectors are byte order adjusted too
(define (scsh-emit-b-vector-initializer x externs port)
(cond ((and (code-vector? x) (cond ((and (code-vector? x)
(table-ref externs x)) => (table-ref externs x)) =>
(lambda (name) (lambda (name)
@ -376,7 +476,8 @@
((1) ((1)
(write-hex (write-hex
port port
(net-to-host-32 (arithmetic-shift (b-vector-ref x i) 24)))) (net-to-host-32
(arithmetic-shift (b-vector-ref x i) 24))))
((2) ((2)
(write-hex (write-hex
port port
@ -398,27 +499,20 @@
port port
(net-to-host-32 (bitwise-ior (net-to-host-32 (bitwise-ior
(bitwise-ior (bitwise-ior
(arithmetic-shift (b-vector-ref x i) 24) (arithmetic-shift
(arithmetic-shift (b-vector-ref x (+ i 1)) 16)) (b-vector-ref x i) 24)
(arithmetic-shift
(b-vector-ref x (+ i 1)) 16))
(bitwise-ior (bitwise-ior
(arithmetic-shift (b-vector-ref x (+ i 2)) 8) (arithmetic-shift
(b-vector-ref x (+ i 2)) 8)
(b-vector-ref x (+ i 3)))))))) (b-vector-ref x (+ i 3))))))))
))) )))
(define (scsh-emit-descriptor x reloc port) ;;; scsh-for-each-stored-object
(if (stob? x) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let ((n (chunk-number x))) ;;; see scheme48 for-each-stored-object
(display "(long)(&" port) ;;; Image traversal utility
(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) (define (scsh-for-each-stored-object chunk-start proc chunk-end)
(let ((limit (heap-pointer))) (let ((limit (heap-pointer)))
@ -434,20 +528,26 @@
(len (addr1+ (header-a-units d)))) (len (addr1+ (header-a-units d))))
(if (not (header? d)) (if (not (header? d))
(warn "heap is in an inconsistent state" d)) (warn "heap is in an inconsistent state" d))
(proc i (address->stob-descriptor (addr1+ addr)) len) (proc i
(address->stob-descriptor (addr1+ addr))
len)
(loop (addr+ addr len))) (loop (addr+ addr len)))
(begin (chunk-end i) (begin (chunk-end i)
(chunk-loop addr (chunk-loop addr
(+ i 1) (+ i 1)
(+ chunk *chunk-size*)))))))))) (+ chunk *chunk-size*))))))))))
;;; write-hex
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; utility routine to print a scheme number as a c hex number
(define (write-hex port x) (define (write-hex port x)
(format port (format port
(if (negative? x) "-0x~a," "0x~a,") (if (negative? x) "-0x~a," "0x~a,")
(number->string (abs x) 16))) (number->string (abs x) 16)))
;; takes a string and break it into a list at whitespace ;;; line->list
;; rewrite using scsh stuff? ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; utility that takes a string and break it into a list at whitespace
;;; rewrite using scsh stuff?
(define (line->list line) (define (line->list line)
(let ((len (string-length line))) (let ((len (string-length line)))
(let loop ((start 0) (let loop ((start 0)
@ -474,9 +574,9 @@
l)) l))
(else (error "unexpected case in line->list")))))) (else (error "unexpected case in line->list"))))))
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Debugging ;;; Debugging
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (bin n) (define (bin n)
(number->string n 2)) (number->string n 2))
@ -489,8 +589,15 @@
(define (hex n) (define (hex n)
(number->string n 16)) (number->string n 16))
;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- ;;; 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.
; For example: ; For example:
; (do-it 100000 "~/s48/debug/little.image" "little-heap.c") ; (do-it 100000 "~/s48/debug/little.image" "little-heap.c")