diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index c283eb6..b6d4bf7 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -587,7 +587,9 @@ (intmap-for-each (lambda (kfun body) (compile-function (intmap-select exp body) asm)) (compute-reachable-functions exp 0)) - (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f)) + (values (link-assembly asm + #:page-aligned? (kw-arg-ref opts #:to-file? #f) + #:debug? (kw-arg-ref opts #:debug-info? #t)) env env))) diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm index 939fb25..ff20bca 100644 --- a/module/scripts/compile.scm +++ b/module/scripts/compile.scm @@ -42,6 +42,7 @@ #:export (compile)) (define %summary "Compile a file.") +(define debug-options '(#:debug-info? #t)) (define (fail . messages) @@ -116,6 +117,28 @@ (return-option (substring arg 3) #f)) (else (return-option arg #t))))) + + (option '(#\g "debug") #t #f + (lambda (opt name arg result) + (define (return val) + (alist-cons 'debug val result)) + (define (return-option name val) + (let ((kw (symbol->keyword + (string->symbol (string-append name "?"))))) + (unless (memq kw debug-options) + (fail "Unknown debug option `~a'" name)) + (return (list kw val)))) + (cond + ((string=? arg "help") + (show-debug-help) + (exit 0)) + ((equal? arg "0") (return '(#:debug-info? #f))) + ((equal? arg "1") (return '(#:debug-info? #t))) + ((string-prefix? "no-" arg) + (return-option (substring arg 3) #f)) + (else + (return-option arg #t))))) + (option '(#\f "from") #t #f (lambda (opt name arg result) (if (assoc-ref result 'from) @@ -185,6 +208,27 @@ There is NO WARRANTY, to the extent permitted by law.~%")) (format #t "everything. The default is equivalent to `-O2'.") (format #t "~%")) +(define (show-debug-help) + (format #t "The available debug options are:~%~%") + (let lp ((options debug-options)) + (match options + (() #t) + ((kw val . options) + (let ((name (string-trim-right (symbol->string (keyword->symbol kw)) + #\?))) + (format #t " -g~a~%" + (if val name (string-append "no-" name))) + (lp options))))) + (format #t "~%") + (format #t "To disable an debug info level, prepend it with `no-', for example~%") + (format #t "`-gno-debug-info'~%~%") + (format #t "You may also specify debug levels as `-g0', `-g1'.~%") + (format #t "Currently `-g0' removes debug info from the compiled file~%") + (format #t "and remove all debug information,~%") + (format #t "`-g1' have all debug info inserted in the compiled file.~%") + (format #t "The default is equivalent to `-g1'.") + (format #t "~%")) + (define (compile . args) (let* ((options (parse-args args)) @@ -195,6 +239,7 @@ There is NO WARRANTY, to the extent permitted by law.~%")) (lambda (opt) (match opt (('optimizations . opts) opts) + (('debug . opts) opts) (_ '()))) options))) (from (or (assoc-ref options 'from) 'scheme)) @@ -217,7 +262,8 @@ Compile each Guile source file FILE into a Guile object. for a list of available warnings -O, --optimize=OPT specify optimization passes to run; use `-Ohelp' for a list of available optimizations - + -g, --debug=OPT specify debug information availability; use `-ghelp' + for a list of available debug options -f, --from=LANG specify a source language other than `scheme' -t, --to=LANG specify a target language other than `bytecode' -T, --target=TRIPLET produce bytecode for host TRIPLET diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 8d71dc5..bf96d3b 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -2194,7 +2194,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If ;; The size of a procprops entry, in bytes. (define procprops-size 8) - + (define (link-procprops asm) (define (assoc-remove-one alist key value-pred) (match alist @@ -2575,7 +2575,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If (make-object asm '.debug_line bv line-relocs '() #:type SHT_PROGBITS #:flags 0))))) -(define (link-objects asm) +(define* (link-objects asm debug?) (let*-values (;; Link procprops before constants, because it probably ;; interns more constants. ((procprops) (link-procprops asm)) @@ -2588,16 +2588,21 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If ((symtab strtab) (link-symtab (linker-object-section text) asm)) ((arities arities-strtab) (link-arities asm)) ((docstrs docstrs-strtab) (link-docstrs asm)) - ((dinfo dabbrev dstrtab dloc dline) (link-debug asm)) + ((debug-tables) + (values + (if debug? + (call-with-values (lambda () (link-debug asm)) list) + '()))) ;; This needs to be linked last, because linking other ;; sections adds entries to the string table. ((shstrtab) (link-shstrtab asm))) (filter identity - (list text ro frame-maps rw dt symtab strtab - arities arities-strtab - docstrs docstrs-strtab procprops - dinfo dabbrev dstrtab dloc dline - shstrtab)))) + (append + (list text ro frame-maps rw dt symtab strtab + arities arities-strtab + docstrs docstrs-strtab procprops) + debug-tables + (list shstrtab))))) @@ -2606,9 +2611,10 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If ;;; High-level public interfaces. ;;; -(define* (link-assembly asm #:key (page-aligned? #t)) +(define* (link-assembly asm #:key (page-aligned? #t) (debug? #t)) "Produce an ELF image from the code and data emitted into @var{asm}. The result is a bytevector, by default linked so that read-only and writable data are on separate pages. Pass @code{#:page-aligned? #f} to -disable this behavior." - (link-elf (link-objects asm) #:page-aligned? page-aligned?)) +disable this behavior. Pass @code{debug? #f} to remove debug info from +the elf image" + (link-elf (link-objects asm debug?) #:page-aligned? page-aligned?))