artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

mescc: Be silent.

Browse source 
* module/mescc/M1.scm (infos->M1, info->M1): Add verbose?.  Move
debugging into verbose? > 1.
* module/mescc/compile.scm (c99-input->info, c99-ast->info): Likewise.
(mescc:trace-verbose): Rename from mescc:trace.
(mescc:trace): New function.
* module/mescc.scm (mescc:main): Likewise.
* module/mescc/mescc.scm (mescc:preprocess, c->ast mescc:compile,
c->info, E->info): Likewise.
* module/mescc/preprocess.scm (c99-input->full-ast, c99-input->ast):
Likewise.
This commit is contained in:
Jan Nieuwenhuizen 2019-07-27 09:51:21 +02:00
parent af1cc3ce81
commit c03807b78f
No known key found for this signature in database
GPG key ID: F3C1A0D9C1D65273
5 changed files with 82 additions and 59 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
module/mescc.scm
View file

@ -158,10 +158,11 @@ General help using GNU software: <http://gnu.org/gethelp/>
(preprocess? (option-ref options 'preprocess #f)) (preprocess? (option-ref options 'preprocess #f))
(compile? (option-ref options 'compile #f)) (compile? (option-ref options 'compile #f))
(assemble? (option-ref options 'assemble #f)) (assemble? (option-ref options 'assemble #f))
(verbose? (option-ref options 'verbose (getenv "MES_DEBUG")))) (verbose? (count-opt options 'verbose)))
(when verbose? (when verbose?
(setenv "NYACC_TRACE" "yes") (setenv "NYACC_TRACE" "yes")
(format (current-error-port) "options=~s\n" options)) (when (> verbose? 1)
(format (current-error-port) "options=~s\n" options)))
(cond (dumpmachine? (display (mescc:get-host options))) (cond (dumpmachine? (display (mescc:get-host options)))
(preprocess? (mescc:preprocess options)) (preprocess? (mescc:preprocess options))
(compile? (mescc:compile options)) (compile? (mescc:compile options))

19
module/mescc/M1.scm
View file

@ -35,9 +35,9 @@
infos->M1 infos->M1
M1:merge-infos)) M1:merge-infos))
(define* (infos->M1 file-name infos #:key align?) (define* (infos->M1 file-name infos #:key align? verbose?)
(let ((info (fold M1:merge-infos (make <info>) infos))) (let ((info (fold M1:merge-infos (make <info>) infos)))
(info->M1 file-name info #:align? align?))) (info->M1 file-name info #:align? align? #:verbose? verbose?)))
(define (M1:merge-infos o info) (define (M1:merge-infos o info)
(clone info (clone info
@ -100,7 +100,7 @@
(display sep)) (display sep))
(loop (cdr o))))) (loop (cdr o)))))
(define* (info->M1 file-name o #:key align?) (define* (info->M1 file-name o #:key align? verbose?)
(let* ((functions (.functions o)) (let* ((functions (.functions o))
(function-names (map car functions)) (function-names (map car functions))
(globals (.globals o)) (globals (.globals o))
@ -186,7 +186,8 @@
(display-join (map text->M1 o) " ")) (display-join (map text->M1 o) " "))
(else (error "line->M1 invalid line:" o))) (else (error "line->M1 invalid line:" o)))
(newline)) (newline))
(display (string-append " :" name "\n") (current-error-port)) (when verbose?
(display (string-append " :" name "\n") (current-error-port)))
(display (string-append "\n\n:" name "\n")) (display (string-append "\n\n:" name "\n"))
(for-each line->M1 (apply append text)))) (for-each line->M1 (apply append text))))
(define (write-global o) (define (write-global o)
@ -212,8 +213,8 @@
((global? (cdr o)) (global->string (cdr o))) ((global? (cdr o)) (global->string (cdr o)))
(else (car o)))) (else (car o))))
(string? (string-prefix? "_string" label)) (string? (string-prefix? "_string" label))
(foo (if (not (eq? (car (string->list label)) #\_)) (foo (when (and verbose? (not (eq? (car (string->list label)) #\_)))
(display (string-append " :" label "\n") (current-error-port)))) (display (string-append " :" label "\n") (current-error-port))))
(data ((compose global:value cdr) o)) (data ((compose global:value cdr) o))
(data (filter-map labelize data)) (data (filter-map labelize data))
(len (length data)) (len (length data))
@ -236,10 +237,12 @@
(display-join text " ") (display-join text " ")
(display-align (length text)))) (display-align (length text))))
(newline))) (newline)))
(display "M1: functions\n" (current-error-port)) (when verbose?
(display "M1: functions\n" (current-error-port)))
(for-each write-function (filter cdr functions)) (for-each write-function (filter cdr functions))
(when (assoc-ref functions "main") (when (assoc-ref functions "main")
(display "\n\n:ELF_data\n") ;; FIXME (display "\n\n:ELF_data\n") ;; FIXME
(display "\n\n:HEX2_data\n")) (display "\n\n:HEX2_data\n"))
(display "M1: globals\n" (current-error-port)) (when verbose?
(display "M1: globals\n" (current-error-port)))
(for-each write-global globals))) (for-each write-global globals)))

17
module/mescc/compile.scm
View file

@ -49,12 +49,14 @@
(if %reduced-register-count %reduced-register-count (if %reduced-register-count %reduced-register-count
(length (append (.registers info) (.allocated info))))) (length (append (.registers info) (.allocated info)))))
(define* (c99-input->info info #:key (prefix "") (defines '()) (includes '()) (arch "")) (define* (c99-input->info info #:key (prefix "") (defines '()) (includes '()) (arch "") verbose?)
(let ((ast (c99-input->ast #:prefix prefix #:defines defines #:includes includes #:arch arch))) (let ((ast (c99-input->ast #:prefix prefix #:defines defines #:includes includes #:arch arch #:verbose? verbose?)))
(c99-ast->info info ast))) (c99-ast->info info ast #:verbose? verbose?)))
(define* (c99-ast->info info o) (define* (c99-ast->info info o #:key verbose?)
(stderr "compiling: input\n") (when verbose?
(stderr "compiling: input\n")
(set! mescc:trace mescc:trace-verbose))
(let ((info (ast->info o info))) (let ((info (ast->info o info)))
(clean-info info))) (clean-info info)))
@ -427,9 +429,12 @@
(define (make-local-entry name type id) (define (make-local-entry name type id)
(cons name (make-local name type id))) (cons name (make-local name type id)))
(define* (mescc:trace name #:optional (type "")) (define* (mescc:trace-verbose name #:optional (type ""))
(format (current-error-port) " :~a~a\n" name type)) (format (current-error-port) " :~a~a\n" name type))
(define* (mescc:trace name #:optional (type ""))
#t)
(define (expr->arg o i info) (define (expr->arg o i info)
(pmatch o (pmatch o
((p-expr (string ,string)) ((p-expr (string ,string))

50
module/mescc/mescc.scm
View file

@ -28,11 +28,13 @@
#:use-module (mescc preprocess) #:use-module (mescc preprocess)
#:use-module (mescc compile) #:use-module (mescc compile)
#:use-module (mescc M1) #:use-module (mescc M1)
#:export (mescc:preprocess #:export (count-opt
mescc:preprocess
mescc:get-host mescc:get-host
mescc:compile mescc:compile
mescc:assemble mescc:assemble
mescc:link)) mescc:link
multi-opt))
(define GUILE-with-output-to-file with-output-to-file) (define GUILE-with-output-to-file with-output-to-file)
(define (with-output-to-file file-name thunk) (define (with-output-to-file file-name thunk)
@ -55,13 +57,14 @@
(prefix (option-ref options 'prefix "")) (prefix (option-ref options 'prefix ""))
(machine (option-ref options 'machine "32")) (machine (option-ref options 'machine "32"))
(arch (arch-get options)) (arch (arch-get options))
(defines (cons (arch-get-define options) defines))) (defines (cons (arch-get-define options) defines))
(verbose? (count-opt options 'verbose)))
(with-output-to-file ast-file-name (with-output-to-file ast-file-name
(lambda _ (for-each (cut c->ast prefix defines includes arch pretty-print/write <>) files))))) (lambda _ (for-each (cut c->ast prefix defines includes arch pretty-print/write verbose? <>) files)))))
(define (c->ast prefix defines includes arch write file-name) (define (c->ast prefix defines includes arch write verbose? file-name)
(with-input-from-file file-name (with-input-from-file file-name
(cut write (c99-input->ast #:prefix prefix #:defines defines #:includes includes #:arch arch)))) (cut write (c99-input->ast #:prefix prefix #:defines defines #:includes includes #:arch arch #:verbose? verbose?))))
(define (mescc:compile options) (define (mescc:compile options)
(let* ((files (option-ref options '() '("a.c"))) (let* ((files (option-ref options '() '("a.c")))
@ -71,12 +74,12 @@
(option-ref options 'output #f))) (option-ref options 'output #f)))
(else (replace-suffix input-base ".s")))) (else (replace-suffix input-base ".s"))))
(infos (map (cut file->info options <>) files)) (infos (map (cut file->info options <>) files))
(verbose? (option-ref options 'verbose #f)) (verbose? (count-opt options 'verbose))
(align? (option-ref options 'align #f))) (align? (option-ref options 'align #f)))
(when verbose? (when verbose?
(stderr "dumping: ~a\n" M1-file-name)) (stderr "dumping: ~a\n" M1-file-name))
(with-output-to-file M1-file-name (with-output-to-file M1-file-name
(cut infos->M1 M1-file-name infos #:align? align?)) (cut infos->M1 M1-file-name infos #:align? align? #:verbose? verbose?))
M1-file-name)) M1-file-name))
(define (file->info options file-name) (define (file->info options file-name)
@ -90,13 +93,15 @@
(includes (cons dir includes)) (includes (cons dir includes))
(prefix (option-ref options 'prefix "")) (prefix (option-ref options 'prefix ""))
(defines (cons (arch-get-define options) defines)) (defines (cons (arch-get-define options) defines))
(arch (arch-get options))) (arch (arch-get options))
(verbose? (count-opt options 'verbose)))
(with-input-from-file file-name (with-input-from-file file-name
(cut c99-input->info (arch-get-info options) #:prefix prefix #:defines defines #:includes includes #:arch arch)))) (cut c99-input->info (arch-get-info options) #:prefix prefix #:defines defines #:includes includes #:arch arch #:verbose? verbose?))))
(define (E->info options file-name) (define (E->info options file-name)
(let ((ast (with-input-from-file file-name read))) (let ((ast (with-input-from-file file-name read))
(c99-ast->info (arch-get-info options) ast))) (verbose? (count-opt options 'verbose)))
(c99-ast->info (arch-get-info options) ast #:verbose? verbose?)))
(define (mescc:assemble options) (define (mescc:assemble options)
(let* ((files (option-ref options '() '("a.c"))) (let* ((files (option-ref options '() '("a.c")))
@ -155,7 +160,7 @@
(M1-file-name (replace-suffix hex2-file-name ".s")) (M1-file-name (replace-suffix hex2-file-name ".s"))
(options (acons 'compile #t options)) ; ugh (options (acons 'compile #t options)) ; ugh
(options (acons 'output hex2-file-name options)) (options (acons 'output hex2-file-name options))
(verbose? (option-ref options 'verbose #f)) (verbose? (count-opt options 'verbose))
(align? (option-ref options 'align #f))) (align? (option-ref options 'align #f)))
(when verbose? (when verbose?
(stderr "dumping: ~a\n" M1-file-name)) (stderr "dumping: ~a\n" M1-file-name))
@ -173,7 +178,7 @@
((option-ref options 'assemble #f) ((option-ref options 'assemble #f)
(replace-suffix input-base ".o")) (replace-suffix input-base ".o"))
(else (replace-suffix M1-file-name ".o")))) (else (replace-suffix M1-file-name ".o"))))
(verbose? (option-ref options 'verbose #f)) (verbose? (count-opt options 'verbose))
(M1 (or (getenv "M1") "M1")) (M1 (or (getenv "M1") "M1"))
(command `(,M1 (command `(,M1
"--LittleEndian" "--LittleEndian"
@ -181,7 +186,7 @@
"-f" ,(arch-find options (arch-get-m1-macros options)) "-f" ,(arch-find options (arch-get-m1-macros options))
,@(append-map (cut list "-f" <>) M1-files) ,@(append-map (cut list "-f" <>) M1-files)
"-o" ,hex2-file-name))) "-o" ,hex2-file-name)))
(when verbose? (when (and verbose? (> verbose? 1))
(stderr "~a\n" (string-join command))) (stderr "~a\n" (string-join command)))
(and (zero? (apply assert-system* command)) (and (zero? (apply assert-system* command))
hex2-file-name))) hex2-file-name)))
@ -190,7 +195,7 @@
(let* ((input-file-name (car (option-ref options '() '("a.c")))) (let* ((input-file-name (car (option-ref options '() '("a.c"))))
(elf-file-name (cond ((option-ref options 'output #f)) (elf-file-name (cond ((option-ref options 'output #f))
(else "a.out"))) (else "a.out")))
(verbose? (option-ref options 'verbose #f)) (verbose? (count-opt options 'verbose))
(hex2 (or (getenv "HEX2") "hex2")) (hex2 (or (getenv "HEX2") "hex2"))
(base-address (option-ref options 'base-address "0x1000000")) (base-address (option-ref options 'base-address "0x1000000"))
(machine (arch-get-machine options)) (machine (arch-get-machine options))
@ -210,7 +215,7 @@
"-f" ,elf-footer "-f" ,elf-footer
"--exec_enable" "--exec_enable"
"-o" ,elf-file-name))) "-o" ,elf-file-name)))
(when verbose? (when (and verbose? (> verbose? 1))
(stderr "~a\n" (string-join command))) (stderr "~a\n" (string-join command)))
(and (zero? (apply assert-system* command)) (and (zero? (apply assert-system* command))
elf-file-name))) elf-file-name)))
@ -220,13 +225,13 @@
(M1-blood-elf-footer (string-append M1-file-name ".blood-elf")) (M1-blood-elf-footer (string-append M1-file-name ".blood-elf"))
(hex2-file-name (replace-suffix M1-file-name ".o")) (hex2-file-name (replace-suffix M1-file-name ".o"))
(blood-elf-footer (string-append hex2-file-name ".blood-elf")) (blood-elf-footer (string-append hex2-file-name ".blood-elf"))
(verbose? (option-ref options 'verbose #f)) (verbose? (count-opt options 'verbose))
(blood-elf (or (getenv "BLOOD_ELF") "blood-elf")) (blood-elf (or (getenv "BLOOD_ELF") "blood-elf"))
(command `(,blood-elf (command `(,blood-elf
"-f" ,(arch-find options (arch-get-m1-macros options)) "-f" ,(arch-find options (arch-get-m1-macros options))
,@(append-map (cut list "-f" <>) M1-files) ,@(append-map (cut list "-f" <>) M1-files)
"-o" ,M1-blood-elf-footer))) "-o" ,M1-blood-elf-footer)))
(when verbose? (when (and verbose? (> verbose? 1))
(format (current-error-port) "~a\n" (string-join command))) (format (current-error-port) "~a\n" (string-join command)))
(and (zero? (apply assert-system* command)) (and (zero? (apply assert-system* command))
(let* ((options (acons 'compile #t options)) ; ugh (let* ((options (acons 'compile #t options)) ; ugh
@ -258,9 +263,9 @@
(prefix-file options "lib") (prefix-file options "lib")
(filter-map (multi-opt 'library-dir) options))) (filter-map (multi-opt 'library-dir) options)))
(arch-file-name (string-append arch "/" file-name)) (arch-file-name (string-append arch "/" file-name))
(verbose? (option-ref options 'verbose #f))) (verbose? (count-opt options 'verbose)))
(let ((file (search-path path arch-file-name))) (let ((file (search-path path arch-file-name)))
(when verbose? (when (and verbose? (> verbose? 1))
(stderr "arch-find=~s\n" arch-file-name) (stderr "arch-find=~s\n" arch-file-name)
(stderr " path=~s\n" path) (stderr " path=~s\n" path)
(stderr " => ~s\n" file)) (stderr " => ~s\n" file))
@ -325,6 +330,9 @@
((equal? arch "x86_64") "amd64")))) ((equal? arch "x86_64") "amd64"))))
(define (multi-opt option-name) (lambda (o) (and (eq? (car o) option-name) (cdr o)))) (define (multi-opt option-name) (lambda (o) (and (eq? (car o) option-name) (cdr o))))
(define (count-opt options option-name)
(let ((lst (filter-map (multi-opt option-name) options)))
(and (pair? lst) (length lst))))
(define (.c? o) (or (string-suffix? ".c" o) (define (.c? o) (or (string-suffix? ".c" o)
(string-suffix? ".M2" o))) (string-suffix? ".M2" o)))

50
module/mescc/preprocess.scm
View file

@ -77,34 +77,40 @@
(define mes? (pair? (current-module))) (define mes? (pair? (current-module)))
(define* (c99-input->full-ast #:key (prefix "") (defines '()) (includes '()) (arch "")) (define* (c99-input->full-ast #:key (prefix "") (defines '()) (includes '()) (arch "") verbose?)
(let* ((sys-include (if (equal? prefix "") "include" (let* ((sys-include (if (equal? prefix "") "include"
(string-append prefix "/include"))) (string-append prefix "/include")))
(kernel "linux") (kernel "linux")
(kernel-include (string-append sys-include "/" kernel "/" arch))) (kernel-include (string-append sys-include "/" kernel "/" arch))
(includes (append
includes
(cons* kernel-include
sys-include
(append (or (and=> (getenv "CPATH")
(cut string-split <> #\:)) '())
(or (and=> (getenv "C_INCLUDE_PATH")
(cut string-split <> #\:)) '())))))
(defines `(
"NULL=0"
"__linux__=1"
"_POSIX_SOURCE=0"
"SYSTEM_LIBC=0"
"__STDC__=1"
"__MESC__=1"
,(if mes? "__MESC_MES__=1" "__MESC_MES__=0")
,@defines)))
(when (and verbose? (> verbose? 1))
(stderr "includes: ~s\n" includes)
(stderr "defines: ~s\n" defines))
(parse-c99 (parse-c99
#:inc-dirs (append #:inc-dirs includes
includes #:cpp-defs defines
(cons* kernel-include
sys-include
(append (or (and=> (getenv "CPATH")
(cut string-split <> #\:)) '())
(or (and=> (getenv "C_INCLUDE_PATH")
(cut string-split <> #\:)) '()))))
#:cpp-defs `(
"NULL=0"
"__linux__=1"
"_POSIX_SOURCE=0"
"SYSTEM_LIBC=0"
"__STDC__=1"
"__MESC__=1"
,(if mes? "__MESC_MES__=1" "__MESC_MES__=0")
,@defines)
#:mode 'code))) #:mode 'code)))
(define* (c99-input->ast #:key (prefix "") (defines '()) (includes '()) (arch "")) (define* (c99-input->ast #:key (prefix "") (defines '()) (includes '()) (arch "") verbose?)
(stderr "parsing: input\n") (when verbose?
((compose ast-strip-const ast-strip-comment) (c99-input->full-ast #:prefix prefix #:defines defines #:includes includes #:arch arch))) (stderr "parsing: input\n"))
((compose ast-strip-const ast-strip-comment) (c99-input->full-ast #:prefix prefix #:defines defines #:includes includes #:arch arch #:verbose? verbose?)))
(define (ast-strip-comment o) (define (ast-strip-comment o)
(pmatch o (pmatch o