Next case of death.
This commit is contained in:
mainzelm
parent
29ed0edb27
commit
16f7c7ce18
|
|
@ -1,913 +0,0 @@
|
|||
#!@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
|
||||
))
|
||||
Loading…
Reference in New Issue