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

reworked argument parsing to make in a littl cleaner i hope; most C compilation now done in background

This commit is contained in:
bdc 1996-11-01 07:40:21 +00:00
parent 55a65c1b64
commit 0d6cbfb5fa
1 changed files with 216 additions and 202 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

418
scsh/static.scm.in
View File

@ -46,92 +46,95 @@ For testing load this at a scsh prompt
;;; real work in static-heap-linker1 ;;; real work in static-heap-linker1
;;; argl is a list of the command line arguments ;;; argl is a list of the command line arguments
(define (static-heap-linker argl) (define (static-heap-linker argl)
(let ((temp-dir-arg #f) (static-heap-linker1 (parse-options argl))
(cc-command-arg #f) (exit 0))
(ld-flags-arg #f)
(libraries-arg #f) ;;; parse-options
(input-image-arg #f) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(output-executible-arg #f)) ;;; parses the command line options
(let loop ((args (cdr argl))) ;;; returns them in an options structure
(cond ((null? args) (define (parse-options argl)
(cond ((not output-executible-arg) (let ((options (make-options)))
(display "error: -o is a required argument") (let loop ((args (cdr argl)))
(newline) (cond ((null? args)
(usage (car argl))) (cond ((not (options:output-executible options))
((not input-image-arg) (display "error: -o is a required argument")
(display "error: -i is a required argument") (newline)
(newline) (usage (car argl)))
(usage (car argl))))) ((not (options:input-image options))
((equal? (car args) "-o") (display "error: -i is a required argument")
(cond ((not (null? (cdr args))) (newline)
(set! output-executible-arg (cadr args)) (usage (car argl)))))
(loop (cddr args))) ((equal? (car args) "-o")
(else (cond ((not (null? (cdr args)))
(display "error: -o requires argument") (newline) (set-options:output-executible options (cadr args))
(usage (car argl))))) (loop (cddr args)))
((equal? (car args) "-i") (else
(cond ((not (null? (cdr args))) (display "error: -o requires argument") (newline)
(set! input-executible-arg (cadr args)) (usage (car argl)))))
(loop (cddr args))) ((equal? (car args) "-i")
(else (cond ((not (null? (cdr args)))
(display "error: -i requires argument") (newline) (set-options:input-image options (cadr args))
(usage (car argl))))) (loop (cddr args)))
((equal? (car args) "--temp") (else
(cond ((not (null? (cdr args))) (display "error: -i requires argument") (newline)
(set! temp-dir-arg (cadr args)) (usage (car argl)))))
(loop (cddr args))) ((equal? (car args) "--temp")
(else (cond ((not (null? (cdr args)))
(display "error: --temp requires argument") (newline) (set-options:temp-dir options (cadr args))
(usage (car argl))))) (loop (cddr args)))
((equal? (car args) "--cc") (else
(cond ((not (null? (cdr args))) (display "error: --temp requires argument") (newline)
(set! cc-command-arg (cadr args)) (usage (car argl)))))
(loop (cddr args))) ((equal? (car args) "--cc")
(else (cond ((not (null? (cdr args)))
(display "error: --cc requires argument") (newline) (set-options:cc-command options (cadr args))
(usage (car argl))))) (loop (cddr args)))
((equal? (car args) "--ld") (else
(cond ((not (null? (cdr args))) (display "error: --cc requires argument") (newline)
(set! ld-command-arg (cadr args)) (usage (car argl)))))
(loop (cddr args))) ((equal? (car args) "--ld")
(else (cond ((not (null? (cdr args)))
(display "error: --ld requires argument") (newline) (set-options:ld-command options (cadr args))
(usage (car argl))))) (loop (cddr args)))
((equal? (car args) "--libs") (else
(cond ((not (null? (cdr args))) (display "error: --ld requires argument") (newline)
(set! libraries-arg (cadr args)) (usage (car argl)))))
(loop (cddr args))) ((equal? (car args) "--libs")
(else (cond ((not (null? (cdr args)))
(display "error: --libs requires argument") (newline) (set-options:libraries options (cadr args))
(usage (car argl))))) (loop (cddr args)))
(else (else
(format #t "error: unknown argument ~a" (car args)) (display "error: --libs requires argument") (newline)
(newline) (usage (car argl)))))
(usage (car argl))))) (else
(let ((temp-dir ; place for intermediate .c .o files (format #t "error: unknown argument ~a" (car args))
(or temp-dir-arg (newline)
(getenv "TMPDIR") (usage (car argl)))))
"@TMPDIR@")) (set-options:temp-dir
(cc-command ; command to compile a .c file options
(or cc-command-arg (or (options:temp-dir options)
(getenv "CC") (getenv "TMPDIR")
"@CC@ @CFLAGS@")) "@TMPDIR@"))
(ld-flags ; flags needed to link executible (set-options:cc-command
(or ld-flags-arg options
(getenv "LDFLAGS") (or (options:cc-command options)
"@LDFLAGS@")) (getenv "CC")
(libraries ; linbraries need to link executible "@CC@ @CFLAGS@"))
(or libraries-arg (set-options:ld-flags
(getenv "LIBS") options
"@LIBS@")) (or (options:ld-flags options)
(input-image ; the input scheme image file (getenv "LDFLAGS")
(cadr argl)) "@LDFLAGS@"))
(output-executible ; the output executible file (set-options:libraries
(caddr argl))) options
(static-heap-linker1 input-image temp-dir output-executible (or (options:libraries options)
cc-command ld-flags libraries) (getenv "LIBS")
(exit 0)))) "@LIBS@"))
options))
;;; usage reporting
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (usage program-name) (define (usage program-name)
(format #t (format #t
(string-append (string-append
@ -143,6 +146,18 @@ For testing load this at a scsh prompt
program-name) program-name)
(exit 1)) (exit 1))
;;; options structure
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-record options
(input-image #f) ; the input scheme image file
(temp-dir #f) ; place for intermediate .c .o files
(output-executible #f) ; the output executible file
(cc-command #f) ; command to compile a .c file
(ld-flags #f) ; flags needed to link executible
(libraries #f) ; linbraries need to link executible
)
;;; heap structure ;;; heap structure
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -153,33 +168,44 @@ For testing load this at a scsh prompt
;;; static-heap-linker1 ;;; static-heap-linker1
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (static-heap-linker1 input-image tempdir output-executible (define (static-heap-linker1 options)
cc-command ld-flags libraries)
(let* ((temp-dir ; make a unique directory with pid ;;; munge some options into a more usable form
(format #f "~a/scsh~s" tempdir (pid))) (set-options:temp-dir
(output-file ; executible relateive to cwd options
(string-append (cwd) "/" output-executible)) (format #f "~a/scsh~s" (options:temp-dir options) (pid)))
(start ; entry point of image (set-options:output-executible
(read-heap-image input-image))) ; *** READ *** options
(string-append (cwd) "/" (options:output-executible 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) (receive (pure impure reloc externs)
(create-heaps-and-tables) ; *** EVAL *** (create-heaps-and-tables)
;;; Prepare for output
;;; if directory exists blow it away ;;; if directory exists blow it away
;;; useful for repeated runs from within same scsh process ;;; useful for repeated runs from within same scsh process
(if (file-exists? temp-dir) (if (file-exists? (options:temp-dir options))
(if (file-directory? temp-dir) (if (file-directory? (options:temp-dir otions))
(with-cwd temp-dir (with-cwd (options:temp-dir options)
(map delete-file (directory-files temp-dir #t))) (map delete-file (directory-files
(delete-file temp-dir))) (options:temp-dir options) #t)))
(create-directory temp-dir #o755 #t) (delete-file (options:temp-dir options))))
(with-cwd temp-dir ; *** PRINT *** (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) (write-c-header-file pure impure externs)
(write-c-image pure impure reloc externs) (compile-main-c-file start reloc options)
(write-main-c-file start reloc) (compile-c-image pure impure reloc externs options)
(compile-c-files cc-command) (link-files options)
(link-files cc-command ld-flags libraries (map delete-file (directory-files
output-file) (options:temp-dir options) #t)))
(map delete-file (directory-files temp-dir #t))) (delete-directory (options:temp-dir options)))))
(delete-directory temp-dir))))
;;; read-heap-image ;;; read-heap-image
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -188,7 +214,7 @@ For testing load this at a scsh prompt
(define (read-heap-image infile) (define (read-heap-image infile)
(let ((bytes (file-info:size (file-info infile)))) (let ((bytes (file-info:size (file-info infile))))
(init (inexact->exact (floor (* 1.1 bytes))) infile))) (init (inexact->exact (floor (* 1.1 bytes))) infile)))
; XXX need little extra space for find-all-xs ;; XXX the 1.1 is because we need a little extra space for find-all-xs
;;; create-heaps-and-tables ;;; create-heaps-and-tables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -215,7 +241,7 @@ For testing load this at a scsh prompt
;; we construct our own data structures describing the layout ;; we construct our own data structures describing the layout
(scsh-for-each-stored-object (scsh-for-each-stored-object
(lambda (chunk) (lambda (chunk)
(format #t "Reading chunk number ~s" chunk)) (display "."))
(lambda (chunk x len) (lambda (chunk x len)
(let* ((heap ; choose the appropriate heap (let* ((heap ; choose the appropriate heap
(vector-ref (if (mutable? x) impure pure) chunk))) (vector-ref (if (mutable? x) impure pure) chunk)))
@ -230,8 +256,8 @@ For testing load this at a scsh prompt
(table-set! externs (table-set! externs
(external-value x) (external-value x)
(vm-string->string (external-name x)))))) (vm-string->string (external-name x))))))
(lambda (chunk) (lambda (chunk) 'foo))
(newline))) (newline)
;; put all the heaps in the correct order ;; put all the heaps in the correct order
(let loop ((i 0)) (let loop ((i 0))
(cond ((not (= i n)) (cond ((not (= i n))
@ -262,7 +288,6 @@ For testing load this at a scsh prompt
;;; declares the c long arrays for each heap chunk ;;; declares the c long arrays for each heap chunk
;;; declares the extern references to other c functions ;;; declares the extern references to other c functions
(define (write-c-header-file pure impure externs) (define (write-c-header-file pure impure externs)
(message "Writing header file")
(call-with-output-file "static.h" (call-with-output-file "static.h"
(lambda (port) (lambda (port)
(format port "/* Static Heap File Automatically Generated~%") (format port "/* Static Heap File Automatically Generated~%")
@ -284,41 +309,7 @@ For testing load this at a scsh prompt
externs) externs)
))) )))
;;; write-c-image ;;; compile-main-c-file
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; responsible for writing the pure and impure heaps
(define (write-c-image pure impure reloc externs)
(message "Writing pure c files")
(write-c-image1 pure "p" "const " reloc externs)
(message "Writing impure c files")
(write-c-image1 impure "i" "" reloc externs))
;;; 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 static-~a~s.c~%" name c)
(call-with-output-file
(format #f "static-~a~s.c" name c)
(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)))
(chunk-loop (+ 1 c)))))))
;;; write-main-c-file
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; creates the top level interfaces that scheme48 wants to see ;;; creates the top level interfaces that scheme48 wants to see
;;; p_count i_count ;;; p_count i_count
@ -329,8 +320,9 @@ For testing load this at a scsh prompt
;;; sizes of each chunk ;;; sizes of each chunk
;;; entry ;;; entry
;;; the starting entry point ;;; the starting entry point
(define (write-main-c-file start reloc) (define (compile-main-c-file start reloc options)
(let ((n (nchunks))) (let ((n (nchunks))
(cc (append (line->list (options:cc-command options)) '(-c))))
(call-with-output-file "static.c" (call-with-output-file "static.c"
(lambda (port) (lambda (port)
(format port "#include \"static.h\"~%") (format port "#include \"static.h\"~%")
@ -362,39 +354,61 @@ For testing load this at a scsh prompt
(display "const long entry = " port) (display "const long entry = " port)
(scsh-emit-descriptor start reloc port) (scsh-emit-descriptor start reloc port)
(write-char #\; port) (write-char #\; port)
(newline port))))) (newline port)))
;;; 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 '("static.c"))) (message (append cc '("static.c")))
(run (,@(append cc '("static.c")))) (run (,@(append cc '("static.c"))))))
(do ((i 0 (+ i 1)))
((= i n)) ;;; compile-c-image
(message "Compiling C file for pure chunk " i) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(message (append cc (list (format #f "static-p~s.c" i)))) ;;; responsible for writing and compiling the pure and impure heaps
(run (,@(append cc (define (compile-c-image pure impure reloc externs options)
(list (format #f "static-p~s.c" i))))) (compile-c-image1 pure "p" "const " reloc externs options)
(message "Compiling C file for impure chunk " i) (compile-c-image1 impure "i" "" reloc externs options))
(message (append cc (list (format #f "static-i~s.c" i))))
(run (,@(append cc ;;; compile-c-image1
(list (format #f "static-i~s.c" i)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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))
(message (append cc (list filename)))
(set! process (& (,@(append cc (list filename)))))
(chunk-loop (+ 1 c))))
(else
(wait process))))))
;;; link-files ;;; link-files
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; links the .o's from compile-c-files ;;; links the .o's from compile-c-files
;;; uses the provided flags and libraries ;;; uses the provided flags and libraries
;;; produces outfile as executible ;;; produces outfile as executible
(define (link-files cc-command linker-flags libraries outfile) (define (link-files options)
(let ((n (nchunks)) (let ((n (nchunks))
(ld (append (line->list cc-command) (ld (append (line->list (options:cc-command options))
(line->list linker-flags) (line->list (options:ld-flags options))
`(-o ,outfile))) `(-o ,(options:output-executible options))))
(libs (line->list libraries))) (libs (line->list (options:libraries options))))
(message "Linking executible")
(message (append ld (message (append ld
(let loop ((i 0) (let loop ((i 0)
(l '())) (l '()))
@ -402,9 +416,9 @@ For testing load this at a scsh prompt
(loop (+ i 1) (loop (+ i 1)
(cons (cons
(format #f "static-i~s.o" i) (format #f "static-i~s.o" i)
(cons (cons
(format #f "static-p~s.o" i) (format #f "static-p~s.o" i)
l)))) l))))
(else (else
(reverse (reverse
(cons "static.o" (cons "static.o"
@ -417,15 +431,15 @@ For testing load this at a scsh prompt
(l '())) (l '()))
(cond ((not (= i n)) (cond ((not (= i n))
(loop (+ i 1) (loop (+ i 1)
(cons (cons
(format #f "static-i~s.o" i) (format #f "static-i~s.o" i)
(cons (cons
(format #f "static-p~s.o" i) (format #f "static-p~s.o" i)
l)))) l))))
(else (else
(reverse (reverse
(cons "static.o" (cons "static.o"
l))))) l)))))
'("@prefix@/lib/scsh/libscshvm.a") '("@prefix@/lib/scsh/libscshvm.a")
libs))))) libs)))))
@ -481,7 +495,7 @@ For testing load this at a scsh prompt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; vm-strings are converted to numbers and byte order adjusted ;;; vm-strings are converted to numbers and byte order adjusted
(define (scsh-emit-vm-string-initializer x port) (define (scsh-emit-vm-string-initializer x port)
(let* ((len (vm-string-length x)) ; end is jawilson style hack (let* ((len (vm-string-length x)) ; end is jawilson style hack
(end (- (cells->bytes (bytes->cells (+ len 1))) 4))) (end (- (cells->bytes (bytes->cells (+ len 1))) 4)))
(do ((i 0 (+ i 4))) (do ((i 0 (+ i 4)))
((= i end) ((= i end)
@ -671,21 +685,21 @@ For testing load this at a scsh prompt
;;; information. Because I needed to break up the files, I had to ;;; information. Because I needed to break up the files, I had to
;;; calculate this information myself. ;;; calculate this information myself.
; For example: ; For example:
; (do-it 100000 "~/s48/debug/little.image" "little-heap.c") ; (do-it 100000 "~/s48/debug/little.image" "little-heap.c")
; ;
; The first argument to do-it should be somewhat larger than the size, ; 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 ; in bytes, of the image file to be converted (which you can obtain with
; "ls -l"). ; "ls -l").
; ;
; If the image contains 0-length stored objects, then the .c file will ; 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 ; have to be compiled by gcc, since 0-length arrays aren't allowed in
; ANSI C. This wouldn't be difficult to work around. ; ANSI C. This wouldn't be difficult to work around.
(define *comments?* #f) (define *comments?* #f)
; 800,000 bytes => 200,000 words => at least 100,000 objects ; 800,000 bytes => 200,000 words => at least 100,000 objects
; 50 chunks => 16,000 bytes per chunk => 2,000 objects per chunk ; 50 chunks => 16,000 bytes per chunk => 2,000 objects per chunk
(define *chunk-size* 10000) (define *chunk-size* 10000)
(define (do-it bytes infile outfile) (define (do-it bytes infile outfile)