cleaned up static linker code
This commit is contained in:
bdc
parent
d472115b34
commit
b5a653f1f3
47
Makefile.in
47
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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -29,54 +40,139 @@
|
|||
scsh)
|
||||
(begin
|
||||
|
||||
(define (scsh-static-linker argl)
|
||||
(if (not (= (length argl) 3))
|
||||
(error "usage: ~a input-image-file output-executible-file"
|
||||
;;; 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))
|
||||
(let ((tempdir (or (getenv "TMPDIR")
|
||||
(exit 1)))
|
||||
(let ((temp-dir ; place for intermediate .c .o files
|
||||
(or (getenv "TMPDIR")
|
||||
"@TMPDIR@"))
|
||||
(cc-command (or (getenv "CC")
|
||||
(cc-command ; command to compile a .c file
|
||||
(or (getenv "CC")
|
||||
"@CC@ @CFLAGS@"))
|
||||
(linker-flags (or (getenv "LDFLAGS")
|
||||
(ld-flags ; flags needed to link executible
|
||||
(or (getenv "LDFLAGS")
|
||||
"@LDFLAGS@"))
|
||||
(libraries (or (getenv "LIBS")
|
||||
(libraries ; linbraries need to link executible
|
||||
(or (getenv "LIBS")
|
||||
"@LIBS@"))
|
||||
(infile (cadr argl))
|
||||
(outfile (caddr argl)))
|
||||
(scsh-do-it infile tempdir outfile
|
||||
cc-command linker-flags libraries)
|
||||
(exit 0))))
|
||||
(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)))
|
||||
|
||||
;;; 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,14 +329,13 @@
|
|||
(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")
|
||||
(cons "static.o"
|
||||
l)))))
|
||||
'("@prefix@/lib/scsh/libscshvm.a")
|
||||
libs))
|
||||
|
|
@ -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")
|
||||
(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))
|
||||
|
|
@ -490,7 +590,14 @@
|
|||
(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")
|
||||
|
|
|
|||
Loading…
Reference in New Issue