diff --git a/Makefile.in b/Makefile.in index 6007167..65dfd74 100644 --- a/Makefile.in +++ b/Makefile.in @@ -655,53 +655,6 @@ scsh/scsh.image: $(VM) $(SCHEME) $(CIG).image scsh/regexp/libregexp.a: 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 $(RM) $(bindir)/$(RUNNABLE) $(INSTALL_PROGRAM) $(srcdir)/scsh/scsh $(bindir)/$(RUNNABLE) diff --git a/scsh/static.scm.in b/scsh/static.scm.in index f5cf808..894e407 100644 --- a/scsh/static.scm.in +++ b/scsh/static.scm.in @@ -1,23 +1,34 @@ #!@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. ;;; 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 -;; heap-pointer -;; 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) +(define-structure static-heaps + (export static-heap-linker) (open scheme heap memory data stob struct heap-extra vm-architecture @@ -28,55 +39,140 @@ defrec-package scsh) (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) - (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)))) +;;; heap structure +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- (define-record heap (length 0) (objects '()) ) - ;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- - (define (scsh-do-it infile tempdir outfile - cc-command linker-flags libraries) - (let* ((temp-dir (format #f "~a/scsh~s" tempdir (pid))) - (prefix (string-append temp-dir "/static")) - (start (read-heap-image infile))) + +;;; 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 *** (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-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)) - (link-files cc-command linker-flags libraries outfile prefix) - ))) + (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. + (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) (cond ((vm-string? x) (let ((len (vm-string-length x))) @@ -89,68 +185,17 @@ (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) +;;; 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) (message "Writing header file") - (call-with-output-file (string-append prefix ".h") + (call-with-output-file "static.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 " */~%") + (format port " * by scsh/static.scm */~%") + ;; declare the long arrays for each heap chunk (let ((n (nchunks))) (do ((i 0 (+ i 1))) ((= i n)) @@ -160,47 +205,63 @@ ((= i n)) (format port "extern long i~s[~s];~%" i (quotient (heap:length (vector-ref impure i)) 4)))) + ;; declare the external references (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) +;;; write-c-image +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; responsible for writing the pure and impure heaps + (define (write-c-image pure impure reloc externs) (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") - (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))) + ;; iterate over all the chunks for this part of heap (let chunk-loop ((c 0)) (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 - (format #f "~a-~a~s.c" prefix name c) + (format #f "static-~a~s.c" name c) (lambda (port) - (format port "#include \"~a.h\"~%" prefix) + (format port "#include \"static.h\"~%") (format port "~a long ~a~s[]={~%" const name c) (let ((heap (vector-ref heap c))) + ;; iterate over each object (let heap-loop ((l (heap:objects heap))) (cond ((not (null? l)) - (scsh-emit-initializer (car l) reloc externs port) + (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) +;;; 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))) - (call-with-output-file (string-append prefix ".c") + (call-with-output-file "static.c" (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 i_count = ~s;~%" n) @@ -209,7 +270,6 @@ ((= 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)) @@ -221,7 +281,6 @@ ((= 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)) @@ -233,24 +292,31 @@ (write-char #\; 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)) (cc (append (line->list cc-command) '(-c)))) (message "Compiling main C file") - (message (append cc (list (format #f "~a.c" prefix)))) - (run (,@(append cc (list (format #f "~a.c" prefix))))) + (message (append cc '("static.c"))) + (run (,@(append cc '("static.c")))) (do ((i 0 (+ i 1))) ((= i n)) (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 - (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 (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 - (list (format #f "~a-i~s.c" prefix i)))))))) - - (define (link-files cc-command linker-flags libraries outfile prefix) + (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) (let ((n (nchunks)) (ld (append (line->list cc-command) (line->list linker-flags) @@ -263,15 +329,14 @@ (cond ((not (= i n)) (loop (+ i 1) (cons - (format #f "~a-i~s.o" prefix i) + (format #f "static-i~s.o" i) (cons - (format #f "~a-p~s.o" prefix i) + (format #f "static-p~s.o" i) l)))) (else (reverse - (cons - (string-append prefix ".o") - l))))) + (cons "static.o" + l))))) '("@prefix@/lib/scsh/libscshvm.a") libs)) (run (,@(append @@ -281,33 +346,40 @@ (cond ((not (= i n)) (loop (+ i 1) (cons - (format #f "~a-i~s.o" prefix i) + (format #f "static-i~s.o" i) (cons - (format #f "~a-p~s.o" prefix i) + (format #f "static-p~s.o" i) l)))) (else (reverse - (cons - (string-append prefix ".o") - l))))) + (cons "static.o" + l))))) '("@prefix@/lib/scsh/libscshvm.a") libs))))) +;;; scsh-emit-initializer +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; see scheme48 emit-initialize below (define (scsh-emit-initializer x reloc externs port) + ;; emit the header (write-hex port (stob-header x)) + ;; handle descriptor vectors and vm-strings. + ;; everything else is a byte vector (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))) + (scsh-emit-b-vector-initializer x externs port))) (if *comments?* (begin (display " /* " port) (writex x port) (display " */" 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) (let ((len (d-vector-length x))) (do ((i 0 (+ i 1))) @@ -315,6 +387,27 @@ (scsh-emit-descriptor (d-vector-ref x i) reloc 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) (let* ((len (vm-string-length x)) ; end is jawilson style hack (end (- (cells->bytes (bytes->cells (+ len 1))) 4))) @@ -353,16 +446,23 @@ (net-to-host-32 (bitwise-ior (bitwise-ior (arithmetic-shift - (char->ascii (vm-string-ref x i)) 24) + (char->ascii + (vm-string-ref x i)) 24) (arithmetic-shift - (char->ascii (vm-string-ref x (+ i 1))) 16)) + (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)))))) + (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) +;;; 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) (table-ref externs x)) => (lambda (name) @@ -376,7 +476,8 @@ ((1) (write-hex 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) (write-hex port @@ -398,27 +499,20 @@ 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) 24) + (arithmetic-shift + (b-vector-ref x (+ i 1)) 16)) (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)))))))) ))) - (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-for-each-stored-object +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; see scheme48 for-each-stored-object +;;; Image traversal utility (define (scsh-for-each-stored-object chunk-start proc chunk-end) (let ((limit (heap-pointer))) @@ -434,20 +528,26 @@ (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) + (proc i + (address->stob-descriptor (addr1+ addr)) + len) (loop (addr+ addr len))) (begin (chunk-end i) (chunk-loop addr (+ i 1) (+ chunk *chunk-size*)))))))))) - +;;; write-hex +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; utility routine to print a scheme number as a c hex number (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? +;;; line->list +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; utility that 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) @@ -474,9 +574,9 @@ l)) (else (error "unexpected case in line->list")))))) -;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Debugging -;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (bin n) (number->string n 2)) @@ -489,8 +589,15 @@ (define (hex n) (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: ; (do-it 100000 "~/s48/debug/little.image" "little-heap.c")