#| -*-Scheme-*-
-$Id: asstop.scm,v 1.11 1999/01/02 06:06:43 cph Exp $
+$Id: asstop.scm,v 1.12 2001/08/10 17:10:28 cph Exp $
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
|#
;;;; Assembler and Linker top level
*label-bindings*
(last-reference *external-labels*))))
(cond ((eq? pathname 'KEEP) ; for dynamic execution
- info)
+ (vector 'DEBUGGING-INFO-WRAPPER
+ 2
+ #f
+ #f
+ #f
+ info))
((eq? pathname 'RECURSIVE) ; recursive compilation
(set! *recursive-compilation-results*
(cons (vector *recursive-compilation-number*
info
*code-vector*)
*recursive-compilation-results*))
- (cons *info-output-filename* *recursive-compilation-number*))
+ (vector 'DEBUGGING-INFO-WRAPPER
+ 2
+ *debugging-key*
+ *info-output-filename*
+ *recursive-compilation-number*
+ #f))
(else
(compiler:dump-info-file
- (let ((others (recursive-compilation-results)))
- (if (null? others)
- info
- (list->vector
- (cons info
- (map (lambda (other) (vector-ref other 1))
- others)))))
+ (vector 'DEBUGGING-FILE-WRAPPER
+ 2
+ *debugging-key*
+ (list->vector
+ (cons info
+ (map (lambda (other) (vector-ref other 1))
+ (recursive-compilation-results)))))
pathname)
- *info-output-filename*)))))))
+ (vector 'DEBUGGING-INFO-WRAPPER
+ 2
+ *debugging-key*
+ *info-output-filename*
+ 0
+ #f))))))))
(define (recursive-compilation-results)
(sort *recursive-compilation-results*
- (lambda (x y)
- (< (vector-ref x 0)
- (vector-ref y 0)))))
+ (lambda (x y)
+ (fix:< (vector-ref x 0) (vector-ref y 0)))))
\f
;;; Various ways of dumping an info file
(define (compiler:dump-inf-file binf pathname)
- (fasdump binf pathname true)
+ (fasdump binf pathname #t)
(announce-info-files pathname))
(define (compiler:dump-bif/bsm-files binf pathname)
(let ((bif-path (pathname-new-type pathname "bif"))
(bsm-path (pathname-new-type pathname "bsm")))
(let ((bsm (split-inf-structure! binf bsm-path)))
- (fasdump binf bif-path true)
- (fasdump bsm bsm-path true))
+ (fasdump binf bif-path #t)
+ (fasdump bsm bsm-path #t))
(announce-info-files bif-path bsm-path)))
(define (compiler:dump-bci/bcs-files binf pathname)
(let ((bsm (split-inf-structure! binf bcs-path)))
(call-with-temporary-filename
(lambda (bif-name)
- (fasdump binf bif-name true)
+ (fasdump binf bif-name #t)
(compress bif-name bci-path)))
(call-with-temporary-filename
(lambda (bsm-name)
- (fasdump bsm bsm-name true)
+ (fasdump bsm bsm-name #t)
(compress bsm-name bcs-path))))
(announce-info-files bci-path bcs-path)))
(define (compiler:dump-bci-file binf pathname)
(let ((bci-path (pathname-new-type pathname "bci")))
- (split-inf-structure! binf false)
+ (split-inf-structure! binf #f)
(call-with-temporary-filename
(lambda (bif-name)
- (fasdump binf bif-name true)
+ (fasdump binf bif-name #t)
(compress bif-name bci-path)))
(announce-info-files bci-path)))
#| -*-Scheme-*-
-$Id: make.scm,v 4.110 1999/01/03 05:23:02 cph Exp $
+$Id: make.scm,v 4.111 2001/08/10 17:11:15 cph Exp $
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
|#
;;;; Compiler: System Construction
'INITIALIZE-PACKAGE!)))))
(initialize-package! '(COMPILER MACROS))
(initialize-package! '(COMPILER DECLARATIONS)))
- (add-identification! (string-append "Liar (" architecture-name ")") 4 110))
\ No newline at end of file
+ (add-identification! (string-append "Liar (" architecture-name ")") 4 111))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: toplev.scm,v 4.59 2000/01/10 03:47:47 cph Exp $
+$Id: toplev.scm,v 4.60 2001/08/10 17:10:33 cph Exp $
-Copyright (c) 1988-2000 Massachusetts Institute of Technology
+Copyright (c) 1988-2001 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
|#
;;;; Compiler Top Level
(let ((kernel
(lambda (source-file)
(with-values
- (lambda () (sf/pathname-defaulting source-file false false))
+ (lambda () (sf/pathname-defaulting source-file #f #f))
(lambda (source-pathname bin-pathname spec-pathname)
;; Maybe this should be done only if scode-file
;; does not exist or is older than source-file.
(compiler-pathnames
input-string
(and (not (default-object? output-string)) output-string)
- (make-pathname false false false false "bin" 'NEWEST)
+ (make-pathname #f #f #f #f "bin" 'NEWEST)
(lambda (input-pathname output-pathname)
(maybe-open-file
compiler:generate-rtl-files?
(maybe-open-file compiler:generate-lap-files?
(pathname-new-type output-pathname "lap")
(lambda (lap-output-port)
- (compile-scode/internal
- (compiler-fasload input-pathname)
- (pathname-new-type output-pathname "inf")
- rtl-output-port
- lap-output-port)))))))
+ (fluid-let ((*debugging-key*
+ (random-byte-vector 32)))
+ (compile-scode/internal
+ (compiler-fasload input-pathname)
+ (pathname-new-type output-pathname "inf")
+ rtl-output-port
+ lap-output-port))))))))
unspecific)))
+(define *debugging-key*)
+
(define (maybe-open-file open? pathname receiver)
(if open?
(call-with-output-file pathname receiver)
- (receiver false)))
+ (receiver #f)))
\f
(define (compiler-pathnames input-string output-string default transform)
(let* ((core
(procedure-environment procedure)))
(define (compile-scode/no-file scode keep-debugging-info?)
- (fluid-let ((compiler:noisy? false)
+ (fluid-let ((compiler:noisy? #f)
(*info-output-filename* keep-debugging-info?))
(compile-scode/internal/hook
(lambda ()
- (compile-scode/internal scode
- *info-output-filename*)))))
+ (compile-scode/internal scode keep-debugging-info?)))))
(define (compiler:batch-compile input #!optional output)
- (fluid-let ((compiler:batch-mode? true))
+ (fluid-let ((compiler:batch-mode? #t))
(bind-condition-handler (list condition-type:error)
compiler:batch-error-handler
(lambda ()
(fresh-line port)
(write-condition-report condition port)
(newline port))
- (compiler:abort false))
+ (compiler:abort #f))
(define (compiler:abort value)
(if (not compiler:abort-handled?)
(call-with-current-continuation
(lambda (abort-compilation)
(fluid-let ((compiler:abort-continuation abort-compilation)
- (compiler:abort-handled? true))
+ (compiler:abort-handled? #t))
(real-kernel input-string))))))
-(define compiler:batch-mode? false)
-(define compiler:abort-handled? false)
+(define compiler:batch-mode? #f)
+(define compiler:abort-handled? #f)
(define compiler:abort-continuation)
\f
(define (compile-recursively scode procedure-result? procedure-name)
(define *process-time*)
(define *real-time*)
-(define *info-output-filename* false)
-(define *rtl-output-port* false)
-(define *lap-output-port* false)
+(define *info-output-filename* #f)
+(define *rtl-output-port* #f)
+(define *lap-output-port* #f)
;; First set: input to compilation
;; Last used: phase/canonicalize-scode
(run-compiler))
(fluid-let ((*recursive-compilation-number* 0)
(*recursive-compilation-count* 1)
- (*procedure-result?* false)
+ (*procedure-result?* #f)
(*remote-links* '())
(*process-time* 0)
(*real-time* 0))
(define (compiler:reset!)
(set! *recursive-compilation-number* 0)
(set! *recursive-compilation-count* 1)
- (set! *procedure-result?* false)
+ (set! *procedure-result?* #f)
(set! *remote-links* '())
(set! *process-time* 0)
(set! *real-time* 0)
wrapper)
(let ((info-output-pathname
(if (default-object? info-output-pathname)
- false
+ #f
info-output-pathname))
(rtl-output-port
- (if (default-object? rtl-output-port) false rtl-output-port))
+ (if (default-object? rtl-output-port) #f rtl-output-port))
(lap-output-port
- (if (default-object? lap-output-port) false lap-output-port))
+ (if (default-object? lap-output-port) #f lap-output-port))
(wrapper
(if (default-object? wrapper) in-compiler wrapper)))
(fluid-let ((*info-output-filename*
(set! *rtl-graphs* rgraphs)
unspecific))
(if *procedure-result?*
- (set! *rtl-expression* false))
+ (set! *rtl-expression* #f))
(set! label->object
(make/label->object *rtl-expression*
*rtl-procedures*
(define (phase/rtl-optimization-cleanup)
(if (not compiler:preserve-data-structures?)
(for-each (lambda (rgraph)
- (set-rgraph-bblocks! rgraph false)
+ (set-rgraph-bblocks! rgraph #f)
;; **** this slot is reused. ****
- ;;(set-rgraph-register-bblock! rgraph false)
- (set-rgraph-register-crosses-call?! rgraph false)
- (set-rgraph-register-n-deaths! rgraph false)
- (set-rgraph-register-live-length! rgraph false)
- (set-rgraph-register-n-refs! rgraph false)
- (set-rgraph-register-known-values! rgraph false))
+ ;;(set-rgraph-register-bblock! rgraph #f)
+ (set-rgraph-register-crosses-call?! rgraph #f)
+ (set-rgraph-register-n-deaths! rgraph #f)
+ (set-rgraph-register-live-length! rgraph #f)
+ (set-rgraph-register-n-refs! rgraph #f)
+ (set-rgraph-register-known-values! rgraph #f))
*rtl-graphs*)))
(define (phase/rtl-file-output scode port)
(vector environment-label free-ref-label n-sections))
unspecific))
(begin
- (let ((prefix (generate-lap *rtl-graphs* *remote-links* false)))
+ (let ((prefix (generate-lap *rtl-graphs* *remote-links* #f)))
(node-insert-snode! (rtl-expr/entry-node *rtl-root*)
(make-sblock prefix)))
(set! *entry-label* (rtl-expr/label *rtl-root*))
(compiler-phase "LAP File Output"
(lambda ()
(fluid-let ((*unparser-radix* 16)
- (*unparse-uninterned-symbols-by-name?* true))
+ (*unparse-uninterned-symbols-by-name?* #t))
(with-output-to-port port
(lambda ()
(write-string "LAP for object ")
#| -*-Scheme-*-
-$Id: conpar.scm,v 14.38 1999/02/24 21:23:46 cph Exp $
+$Id: conpar.scm,v 14.39 2001/08/10 17:09:13 cph Exp $
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
|#
;;;; Continuation Parser
(write-string "within ")
(let ((block (stack-frame/ref frame hardware-trap/pc-info1-index)))
(write block)
- (let loop ((info (compiled-code-block/debugging-info block)))
- (cond ((null? info)
- #f)
- ((string? info)
- (begin
- (write-string " (")
- (write-string info)
- (write-string ")")))
- ((not (pair? info))
- #f)
- ((string? (car info))
- (loop (car info)))
- (else
- (loop (cdr info)))))))
+ (call-with-values
+ (lambda () (compiled-code-block/filename-and-index block))
+ (lambda (filename index)
+ index
+ (if filename
+ (begin
+ (write-string " (")
+ (write-string filename)
+ (write-string ")")))))))
((3) ; probably compiled-code
(write-string " at an unknown compiled-code location."))
((4) ; builtin (i.e. hook)
#| -*-Scheme-*-
-$Id: infstr.scm,v 1.10 2001/03/21 19:15:10 cph Exp $
+$Id: infstr.scm,v 1.11 2001/08/10 17:09:18 cph Exp $
Copyright (c) 1988-2001 Massachusetts Institute of Technology
((ucode-primitive string->symbol)
"#[(runtime compiler-info)dbg-info]"))
(conc-name dbg-info/))
- (expression false read-only true) ;dbg-expression
- (procedures false read-only true) ;vector of dbg-procedure
- (continuations false read-only true) ;vector of dbg-continuation
- (labels/desc false read-only false) ;vector of dbg-label, sorted by offset
+ (expression #f read-only #t) ;dbg-expression
+ (procedures #f read-only #t) ;vector of dbg-procedure
+ (continuations #f read-only #t) ;vector of dbg-continuation
+ (labels/desc #f read-only #f) ;vector of dbg-label, sorted by offset
)
(define (dbg-info/labels dbg-info)
((ucode-primitive string->symbol)
"#[(runtime compiler-info)dbg-expression]"))
(conc-name dbg-expression/))
- (block false read-only true) ;dbg-block
- (label false) ;dbg-label
+ (block #f read-only #t) ;dbg-block
+ (label #f) ;dbg-label
)
(define-integrable (dbg-expression/label-offset expression)
(block label type name required optional rest auxiliary
source-code))
(conc-name dbg-procedure/))
- (block false read-only true) ;dbg-block
- (label false) ;dbg-label
- (type false read-only true)
- (name false read-only true) ;procedure's name
- (required false read-only true) ;names of required arguments
- (optional false read-only true) ;names of optional arguments
- (rest false read-only true) ;name of rest argument, or #F
- (auxiliary false read-only true) ;names of internal definitions
- (external-label false) ;for closure, external entry
- (source-code false read-only true) ;SCode
+ (block #f read-only #t) ;dbg-block
+ (label #f) ;dbg-label
+ (type #f read-only #t)
+ (name #f read-only #t) ;procedure's name
+ (required #f read-only #t) ;names of required arguments
+ (optional #f read-only #t) ;names of optional arguments
+ (rest #f read-only #t) ;name of rest argument, or #F
+ (auxiliary #f read-only #t) ;names of internal definitions
+ (external-label #f) ;for closure, external entry
+ (source-code #f read-only #t) ;SCode
)
(define (dbg-procedure/label-offset procedure)
((ucode-primitive string->symbol)
"#[(runtime compiler-info)dbg-continuation]"))
(conc-name dbg-continuation/))
- (block false read-only true) ;dbg-block
- (label false) ;dbg-label
- (type false read-only true)
- (offset false read-only true) ;difference between sp and block
- (source-code false read-only true)
+ (block #f read-only #t) ;dbg-block
+ (label #f) ;dbg-label
+ (type #f read-only #t)
+ (offset #f read-only #t) ;difference between sp and block
+ (source-code #f read-only #t)
)
(define-integrable (dbg-continuation/label-offset continuation)
make-dbg-block
(type parent original-parent layout stack-link))
(conc-name dbg-block/))
- (type false read-only true) ;continuation, stack, closure, ic
- (parent false read-only true) ;parent block, or #F
- (original-parent false read-only true) ;for closures, closing block
- (layout false read-only true) ;vector of names, except #F for ic
- (stack-link false read-only true) ;next block on stack, or #F
- (procedure false) ;procedure which this is block of
+ (type #f read-only #t) ;continuation, stack, closure, ic
+ (parent #f read-only #t) ;parent block, or #F
+ (original-parent #f read-only #t) ;for closures, closing block
+ (layout #f read-only #t) ;vector of names, except #F for ic
+ (stack-link #f read-only #t) ;next block on stack, or #F
+ (procedure #f) ;procedure which this is block of
)
(define-structure (dbg-variable
((ucode-primitive string->symbol)
"#[(runtime compiler-info)dbg-variable]"))
(conc-name dbg-variable/))
- (name false read-only true) ;symbol
- (type false read-only true) ;normal, cell, integrated
+ (name #f read-only #t) ;symbol
+ (type #f read-only #t) ;normal, cell, integrated
value ;for integrated, the value
)
"#[(runtime compiler-info)dbg-label]"))
(constructor make-dbg-label (name offset))
(conc-name dbg-label-1/))
- (name false) ;a string, primary name
- (offset false read-only true) ;mach. dependent offset into code block
- (external? false) ;if true, can have pointer to this
+ (name #f) ;a string, primary name
+ (offset #f read-only #t) ;mach. dependent offset into code block
+ (external? #f) ;if true, can have pointer to this
(names (list name)) ;names of all labels at this offset
)
(not (negative? offset))
(negative? offset))
(set-cdr! label (- offset))))
- unspecific)
\ No newline at end of file
+ unspecific)
+\f
+;;;; Debugging-info wrappers
+
+(define (compiled-code-block/debugging-wrapper block)
+ (let ((wrapper (compiled-code-block/debugging-info block)))
+ (if (debugging-wrapper? wrapper)
+ wrapper
+ (let ((wrapper (convert-old-debugging-wrapper wrapper)))
+ (if wrapper
+ (set-compiled-code-block/debugging-info! block wrapper))
+ wrapper))))
+
+(define (debugging-wrapper? wrapper)
+ (and (vector? wrapper)
+ (fix:= (vector-length wrapper) 6)
+ (eq? (vector-ref wrapper 0) 'DEBUGGING-INFO-WRAPPER)
+ (or (fix:= (vector-ref wrapper 1) 1)
+ (fix:= (vector-ref wrapper 1) 2))
+ (or (and (not (vector-ref wrapper 2))
+ (not (vector-ref wrapper 3))
+ (not (vector-ref wrapper 4))
+ (dbg-info? (vector-ref wrapper 5)))
+ (and (if (fix:= (vector-ref wrapper 1) 1)
+ (not (vector-ref wrapper 2))
+ (dbg-info-key? (vector-ref wrapper 2)))
+ (debug-info-pathname? (vector-ref wrapper 3))
+ (index-fixnum? (vector-ref wrapper 4))
+ (or (not (vector-ref wrapper 5))
+ (dbg-info? (vector-ref wrapper 5)))))))
+
+(define (debugging-wrapper/version wrapper)
+ (vector-ref wrapper 1))
+
+(define (debugging-wrapper/key wrapper)
+ (vector-ref wrapper 2))
+
+(define (debugging-wrapper/pathname wrapper)
+ (vector-ref wrapper 3))
+
+(define (set-debugging-wrapper/pathname! wrapper pathname)
+ (vector-set! wrapper 3 pathname))
+
+(define (debugging-wrapper/index wrapper)
+ (vector-ref wrapper 4))
+
+(define (debugging-wrapper/info wrapper)
+ (vector-ref wrapper 5))
+
+(define (set-debugging-wrapper/info! wrapper info)
+ (vector-set! wrapper 5 info))
+
+(define (convert-old-debugging-wrapper wrapper)
+ (let ((make-wrapper
+ (lambda (pathname index info)
+ (vector 'DEBUGGING-INFO-WRAPPER 1 #f pathname index info))))
+ (cond ((dbg-info? wrapper)
+ (make-wrapper #f #f wrapper))
+ ((debug-info-pathname? wrapper)
+ (make-wrapper wrapper 0 #f))
+ ((and (pair? wrapper)
+ (debug-info-pathname? (car wrapper))
+ (dbg-info? (cdr wrapper)))
+ (make-wrapper (car wrapper) 0 (cdr wrapper)))
+ ((and (pair? wrapper)
+ (debug-info-pathname? (car wrapper))
+ (index-fixnum? (cdr wrapper))
+ (fix:> (cdr wrapper) 0))
+ (make-wrapper (car wrapper) (cdr wrapper) #f))
+ ((and (pair? wrapper)
+ (pair? (car wrapper))
+ (debug-info-pathname? (caar wrapper))
+ (index-fixnum? (cdar wrapper))
+ (fix:> (cdar wrapper) 0)
+ (dbg-info? (cdr wrapper)))
+ (make-wrapper (caar wrapper) (cdar wrapper) (cdr wrapper)))
+ (else #f))))
+\f
+(define (debugging-file-wrapper? wrapper)
+ (and (vector? wrapper)
+ (fix:= (vector-length wrapper) 4)
+ (eq? (vector-ref wrapper 0) 'DEBUGGING-FILE-WRAPPER)
+ (or (and (fix:= (vector-ref wrapper 1) 1)
+ (not (vector-ref wrapper 2)))
+ (and (fix:= (vector-ref wrapper 1) 2)
+ (dbg-info-key? (vector-ref wrapper 2))))
+ (let ((info (vector-ref wrapper 3)))
+ (let ((n (vector-length info)))
+ (and (fix:>= n 1)
+ (let loop ((i 0))
+ (or (fix:= i n)
+ (and (dbg-info? (vector-ref info i))
+ (loop (fix:+ i 1))))))))))
+
+(define (debugging-file-wrapper/version wrapper)
+ (vector-ref wrapper 1))
+
+(define (debugging-file-wrapper/key wrapper)
+ (vector-ref wrapper 2))
+
+(define (debugging-file-wrapper/info wrapper)
+ (vector-ref wrapper 3))
+
+(define (canonicalize-file-wrapper wrapper)
+ (cond ((debugging-file-wrapper? wrapper)
+ wrapper)
+ ((dbg-info? wrapper)
+ (vector 'DEBUGGING-FILE-WRAPPER 1 #f (vector wrapper)))
+ ((and (vector? wrapper)
+ (let ((n (vector-length wrapper)))
+ (and (fix:>= n 1)
+ (let loop ((i 0))
+ (or (fix:= i n)
+ (and (dbg-info? (vector-ref wrapper i))
+ (loop (fix:+ i 1))))))))
+ (vector 'DEBUGGING-FILE-WRAPPER 1 #f wrapper))
+ (else #f)))
+
+(define (get-wrapped-dbg-info file-wrapper wrapper)
+ (and (let ((k1 (debugging-wrapper/key wrapper))
+ (k2 (debugging-file-wrapper/key file-wrapper)))
+ (or (and k1 k2 (dbg-info-key=? k1 k2))
+ (and (not k1) (not k2))))
+ (let ((v (debugging-file-wrapper/info file-wrapper))
+ (index (debugging-wrapper/index wrapper)))
+ (and (fix:< index (vector-length v))
+ (vector-ref v index)))))
+
+(define (dbg-info-key? object)
+ (and (string? object)
+ (fix:= (string-length object) 32)))
+
+(define (dbg-info-key=? a b)
+ (string=? a b))
+
+(define (debug-info-pathname? object)
+ (or (pathname? object)
+ (string? object)))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: infutl.scm,v 1.64 2001/03/21 19:15:12 cph Exp $
+$Id: infutl.scm,v 1.65 2001/08/10 17:09:23 cph Exp $
Copyright (c) 1988-2001 Massachusetts Institute of Technology
(,lambda-tag:let . LET)
(,lambda-tag:fluid-let . FLUID-LET)
(,lambda-tag:make-environment . MAKE-ENVIRONMENT)))
- (set! blocks-with-memoized-debugging-info (make-population))
+ (set! wrappers-with-memoized-debugging-info (make-population))
(add-secondary-gc-daemon! discard-debugging-info!)
(initialize-uncompressed-files!)
(add-event-receiver! event:after-restore initialize-uncompressed-files!)
(add-gc-daemon! clean-uncompressed-files!))
(define (compiled-code-block/dbg-info block demand-load?)
- (let ((old-info (compiled-code-block/debugging-info block)))
- (cond ((dbg-info? old-info)
- old-info)
- ((and (pair? old-info) (dbg-info? (car old-info)))
- (car old-info))
- (demand-load?
- (let ((dbg-info (read-debugging-info old-info)))
- (if dbg-info (memoize-debugging-info! block dbg-info))
- dbg-info))
- (else #f))))
-
-(define (discard-debugging-info!)
- (without-interrupts
- (lambda ()
- (map-over-population! blocks-with-memoized-debugging-info
- discard-block-debugging-info!)
- (set! blocks-with-memoized-debugging-info (make-population))
- unspecific)))
-
-(define (read-debugging-info descriptor)
- (cond ((debug-info-pathname? descriptor)
- (let ((binf (read-binf-file descriptor)))
- (and binf
- (if (dbg-info? binf)
- binf
- (and (vector? binf)
- (not (zero? (vector-length binf)))
- (vector-ref binf 0))))))
- ((and (pair? descriptor)
- (debug-info-pathname? (car descriptor))
- (exact-nonnegative-integer? (cdr descriptor)))
- (let ((binf (read-binf-file (car descriptor))))
- (and binf
- (vector? binf)
- (< (cdr descriptor) (vector-length binf))
- (vector-ref binf (cdr descriptor)))))
- (else #f)))
+ (let ((wrapper (compiled-code-block/debugging-wrapper block)))
+ (and wrapper
+ (or (debugging-wrapper/info wrapper)
+ (and demand-load?
+ (read-debugging-info wrapper))))))
+
+(define (read-debugging-info wrapper)
+ (let ((pathname (debugging-wrapper/pathname wrapper)))
+ (and pathname
+ (let ((file-wrapper (read-binf-file pathname)))
+ (and file-wrapper
+ (let ((file-wrapper (canonicalize-file-wrapper file-wrapper)))
+ (and file-wrapper
+ (let ((info
+ (get-wrapped-dbg-info file-wrapper wrapper)))
+ (if info
+ (memoize-debugging-info! wrapper info))
+ info))))))))
(define (read-binf-file pathname)
(let ((pathname (canonicalize-debug-info-pathname pathname)))
(if (> time* time)
(loop (cdr left) time* file* receiver*)
(loop (cdr left) time file receiver))))))))
-\f
-(define (memoize-debugging-info! block dbg-info)
+
+(define (memoize-debugging-info! wrapper info)
(without-interrupts
(lambda ()
- (let ((old-info (compiled-code-block/debugging-info block)))
- (if (not (and (pair? old-info) (dbg-info? (car old-info))))
- (begin
- (set-compiled-code-block/debugging-info! block
- (cons dbg-info old-info))
- (add-to-population! blocks-with-memoized-debugging-info
- block)))))))
-
-(define (un-memoize-debugging-info! block)
+ (set-debugging-wrapper/info! wrapper info)
+ (add-to-population! wrappers-with-memoized-debugging-info wrapper))))
+
+(define (discard-debugging-info!)
(without-interrupts
(lambda ()
- (discard-block-debugging-info! block)
- (remove-from-population! blocks-with-memoized-debugging-info block))))
-
-(define (discard-block-debugging-info! block)
- (let ((old-info (compiled-code-block/debugging-info block)))
- (if (and (pair? old-info) (dbg-info? (car old-info)))
- (set-compiled-code-block/debugging-info! block (cdr old-info)))))
+ (map-over-population! wrappers-with-memoized-debugging-info
+ (lambda (wrapper)
+ (set-debugging-wrapper/info! wrapper #f)))
+ (set! wrappers-with-memoized-debugging-info (make-population))
+ unspecific)))
-(define blocks-with-memoized-debugging-info)
+(define wrappers-with-memoized-debugging-info)
\f
(define (compiled-entry/dbg-object entry #!optional demand-load?)
(let ((block (compiled-entry/block entry))
(compiled-code-block/filename-and-index (compiled-entry/block entry)))
(define (compiled-code-block/filename-and-index block)
- (let loop ((info (compiled-code-block/debugging-info block)))
- (cond ((debug-info-pathname? info)
- (values (canonicalize-debug-info-filename info) #f))
- ((not (pair? info)) (values #f #f))
- ((dbg-info? (car info)) (loop (cdr info)))
- ((debug-info-pathname? (car info))
- (values (canonicalize-debug-info-filename (car info))
- (and (exact-nonnegative-integer? (cdr info))
- (cdr info))))
- (else (values #f #f)))))
+ (let ((wrapper (compiled-code-block/debugging-wrapper block)))
+ (if wrapper
+ (let ((pathname (debugging-wrapper/pathname wrapper)))
+ (if pathname
+ (values (canonicalize-debug-info-filename pathname)
+ (debugging-wrapper/index wrapper))
+ (values #f #f)))
+ (values #f #f))))
(define (dbg-labels/find-offset labels offset)
(vector-binary-search labels < dbg-label/offset offset))
(else (error "Illegal dbg-info-vector" info)))))
\f
(define (fasload/update-debugging-info! value com-pathname)
- (let ((process-block
- (lambda (block)
- (let ((binf-filename
- (process-binf-filename
- (compiled-code-block/debugging-info block)
- com-pathname)))
- (set-compiled-code-block/debugging-info! block binf-filename)
- binf-filename)))
- (process-subblocks
- (lambda (blocks start binf-filename)
- (let ((end (vector-length blocks)))
- (let loop ((index start))
- (if (< index end)
- (begin
- (set-car! (compiled-code-block/debugging-info
- (vector-ref blocks index))
- binf-filename)
- (loop (1+ index)))))))))
-
- (cond ((compiled-code-address? value)
- (let ((binf-filename
- (process-block (compiled-code-address->block value)))
- (blocks (load/purification-root value)))
- (if (vector? blocks)
- (process-subblocks blocks 0 binf-filename))))
- ((and (comment? value)
- (dbg-info-vector? (comment-text value)))
- (let ((blocks (dbg-info-vector/blocks-vector (comment-text value))))
- (process-subblocks blocks
- 1
- (process-block (vector-ref blocks 0))))))))
-
-(define (process-binf-filename binf-filename com-pathname)
- (and binf-filename
- (rewrite-directory
- (let ((binf-pathname (merge-pathnames binf-filename))
- (com-pathname (merge-pathnames com-pathname)))
- (if (and (equal? (pathname-name binf-pathname)
- (pathname-name com-pathname))
- (not (equal? (pathname-type binf-pathname)
- (pathname-type com-pathname)))
- (equal? (pathname-version binf-pathname)
- (pathname-version com-pathname)))
- (pathname-new-type com-pathname (pathname-type binf-pathname))
- binf-pathname)))))
-
-(define (debug-info-pathname? object)
- (or (pathname? object)
- (string? object)))
+ (cond ((compiled-code-address? value)
+ (fasload-update-internal (compiled-code-address->block value)
+ (let ((blocks
+ (load/purification-root value)))
+ (and (vector? blocks)
+ blocks))
+ 0
+ com-pathname))
+ ((and (comment? value)
+ (dbg-info-vector? (comment-text value)))
+ (let ((blocks (dbg-info-vector/blocks-vector (comment-text value))))
+ (fasload-update-internal (vector-ref blocks 0)
+ blocks
+ 1
+ com-pathname)))))
+
+(define (fasload-update-internal block blocks start com-pathname)
+ (let ((wrapper (compiled-code-block/debugging-wrapper block)))
+ (if wrapper
+ (let ((pathname (debugging-wrapper/pathname wrapper)))
+ (if pathname
+ (let ((pathname*
+ (fasload-compute-pathname pathname com-pathname)))
+ (set-debugging-wrapper/pathname! wrapper pathname*)
+ (if blocks
+ (fasload-update-sub-blocks blocks start
+ pathname pathname*))))))))
+
+(define (fasload-compute-pathname pathname com-pathname)
+ (rewrite-directory
+ (let ((pathname (merge-pathnames pathname))
+ (com-pathname (merge-pathnames com-pathname)))
+ (if (and (equal? (pathname-name pathname)
+ (pathname-name com-pathname))
+ (not (equal? (pathname-type pathname)
+ (pathname-type com-pathname)))
+ (equal? (pathname-version pathname)
+ (pathname-version com-pathname)))
+ (pathname-new-type com-pathname (pathname-type pathname))
+ pathname))))
+
+(define (fasload-update-sub-blocks blocks start pathname pathname*)
+ (let ((n (vector-length blocks)))
+ (do ((i start (fix:+ i 1)))
+ ((fix:= i n))
+ (let ((wrapper
+ (compiled-code-block/debugging-wrapper (vector-ref blocks i))))
+ (if (and wrapper
+ (pathname? (debugging-wrapper/pathname wrapper))
+ (pathname=? (debugging-wrapper/pathname wrapper) pathname))
+ (set-debugging-wrapper/pathname! wrapper pathname*))))))
\f
(define directory-rewriting-rules
'())
(let* ((infpath (merge-pathnames inffile))
(bifpath (pathname-new-type infpath "bif"))
(bsmpath (pathname-new-type infpath "bsm")))
- (let ((binf (fasload infpath)))
- (inf-structure->bif/bsm binf bifpath bsmpath))))
+ (let ((file-info (fasload infpath)))
+ (inf-structure->bif/bsm file-info bifpath bsmpath))))
-(define (inf-structure->bif/bsm binf bifpath bsmpath)
+(define (inf-structure->bif/bsm file-info bifpath bsmpath)
(let ((bifpath (merge-pathnames bifpath))
(bsmpath (and bsmpath (merge-pathnames bsmpath))))
- (let ((bsm (split-inf-structure! binf bsmpath)))
- (fasdump binf bifpath #t)
- (if bsmpath
- (fasdump bsm bsmpath #t)))))
-
-(define (split-inf-structure! binf bsmpath)
- (let ((bsmname (and bsmpath (->namestring bsmpath))))
- (cond ((dbg-info? binf)
- (let ((labels (dbg-info/labels/desc binf)))
- (set-dbg-info/labels/desc! binf bsmname)
- labels))
- ((vector? binf)
- (let ((n (vector-length binf)))
- (let ((bsm (make-vector n)))
- (do ((i 0 (fix:+ i 1)))
- ((fix:= i n))
- (let ((dbg-info (vector-ref binf i)))
- (let ((labels (dbg-info/labels/desc dbg-info)))
- (vector-set! bsm i labels)
- (set-dbg-info/labels/desc!
- dbg-info
- (and bsmname (cons bsmname i))))))
- bsm)))
- (else
- (error "Unknown inf format:" binf)))))
+ (call-with-values (lambda () (split-inf-structure! file-info bsmpath))
+ (lambda (file-wrapper bsm)
+ (fasdump file-wrapper bifpath #t)
+ (if bsmpath (fasdump bsm bsmpath #t))))))
+
+(define (split-inf-structure! file-info bsmpath)
+ (let ((file-wrapper (canonicalize-file-wrapper file-info))
+ (bsmname (and bsmpath (->namestring bsmpath))))
+ (if (not file-wrapper)
+ (error "Unknown debugging-file format:" file-info))
+ (let ((info (debugging-file-wrapper/info file-wrapper)))
+ (let ((n (vector-length info)))
+ (let ((bsm (make-vector n)))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i n))
+ (let ((dbg-info (vector-ref info i)))
+ (let ((labels (dbg-info/labels/desc dbg-info)))
+ (vector-set! bsm i labels)
+ (set-dbg-info/labels/desc! dbg-info
+ (and bsmname (cons bsmname i))))))
+ (values file-wrapper bsm))))))
\f
;;;; UNCOMPRESS
;;; A simple extractor for compressed binary info files.
;;
;; This version is written for speed:
;;
-;; . The main speed gain is from is by buffering the input. This version
+;; . The main speed gain is from buffering the input. This version
;; is about 10 times faster than the above version on files, and about
;; 1.5 times faster than the above version called on custom input
;; operations.
;; is `single-threaded'. This prevents the compiler from
;; cellifying the variables.
;;
-;; . Some of the drudge in passing all of the state is handed over to the
-;; compiler by making the procedures internal to PARSE-COMMAND.
+;; . Some of the drudgery of passing all of the state is handed over
+;; to the compiler by making the procedures internal to PARSE-COMMAND.
;;
;; . The main loop (PARSE-COMMAND) is `restartable'. This allows the
;; parsing operation to determine if enough input or output buffer is
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.371 2001/08/03 20:29:54 cph Exp $
+$Id: runtime.pkg,v 14.372 2001/08/10 17:09:28 cph Exp $
Copyright (c) 1988-2001 Massachusetts Institute of Technology
(export ()
*save-uncompressed-files?*
*uncompressed-file-lifetime*
+ compiled-code-block/filename-and-index
+ compiled-entry/filename-and-index
compiled-entry/block
compiled-entry/dbg-object
compiled-entry/offset
dbg-procedure/block
dbg-procedure/source-code
dbg-expression?)
- (export (runtime unparser)
- compiled-entry/filename-and-index)
(export (runtime compress)
uncompress-internal)
(export (runtime options)
with-directory-rewriting-rule)
+ (export (runtime continuation-parser)
+ )
(initialization (initialize-package!)))
(define-package (runtime console-i/o-port)
projects / mit-scheme.git / commitdiff