From 0d6cbfb5fa7ca97f149403333c4f33d482d70d82 Mon Sep 17 00:00:00 2001 From: bdc Date: Fri, 1 Nov 1996 07:40:21 +0000 Subject: [PATCH] reworked argument parsing to make in a littl cleaner i hope; most C compilation now done in background --- scsh/static.scm.in | 418 +++++++++++++++++++++++---------------------- 1 file changed, 216 insertions(+), 202 deletions(-) diff --git a/scsh/static.scm.in b/scsh/static.scm.in index 877d589..af71e7b 100644 --- a/scsh/static.scm.in +++ b/scsh/static.scm.in @@ -46,92 +46,95 @@ For testing load this at a scsh prompt ;;; real work in static-heap-linker1 ;;; argl is a list of the command line arguments (define (static-heap-linker argl) - (let ((temp-dir-arg #f) - (cc-command-arg #f) - (ld-flags-arg #f) - (libraries-arg #f) - (input-image-arg #f) - (output-executible-arg #f)) - (let loop ((args (cdr argl))) - (cond ((null? args) - (cond ((not output-executible-arg) - (display "error: -o is a required argument") - (newline) - (usage (car argl))) - ((not input-image-arg) - (display "error: -i is a required argument") - (newline) - (usage (car argl))))) - ((equal? (car args) "-o") - (cond ((not (null? (cdr args))) - (set! output-executible-arg (cadr args)) - (loop (cddr args))) - (else - (display "error: -o requires argument") (newline) - (usage (car argl))))) - ((equal? (car args) "-i") - (cond ((not (null? (cdr args))) - (set! input-executible-arg (cadr args)) - (loop (cddr args))) - (else - (display "error: -i requires argument") (newline) - (usage (car argl))))) - ((equal? (car args) "--temp") - (cond ((not (null? (cdr args))) - (set! temp-dir-arg (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! cc-command-arg (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! ld-command-arg (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! libraries-arg (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))))) - (let ((temp-dir ; place for intermediate .c .o files - (or temp-dir-arg - (getenv "TMPDIR") - "@TMPDIR@")) - (cc-command ; command to compile a .c file - (or cc-command-arg - (getenv "CC") - "@CC@ @CFLAGS@")) - (ld-flags ; flags needed to link executible - (or ld-flags-arg - (getenv "LDFLAGS") - "@LDFLAGS@")) - (libraries ; linbraries need to link executible - (or libraries-arg - (getenv "LIBS") - "@LIBS@")) - (input-image ; the input scheme image file - (cadr argl)) - (output-executible ; the output executible file - (caddr argl))) - (static-heap-linker1 input-image temp-dir output-executible - cc-command ld-flags libraries) - (exit 0)))) - + (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-executible 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) "-o") + (cond ((not (null? (cdr args))) + (set-options:output-executible options (cadr args)) + (loop (cddr args))) + (else + (display "error: -o requires 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) "--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: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 @@ -143,6 +146,18 @@ For testing load this at a scsh prompt program-name) (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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -153,33 +168,44 @@ For testing load this at a scsh prompt ;;; 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 *** + (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-executible + 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) - (create-heaps-and-tables) ; *** EVAL *** + (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? 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 ; *** PRINT *** + (if (file-exists? (options:temp-dir options)) + (if (file-directory? (options:temp-dir otions)) + (with-cwd (options:temp-dir options) + (map delete-file (directory-files + (options:temp-dir options) #t))) + (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) - (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)))) + (compile-main-c-file start reloc options) + (compile-c-image pure impure reloc externs options) + (link-files options) + (map delete-file (directory-files + (options:temp-dir options) #t))) + (delete-directory (options:temp-dir options))))) ;;; read-heap-image ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -188,7 +214,7 @@ For testing load this at a scsh prompt (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 + ;; XXX the 1.1 is because we need a little extra space for find-all-xs ;;; 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 (scsh-for-each-stored-object (lambda (chunk) - (format #t "Reading chunk number ~s" chunk)) + (display ".")) (lambda (chunk x len) (let* ((heap ; choose the appropriate heap (vector-ref (if (mutable? x) impure pure) chunk))) @@ -230,8 +256,8 @@ For testing load this at a scsh prompt (table-set! externs (external-value x) (vm-string->string (external-name x)))))) - (lambda (chunk) - (newline))) + (lambda (chunk) 'foo)) + (newline) ;; put all the heaps in the correct order (let loop ((i 0)) (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 extern references to other c functions (define (write-c-header-file pure impure externs) - (message "Writing header file") (call-with-output-file "static.h" (lambda (port) (format port "/* Static Heap File Automatically Generated~%") @@ -284,41 +309,7 @@ For testing load this at a scsh prompt externs) ))) -;;; write-c-image -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; 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 +;;; compile-main-c-file ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; creates the top level interfaces that scheme48 wants to see ;;; p_count i_count @@ -329,8 +320,9 @@ For testing load this at a scsh prompt ;;; sizes of each chunk ;;; entry ;;; the starting entry point - (define (write-main-c-file start reloc) - (let ((n (nchunks))) + (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\"~%") @@ -362,39 +354,61 @@ For testing load this at a scsh prompt (display "const long entry = " port) (scsh-emit-descriptor start reloc port) (write-char #\; 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") + (newline port))) (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 "static-p~s.c" i)))) - (run (,@(append cc - (list (format #f "static-p~s.c" i))))) - (message "Compiling C file for impure chunk " i) - (message (append cc (list (format #f "static-i~s.c" i)))) - (run (,@(append cc - (list (format #f "static-i~s.c" i)))))))) + (run (,@(append cc '("static.c")))))) + +;;; 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)) + (message (append cc (list filename))) + (set! process (& (,@(append cc (list filename))))) + (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 executible - (define (link-files cc-command linker-flags libraries outfile) + (define (link-files options) (let ((n (nchunks)) - (ld (append (line->list cc-command) - (line->list linker-flags) - `(-o ,outfile))) - (libs (line->list libraries))) - (message "Linking executible") + (ld (append (line->list (options:cc-command options)) + (line->list (options:ld-flags options)) + `(-o ,(options:output-executible options)))) + (libs (line->list (options:libraries options)))) (message (append ld (let loop ((i 0) (l '())) @@ -402,9 +416,9 @@ For testing load this at a scsh prompt (loop (+ i 1) (cons (format #f "static-i~s.o" i) - (cons - (format #f "static-p~s.o" i) - l)))) + (cons + (format #f "static-p~s.o" i) + l)))) (else (reverse (cons "static.o" @@ -417,15 +431,15 @@ For testing load this at a scsh prompt (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))))) + (cons + (format #f "static-i~s.o" i) + (cons + (format #f "static-p~s.o" i) + l)))) + (else + (reverse + (cons "static.o" + l))))) '("@prefix@/lib/scsh/libscshvm.a") libs))))) @@ -481,7 +495,7 @@ For testing load this at a scsh prompt ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 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 + (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) @@ -671,21 +685,21 @@ For testing load this at a scsh prompt ;;; 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. + ; 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 + ; 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)