914 lines
29 KiB
Scheme
914 lines
29 KiB
Scheme
#!@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 static-heaps -e static-heap-linker -s
|
|
!#
|
|
|
|
#!
|
|
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 static-heaps
|
|
(export static-heap-linker)
|
|
(open scheme heap memory data stob struct
|
|
heap-extra
|
|
vm-architecture
|
|
formats
|
|
enumerated
|
|
signals
|
|
tables
|
|
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)
|
|
(static-heap-linker1 (parse-options argl))
|
|
(exit 0))
|
|
|
|
;;; parse-options
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; parses the command line options
|
|
;;; returns them in an options structure
|
|
(define (parse-options argl)
|
|
(let ((options (make-options)))
|
|
|
|
(let loop ((args (cdr argl)))
|
|
(cond ((null? args)
|
|
(cond ((not (options:output-executable options))
|
|
(display "error: -o is a required argument")
|
|
(newline)
|
|
(usage (car argl)))
|
|
((not (options:input-image options))
|
|
(display "error: -i is a required argument")
|
|
(newline)
|
|
(usage (car argl)))))
|
|
((equal? (car args) "-i")
|
|
(cond ((not (null? (cdr args)))
|
|
(set-options:input-image options (cadr args))
|
|
(loop (cddr args)))
|
|
(else
|
|
(display "error: -i requires argument") (newline)
|
|
(usage (car argl)))))
|
|
((equal? (car args) "-o")
|
|
(cond ((not (null? (cdr args)))
|
|
(set-options:output-executable options (cadr args))
|
|
(loop (cddr args)))
|
|
(else
|
|
(display "error: -o requires argument") (newline)
|
|
(usage (car argl)))))
|
|
((equal? (car args) "--args")
|
|
(cond ((not (null? (cdr args)))
|
|
(set-options:args-parser options (cadr args))
|
|
(loop (cddr args)))
|
|
(else
|
|
(display "error: --args requires argument") (newline)
|
|
(usage (car argl)))))
|
|
((equal? (car args) "--temp")
|
|
(cond ((not (null? (cdr args)))
|
|
(set-options:temp-dir options (cadr args))
|
|
(loop (cddr args)))
|
|
(else
|
|
(display "error: --temp requires argument") (newline)
|
|
(usage (car argl)))))
|
|
((equal? (car args) "--cc")
|
|
(cond ((not (null? (cdr args)))
|
|
(set-options:cc-command options (cadr args))
|
|
(loop (cddr args)))
|
|
(else
|
|
(display "error: --cc requires argument") (newline)
|
|
(usage (car argl)))))
|
|
((equal? (car args) "--ld")
|
|
(cond ((not (null? (cdr args)))
|
|
(set-options:ld-command options (cadr args))
|
|
(loop (cddr args)))
|
|
(else
|
|
(display "error: --ld requires argument") (newline)
|
|
(usage (car argl)))))
|
|
((equal? (car args) "--libs")
|
|
(cond ((not (null? (cdr args)))
|
|
(set-options:libraries options (cadr args))
|
|
(loop (cddr args)))
|
|
(else
|
|
(display "error: --libs requires argument") (newline)
|
|
(usage (car argl)))))
|
|
(else
|
|
(format #t "error: unknown argument ~a" (car args))
|
|
(newline)
|
|
(usage (car argl)))))
|
|
(set-options:args-parser
|
|
options
|
|
(if (options:args-parser options)
|
|
(list (options:args-parser options))
|
|
'()))
|
|
(set-options:temp-dir
|
|
options
|
|
(or (options:temp-dir options)
|
|
(getenv "TMPDIR")
|
|
"@TMPDIR@"))
|
|
(set-options:cc-command
|
|
options
|
|
(or (options:cc-command options)
|
|
(getenv "CC")
|
|
"@CC@ @CFLAGS@"))
|
|
(set-options:ld-flags
|
|
options
|
|
(or (options:ld-flags options)
|
|
(getenv "LDFLAGS")
|
|
"@LDFLAGS@"))
|
|
(set-options:libraries
|
|
options
|
|
(or (options:libraries options)
|
|
(getenv "LIBS")
|
|
"@LIBS@"))
|
|
options))
|
|
|
|
;;; usage reporting
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (usage program-name)
|
|
(format #t
|
|
(string-append
|
|
"usage: ~a ~%"
|
|
" [-i image]~%"
|
|
" [-o executable]~%"
|
|
" [--args object]~%"
|
|
" [--temp directory]~%"
|
|
" [--cc command]~%"
|
|
" [--ld command]~%"
|
|
" [--libs libraries]~%")
|
|
program-name)
|
|
(exit 1))
|
|
|
|
;;; options structure
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-record options
|
|
(input-image #f) ; the input scheme image file
|
|
(output-executable #f) ; the output executable file
|
|
(args-parser #f) ; .o file for replacement process_args
|
|
(temp-dir #f) ; place for intermediate .c .o files
|
|
(cc-command #f) ; command to compile a .c file
|
|
(ld-flags #f) ; flags needed to link executable
|
|
(libraries #f) ; linbraries need to link executable
|
|
)
|
|
|
|
;;; heap structure
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-record heap
|
|
(length 0)
|
|
(objects '())
|
|
)
|
|
|
|
;;; static-heap-linker1
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (static-heap-linker1 options)
|
|
|
|
;;; munge some options into a more usable form
|
|
(set-options:temp-dir
|
|
options
|
|
(format #f "~a/scsh~s" (options:temp-dir options) (pid)))
|
|
(set-options:output-executable
|
|
options
|
|
(string-append (cwd) "/" (options:output-executable options)))
|
|
|
|
;;; Read the image
|
|
(let ((start ; entry point of image
|
|
(read-heap-image (options:input-image options))))
|
|
|
|
;;; Process the image
|
|
(receive (pure impure reloc externs)
|
|
(create-heaps-and-tables)
|
|
|
|
;;; Prepare for output
|
|
;;; if directory exists blow it away
|
|
;;; useful for repeated runs from within same scsh process
|
|
(if (file-exists? (options:temp-dir options))
|
|
(cond ((file-directory? (options:temp-dir otions))
|
|
(with-cwd (options:temp-dir options)
|
|
(let loop ((files (directory-files
|
|
(options:temp-dir options)
|
|
#t)))
|
|
(cond ((not (null? files))
|
|
(delete-file (car files))
|
|
(loop (cdr files))))))
|
|
(delete-directory (options:temp-dir options)))
|
|
(else
|
|
(delete-file (options:temp-dir options)))))
|
|
(create-directory (options:temp-dir options) #o755 #t)
|
|
|
|
;;; Process the info we gather to make it the output file
|
|
(with-cwd (options:temp-dir options)
|
|
(write-c-header-file pure impure externs)
|
|
(compile-main-c-file start reloc options)
|
|
(compile-c-image pure impure reloc externs options)
|
|
(link-files options)
|
|
(let loop ((files (directory-files
|
|
(options:temp-dir options) #t)))
|
|
(cond ((not (null? files))
|
|
(delete-file (car files))
|
|
(loop (cdr files))))))
|
|
(delete-directory (options:temp-dir options)))))
|
|
|
|
;;; 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 the 1.1 is because we need a 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
|
|
(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)
|
|
(display "."))
|
|
(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) 'foo))
|
|
(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)))
|
|
(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)
|
|
(call-with-output-file "static.h"
|
|
(lambda (port)
|
|
(format port "/* Static Heap File Automatically Generated~%")
|
|
(format port " * by scsh/static.scm */~%")
|
|
;; declare the long arrays for each heap chunk
|
|
(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))))
|
|
;; declare the external references
|
|
(table-walk
|
|
(lambda (address name)
|
|
(format port "const extern ~a();~%" name))
|
|
externs)
|
|
)))
|
|
|
|
;;; compile-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 (compile-main-c-file start reloc options)
|
|
(let ((n (nchunks))
|
|
(cc (append (line->list (options:cc-command options)) '(-c))))
|
|
(call-with-output-file "static.c"
|
|
(lambda (port)
|
|
(format port "#include \"static.h\"~%")
|
|
(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)))
|
|
(let ((command (append cc '("static.c"))))
|
|
(message command)
|
|
(run (,@command)))))
|
|
|
|
;;; compile-c-image
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; responsible for writing and compiling the pure and impure heaps
|
|
(define (compile-c-image pure impure reloc externs options)
|
|
(compile-c-image1 pure "p" "const " reloc externs options)
|
|
(compile-c-image1 impure "i" "" reloc externs options))
|
|
|
|
;;; compile-c-image1
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; writes and compiles the c long array
|
|
(define (compile-c-image1 heap name const reloc externs options)
|
|
(let* ((n (nchunks))
|
|
(process #f)
|
|
(cc (append (line->list (options:cc-command options)) '(-c))))
|
|
;; iterate over all the chunks for this part of heap
|
|
(let chunk-loop ((c 0))
|
|
(cond ((not (= c n))
|
|
(let ((filename (format #f "static-~a~s.c" name c)))
|
|
(call-with-output-file filename
|
|
(lambda (port)
|
|
(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)
|
|
(heap-loop (cdr l))))))
|
|
(display "};" port)
|
|
(newline port)))
|
|
;; wait for last compile before starting new one
|
|
(if process
|
|
(wait process))
|
|
(let ((command (append cc (list filename))))
|
|
(message command)
|
|
(set! process (& (,@command))))
|
|
(chunk-loop (+ 1 c))))
|
|
(else
|
|
(wait process))))))
|
|
|
|
;;; link-files
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; links the .o's from compile-c-files
|
|
;;; uses the provided flags and libraries
|
|
;;; produces outfile as executable
|
|
(define (link-files options)
|
|
(let ((n (nchunks))
|
|
(ld (append (line->list (options:cc-command options))
|
|
(line->list (options:ld-flags options))
|
|
`(-o ,(options:output-executable options))))
|
|
(libs (line->list (options:libraries options))))
|
|
(let ((command (append ld
|
|
(let loop ((i 0)
|
|
(l '()))
|
|
(cond ((not (= i n))
|
|
(loop (+ i 1)
|
|
(cons
|
|
(format #f "static-i~s.o" i)
|
|
(cons
|
|
(format #f "static-p~s.o" i)
|
|
l))))
|
|
(else
|
|
(reverse
|
|
(cons "static.o"
|
|
l)))))
|
|
(options:args-parser options)
|
|
'("-L" "@prefix@/lib/scsh" "-lscshvm")
|
|
libs)))
|
|
(message command)
|
|
(run (,@command)))))
|
|
|
|
;;; 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 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)))
|
|
((= i len))
|
|
(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)))
|
|
(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))))))
|
|
))))
|
|
|
|
;;; 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)
|
|
(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))))))))
|
|
)))
|
|
|
|
;;; 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)))
|
|
(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*))))))))))
|
|
;;; 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)))
|
|
|
|
;;; 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)
|
|
(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))
|
|
|
|
;;; 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")
|
|
;
|
|
; 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
|
|
))
|